cldc.pas

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

    FreeObjectIfNeed(OpenRequestAction);
  end;
end;

procedure TclDownLoadThreader.SyncDoDataItemProceed;
begin
  if Assigned(OnDataItemProceed) then
  begin
    OnDataItemProceed(Self, ResourceInfo, ResourcePos, FDataProceed, FDataProceedSize);
  end;
end;

{ TclUploadThreader }

constructor TclUploadThreader.Create(const AURL: string; ADataStream: TStream; AIsGetResourceInfo: Boolean);
begin
  inherited Create(AURL, ADataStream);
  FIsGetResourceInfo := AIsGetResourceInfo;
  FDataProceedSize := 0;
  FUploadedDataSize := 0;
  FDataProceed := nil;
  FRequestMethod := 'PUT';
end;

procedure TclUploadThreader.Dump(AResourceAction: TclInternetResourceAction);
var
  Uploaded: Integer;
  WriteFileAction: TclInternetWriteFileAction;
begin
  Dec(FRetryProceed);
  if (DataStream = nil) then Exit;
  Uploaded := 0;
  FUploadedDataSize := 0;
  WriteFileAction := nil;
  GetMem(FDataProceed, FBatchSize + 1);
  try
    WriteFileAction := TclInternetWriteFileAction.Create(Connection, AResourceAction.Internet,
      AResourceAction.hResource);
    while (not Terminated) and (Uploaded < DataStream.Size) do
    begin
      BeginDataStreamAccess();
      try
        DataStream.Position := Uploaded;
        FDataProceedSize := DataStream.Read(FDataProceed^, FBatchSize);
      finally
        EndDataStreamAccess();
      end;
      WriteFileAction.lpBuffer := FDataProceed;
      WriteFileAction.dwNumberOfBytesToWrite := FDataProceedSize;
      WriteFileAction.FireAction(GetNormTimeOut(TimeOut));
      Uploaded := Uploaded + FDataProceedSize; 
      FUploadedDataSize := FUploadedDataSize + FDataProceedSize;
      InternalSynchronize(SyncDoDataItemProceed);
    end;
  finally
    WriteFileAction.Free();
    FreeMem(FDataProceed);
  end;
end;

type
  TclRequestParameters = class(TObject)
    FSendRequestAction: TclHttpSendRequestExAction;
    FEndRequestAction: TclHttpEndRequestAction;
    FOpenRequest: TclHttpOpenRequestAction;
  end;

procedure TclUploadThreader.RequestOperation(AParameters: TObject);
var
  RequestParameters: TclRequestParameters;
begin
  RequestParameters := (AParameters as TclRequestParameters);
  RequestParameters.FSendRequestAction.FireAction(GetNormTimeOut(TimeOut));
  if Terminated then Exit;
  Dump(RequestParameters.FOpenRequest);
  if Terminated then Exit;
  RequestParameters.FEndRequestAction.FireAction(GetNormTimeOut(TimeOut));
end;

procedure TclUploadThreader.ProcessRequest(AOpenRequest: TclHttpOpenRequestAction;
  const AHeader: string; ADataSize: Integer);
var
  RequestParameters: TclRequestParameters;
  SendRequestAction: TclHttpSendRequestExAction;
  EndRequestAction: TclHttpEndRequestAction;
  bufin: INTERNET_BUFFERS;
begin
  ZeroMemory(@bufin, SizeOf(bufin));
  if (AHeader <> '') then
  begin
    bufin.lpcszHeader := PChar(AHeader);
    bufin.dwHeadersLength := Length(AHeader);
  end;
  bufin.dwStructSize := SizeOf(bufin);
  bufin.dwBufferTotal := ADataSize;
  SendRequestAction := nil;
  EndRequestAction := nil;
  RequestParameters := nil;
  try
    SendRequestAction := TclHttpSendRequestExAction.Create(Connection, AOpenRequest.Internet,
      AOpenRequest.hResource, @bufin, nil, HSR_INITIATE);
    EndRequestAction := TclHttpEndRequestAction.Create(Connection, AOpenRequest.Internet,
      AOpenRequest.hResource, nil, HSR_INITIATE);
    RequestParameters := TclRequestParameters.Create();
    RequestParameters.FSendRequestAction := SendRequestAction;
    RequestParameters.FEndRequestAction := EndRequestAction;
    RequestParameters.FOpenRequest := AOpenRequest;
    PerformRequestOperation(AOpenRequest, RequestOperation, RequestParameters);
  finally
    RequestParameters.Free();
    EndRequestAction.Free();
    SendRequestAction.Free();
  end;
end;

procedure TclUploadThreader.GetResourceInfoByDataStream();
begin
  ClearInfo();
  if (DataStream = nil) then
  begin
    raise EclInternetError.Create(cDataStreamAbsent, -1);
  end;
  if (FResourceInfo = nil) then
  begin
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetSize(DataStream.Size);
    TclResourceInfoAccess(ResourceInfo).SetName('');
  end;
end;

procedure TclUploadThreader.ProcessHTTP(AConnect: TclConnectAction);
var
  i: Integer;
  OpenRequestAction: TclHttpOpenRequestAction;
begin
  FRetryCount := GetRetryCount();
  FRetryProceed := FRetryCount + 1;

  if (not FIsGetResourceInfo) then
  begin
    GetResourceInfoByDataStream();
    OpenRequestAction := nil;
    try
      OpenRequestAction := (Connection.GetActionByClass(TclHttpOpenRequestAction) as TclHttpOpenRequestAction);
      if (OpenRequestAction = nil) then
      begin
        OpenRequestAction := TclHttpOpenRequestAction.Create(Connection, AConnect.Internet, AConnect.hResource,
          RequestMethod, URLParser.Urlpath + URLParser.Extra, '', '', nil, GetOpenRequestFlags(False));
        OpenRequestAction.FireAction(GetNormTimeOut(TimeOut));
      end;
      if Terminated then Exit;
      if (ResourceInfo <> nil) then
      begin
        SetHttpHeader(OpenRequestAction);
        i := 0;
        while (i < 4) do
        begin
          Inc(i);
          if UseSimpleRequest then
          begin
            ProcessSimpleRequest(OpenRequestAction, '', DataStream);
          end else
          begin
            ProcessRequest(OpenRequestAction, '', ResourceInfo.Size);
          end;
          try
            GetHttpStatusCode(OpenRequestAction);
            Break;
          except
            if (ResourceInfo.StatusCode = 401) then
            begin
              if UseInternetErrorDialog then
              begin
                SetCertOptions(OpenRequestAction, 0);
              end else
              if (i < 4) then
              begin
                ServerAuthentication(OpenRequestAction);
              end else
              begin
                raise;
              end;
            end else
            if (ResourceInfo.StatusCode = 407) then
            begin
              if UseInternetErrorDialog then
              begin
                SetCertOptions(OpenRequestAction, 0);
              end else
              if (HttpProxySettings.AuthenticationType = atAutoDetect) then
              begin
                ProxyAuthentication(OpenRequestAction);
              end else
              begin
                raise;
              end;
            end else
            begin
              raise;
            end;
          end;
          if Terminated then Exit;
        end;
        if (FRetryCount > 0) then
        begin
          FRetryCount := 0;
          SyncDoDataItemProceed();
        end;
      end;
      GetHttpResponse(OpenRequestAction);
    finally
      FreeObjectIfNeed(OpenRequestAction);
    end;
  end;
  if SameText(RequestMethod, 'PUT') then
  begin
    inherited ProcessHTTP(AConnect);
  end;
end;

procedure TclUploadThreader.ProcessFTP(AConnect: TclConnectAction);
var
  OpenFileAction: TclFtpOpenFileAction;
begin
  FRetryCount := 0;
  FRetryProceed := 0;

  if (not FIsGetResourceInfo) then
  begin
    GetResourceInfoByDataStream();
    OpenFileAction := nil;
    try
      if FForceRemoteDir then
      begin
        ForceRemoteDirectory(AConnect);
      end;
      if Terminated then Exit;
      OpenFileAction := (Connection.GetActionByClass(TclFtpOpenFileAction) as TclFtpOpenFileAction);
      if (OpenFileAction = nil) then
      begin
        OpenFileAction := TclFtpOpenFileAction.Create(Connection, AConnect.Internet, AConnect.hResource,
          URLParser.Urlpath, GENERIC_WRITE, FTP_TRANSFER_TYPE_BINARY);
        OpenFileAction.FireAction(GetNormTimeOut(TimeOut));
      end;
      if Terminated then Exit;
      Dump(OpenFileAction);
    finally
      FreeObjectIfNeed(OpenFileAction);
    end;
  end;
  inherited ProcessFTP(AConnect);
end;

procedure TclUploadThreader.SyncDoDataItemProceed;
var
  uploaded: Integer;
begin
  if Assigned(OnDataItemProceed) then
  begin
    if FRetryCount > 0 then
    begin
      uploaded := FUploadedDataSize div FRetryCount;
      uploaded := (BytesToProceed div FRetryCount) * (FRetryCount - FRetryProceed) + uploaded;
    end else
    begin
      uploaded := FUploadedDataSize;
    end;
    OnDataItemProceed(Self, ResourceInfo, uploaded, FDataProceed, FDataProceedSize);
  end;
end;

procedure TclUploadThreader.GetHttpResponse(AOpenRequest: TclHttpOpenRequestAction);
var
  dwDownloaded: DWORD;
  buf: PChar;
  ReadFileAction: TclInternetReadFileAction;
begin
  if (HttpResponse = nil) or Terminated then Exit;
  ReadFileAction := nil;
  GetMem(buf, FBatchSize);
  try
    ReadFileAction := TclInternetReadFileAction.Create(Connection, AOpenRequest.Internet,
      AOpenRequest.hResource, buf);
    repeat
      ZeroMemory(buf, FBatchSize);
      ReadFileAction.dwNumberOfBytesToRead := FBatchSize;
      ReadFileAction.FireAction(GetNormTimeOut(TimeOut));
      dwDownloaded := ReadFileAction.lpdwNumberOfBytesRead;
      if (dwDownloaded = 0) then Break;
      BeginDataStreamAccess();
      try
        HttpResponse.Write(buf^, dwDownloaded);
      finally
        EndDataStreamAccess();
      end;
    until (Terminated);
  finally
    ReadFileAction.Free();
    FreeMem(buf);
  end;
end;

procedure TclUploadThreader.ForceRemoteDirectory(AConnect: TclConnectAction);
  function ExtractFtpFilePath(const AFileName: string): string;
  var
    i: Integer;
  begin
    i := LastDelimiter('/', AFileName);
    Result := Copy(AFileName, 1, i);
  end;

  function IsFtpPathDelimiter(const S: string; Index: Integer): Boolean;
  begin
    Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = '/')
      and (ByteType(S, Index) = mbSingleByte);
  end;

  function ExcludeTrailingFtpBackslash(const S: string): string;
  begin
    Result := S;
    if IsFtpPathDelimiter(Result, Length(Result)) then
      SetLength(Result, Length(Result)-1);
  end;

  function FtpDirectoryExists(const Name: string): Boolean;
  var
    Action: TclFtpFindFirstFileAction;
  begin
    Action := TclFtpFindFirstFileAction.Create(Connection, AConnect.Internet,
      AConnect.hResource, PChar(Name), INTERNET_FLAG_RELOAD);
    try
      Result := Action.FireAction(GetNormTimeOut(TimeOut), True);
    except
      Result := False;
    end;
    Action.Free();
  end;

  function CreateFtpDir(const Dir: string): Boolean;
  var
    Action: TclFtpCreateDirectoryAction;
  begin
    Action := TclFtpCreateDirectoryAction.Create(Connection, AConnect.Internet, AConnect.hResource, Dir);
    try
      Result := Action.FireAction(GetNormTimeOut(TimeOut), True);
    except
      Result := False;
    end;
    Action.Free();
  end;

  function ForceDirs(Dir: String): Boolean;
  begin
    Result := True;
    if Length(Dir) = 0 then Exit;
    Dir := ExcludeTrailingFtpBackslash(Dir);
    if (Length(Dir) < 1) or FtpDirectoryExists(Dir)
      or (ExtractFtpFilePath(Dir) = Dir) then Exit;
    Result := ForceDirs(ExtractFtpFilePath(Dir)) and CreateFtpDir(Dir);
  end;
  
begin
  ForceDirs(ExtractFtpFilePath(URLParser.Urlpath));
end;

procedure TclUploadThreader.ProcessSimpleRequest(
  AOpenRequest: TclHttpOpenRequestAction; const AHeader: string;
  AData: TStream);
var
  SendRequestAction: TclHttpSendRequestAction;
begin
  FDataProceed := nil;
  SendRequestAction := nil;
  try
    FUploadedDataSize := AData.Size;
    FDataProceedSize := FUploadedDataSize;
    GetMem(FDataProceed, FDataProceedSize + 1);
    ZeroMemory(FDataProceed, FDataProceedSize + 1);
    BeginDataStreamAccess();
    try
      AData.Position := 0;
      AData.Read(FDataProceed^, FDataProceedSize);
    finally
      EndDataStreamAccess();
    end;
    SendRequestAction := TclHttpSendRequestAction.Create(Connection, AOpenRequest.Internet,
      AOpenRequest.hResource, AHeader, FDataProceed, FDataProceedSize);
    PerformRequestOperation(AOpenRequest, SimpleRequestOperation, SendRequestAction);
  finally
    FreeMem(FDataProceed);
    SendRequestAction.Free();
  end;
end;

procedure TclUploadThreader.SimpleRequestOperation(AParameters: TObject);
begin
  (AParameters as TclHttpSendRequestAction).FireAction(GetNormTimeOut(TimeOut));
  InternalSynchronize(SyncDoDataItemProceed);
end;

function TclUploadThreader.GetRetryCount: Integer;
begin
  Result := 0;
  if (not PutOptimization) then
  begin
    Exit;
  end;
  if (URLParser.User <> '') and (URLParser.Password <> '') then
  begin
    Inc(Result);
  end;
  if (HttpProxySettings.UserName <> '') and (HttpProxySettings.Password <> '') then
  begin
    Inc(Result);
  end;
  if (URLParser.UrlType = utHTTPS) then
  begin
    Inc(Result);
  end;
  Inc(Result);
end;

{ TclDeleteThreader }

constructor TclDeleteThreader.Create(const AURL: string);
begin
  inherited Create(AURL, nil);
end;

procedure TclDeleteThreader.ProcessFTP(AConnect: TclConnectAction);
var
  b: Boolean;
begin
  if (URLParser.Urlpath <> '') and (URLParser.Urlpath[Length(URLParser.Urlpath)] = '/') then
  begin
    b := FtpRemoveDirectory(AConnect.hResource, PChar(URLParser.Urlpath));
  end else
  begin
    b := FtpDeleteFile(AConnect.hResource, PChar(URLParser.Urlpath));
  end;
  if not b then
  begin
    raise EclInternetError.CreateByLastError();
  end;
end;

procedure TclDeleteThreader.ProcessHTTP(AConnect: TclConnectAction);
var
  OpenRequestAction: TclHttpOpenRequestAction;
begin
  OpenRequestAction := nil;
  try
    OpenRequestAction := (Connection.GetActionByClass(TclHttpOpenRequestAction) as TclHttpOpenRequestAction);
    if (OpenRequestAction = nil) then
    begin
      OpenRequestAction := TclHttpOpenRequestAction.Create(Connection, AConnect.Internet,
        AConnect.hResource, 'DELETE', URLParser.Urlpath + URLParser.Extra, '', '', nil, GetOpenRequestFlags(False));
      OpenRequestAction.FireAction(GetNormTimeOut(TimeOut));
    end;
    if Terminated then Exit;

    SetHttpHeader(OpenRequestAction);
    SendRequest(OpenRequestAction);
  finally
    FreeObjectIfNeed(OpenRequestAction);
  end;
end;

end.