cldc.pas

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

procedure TclCustomThreader.ProcessURL;
const
  ConnectService: array[Boolean] of DWORD = (INTERNET_SERVICE_HTTP, INTERNET_SERVICE_FTP);
  AccessTypes: array[Boolean] of DWORD = (INTERNET_OPEN_TYPE_PRECONFIG, INTERNET_OPEN_TYPE_PROXY);
  ConnectFlags: array[Boolean] of DWORD = (0, INTERNET_FLAG_PASSIVE);
var
  OpenAction: TclInternetOpenAction;
  ConnectAction: TclConnectAction;
  Proxy, usr, psw: string;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'ProcessURL');{$ENDIF}
  OpenAction := nil;
  ConnectAction := nil;
  try
    OpenAction := (Connection.GetActionByClass(TclInternetOpenAction) as TclInternetOpenAction);
    if (OpenAction = nil) then
    begin
      Proxy := GetProxyString();
      OpenAction := TclInternetOpenAction.Create(Connection, InternetAgent,
        AccessTypes[(Proxy <> '')], Proxy, ProxyBypass, 0);
      OpenAction.FireAction(-1);
    end;
    if Terminated then Exit;
    ConnectAction := (Connection.GetActionByClass(TclConnectAction) as TclConnectAction);
    if (ConnectAction = nil) then
    begin
      if (URLParser.UrlType = utFTP) then
      begin
        usr := URLParser.User;
        psw := URLParser.Password;
      end else
      begin
        usr := '';
        psw := '';
      end;
      ConnectAction := TclConnectAction.Create(Connection, OpenAction.hResource,
        URLParser.Host, URLParser.Port, usr, psw,
        ConnectService[URLParser.UrlType = utFTP], ConnectFlags[(URLParser.UrlType = utFTP) and PassiveFTPMode]);
      ConnectAction.FireAction(GetNormTimeOut(TimeOut));
    end;
    if Terminated then Exit;
    if (URLParser.UrlType = utFTP) then
    begin
      ProcessFTP(ConnectAction);
    end else
    if (URLParser.UrlType in [utHTTP, utHTTPS]) then
    begin
      ProcessHTTP(ConnectAction);
    end;
  finally
    FreeObjectIfNeed(ConnectAction);
    FreeObjectIfNeed(OpenAction);
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'ProcessURL'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'ProcessURL', E); raise; end; end;{$ENDIF}
end;

procedure TclCustomThreader.GetResourceInfo(AConnect: TclConnectAction);
var
  needAllInfo: Boolean;
begin
  if Terminated then Exit;
  ClearInfo();
  needAllInfo := (FResourceInfo = nil);
  if DoNotGetResourceInfo then
  begin
    AssignIfNeedResourceInfo();
  end else
  begin
    case FURLParser.UrlType of
      utHTTP, utHTTPS: GetHTTPResourceInfo(AConnect);
      utFTP: GetFTPResourceInfo(AConnect);
    end;
    if Terminated then Exit;
    if needAllInfo then
    begin
      InternalSynchronize(SyncDoGetResourceInfo);
    end;
  end;
end;

procedure TclCustomThreader.SyncDoGetCertificate;
begin
  if Assigned(FOnGetCertificate) then
  begin
    FOnGetCertificate(Self, FCertificate, FCertificateHandled);
  end;
end;

procedure TclCustomThreader.ProcessFTP(AConnect: TclConnectAction);
begin
  GetResourceInfo(AConnect);
end;

procedure TclCustomThreader.ProcessHTTP(AConnect: TclConnectAction);
begin
  GetResourceInfo(AConnect);
end;

procedure TclCustomThreader.SetResourceInfo(const Value: TclResourceInfo);
begin
  if (ResourceInfo <> Value) then
  begin
    ClearInfo();
    FResourceInfo := Value;
  end;
end;

function TclCustomThreader.GetInternalResourceInfo: TclResourceInfo;
begin
  if (FResourceInfo <> nil) then
  begin
    Result := FResourceInfo;
  end else
  begin
    Result := FSelfResourceInfo;
  end;
end;

procedure TclCustomThreader.BeginDataStreamAccess;
begin
  if (FDataAccessor <> nil) then
  begin
    FDataAccessor.Enter();
  end;
end;

procedure TclCustomThreader.EndDataStreamAccess;
begin
  if (FDataAccessor <> nil) then
  begin
    FDataAccessor.Leave();
  end;
end;

procedure TclCustomThreader.SetURLParser(const Value: TclUrlParser);
begin
  FURLParser.Assign(Value);
end;

function TclCustomThreader.GetConnection: TclInternetConnection;
begin
  if (FConnection <> nil) then
  begin
    Result := FConnection;
  end else
  begin
    if (FSelfConnection = nil) then
    begin
      FSelfConnection := TclInternetConnection.Create(nil);
    end;
    Result := FSelfConnection;
  end;
end;

procedure TclCustomThreader.SetConnection(const Value: TclInternetConnection);
begin
  FConnection := Value;
  FSelfConnection.Free();
  FSelfConnection := nil;
end;

procedure TclCustomThreader.FreeObjectIfNeed(var AObject);
var
  Temp: TObject;
begin
  if not KeepConnection then
  begin
    Temp := TObject(AObject);
    Pointer(AObject) := nil;
    Temp.Free();
  end;
end;

type
  TclInternetConnectionAccess = class(TclInternetConnection);
  
procedure TclCustomThreader.Stop;
begin
  Terminate();
  SetEvent(FSleepEvent);
  DoStop();
end;

procedure TclCustomThreader.DoStop;
begin
  TclInternetConnectionAccess(Connection).Stop();
end;

function TclCustomThreader.GetOpenRequestFlags(ANeedCaching: Boolean): DWORD;
begin
  if ANeedCaching then
  begin
    Result := 0;
  end else
  begin
    Result := INTERNET_FLAG_NO_CACHE_WRITE;
  end;
  if KeepConnection then
  begin
    Result := Result or INTERNET_FLAG_KEEP_CONNECTION;
  end;
  if (URLParser.UrlType = utHTTPS) then
  begin
    Result := Result or INTERNET_FLAG_SECURE;
  end;
end;

procedure TclCustomThreader.DoTerminate;
begin
  if Assigned(OnTerminate) then
  begin
    InternalSynchronize(SyncTerminate);
  end;
end;

procedure TclCustomThreader.SyncTerminate;
begin
  if Assigned(OnTerminate) then
  begin
    OnTerminate(Self);
  end;
end;

procedure TclCustomThreader.SetHttpHeader(AResourceAction: TclInternetResourceAction);
const
  AcceptEncoding = 'Accept-Encoding: gzip, deflate';
var
  s: string;
  auth: TclHttpBasicAuthorization;
  authMethods: TStrings;
begin
  if (RequestHeader.Count > 0) then
  begin
    s := Trim(RequestHeader.Text);
    HttpAddRequestHeaders(AResourceAction.hResource, PChar(s), Length(s), HTTP_ADDREQ_FLAG_ADD_IF_NEW);
  end;

  if AllowCompression then
  begin
    HttpAddRequestHeaders(AResourceAction.hResource, AcceptEncoding,
      Length(AcceptEncoding), HTTP_ADDREQ_FLAG_ADD_IF_NEW);
  end;

  if (HttpProxySettings.AuthenticationType = atBasic)
    and ((HttpProxySettings.UserName <> '') or (HttpProxySettings.Password <> '')) then
  begin
    auth := nil;
    authMethods := nil;
    try
      auth := TclHttpBasicAuthorization.Create();
      authMethods := TStringList.Create();
      authMethods.Add('Basic');

      s := 'Proxy-Authorization: ' + auth.Authenticate(FURLParser, '',
        HttpProxySettings.UserName, HttpProxySettings.Password, authMethods, Self);
      HttpAddRequestHeaders(AResourceAction.hResource, PChar(s), Length(s), HTTP_ADDREQ_FLAG_ADD_IF_NEW);
    finally
      authMethods.Free();
      auth.Free();
    end;
  end;
end;

procedure TclCustomThreader.SetRequestHeader(const Value: TStrings);
begin
  FRequestHeader.Assign(Value);
end;

procedure TclCustomThreader.ServerAuthentication(AOpenRequest: TclHttpOpenRequestAction);
var
  p: PChar;
begin
  if (URLParser.User <> '') then
  begin
    p := PChar(URLParser.User);
    InternetSetOption(AOpenRequest.hResource, INTERNET_OPTION_USERNAME,
      p, Length(URLParser.User));
  end;

  if (URLParser.Password <> '') then
  begin
    p := PChar(URLParser.Password);
    InternetSetOption(AOpenRequest.hResource, INTERNET_OPTION_PASSWORD,
      p, Length(URLParser.Password));
  end;
end;

procedure TclCustomThreader.ProxyAuthentication(AOpenRequest: TclHttpOpenRequestAction);
var
  p: PChar;
begin
  if (HttpProxySettings.UserName <> '') then
  begin
    p := PChar(HttpProxySettings.UserName);
    InternetSetOption(AOpenRequest.hResource, INTERNET_OPTION_PROXY_USERNAME,
      p, Length(HttpProxySettings.UserName));
  end;

  if (HttpProxySettings.Password <> '') then
  begin
    p := PChar(HttpProxySettings.Password);
    InternetSetOption(AOpenRequest.hResource, INTERNET_OPTION_PROXY_PASSWORD,
      p, Length(HttpProxySettings.Password));
  end;
end;

procedure TclCustomThreader.SetFtpProxySettings(const Value: TclFtpProxySettings);
begin
  FFtpProxySettings.Assign(Value);
end;

procedure TclCustomThreader.SetHttpProxySettings(const Value: TclHttpProxySettings);
begin
  FHttpProxySettings.Assign(Value);
end;

{ TclDownLoadThreader }

constructor TclDownLoadThreader.Create(const AURL: string; ADataStream: TStream; AIsGetResourceInfo: Boolean);
begin
  inherited Create(AURL, ADataStream);
  FIsGetResourceInfo := AIsGetResourceInfo;
  FDataProceedSize := 0;
  FTotalDownloaded := 0;
end;

procedure TclDownLoadThreader.SetResourcePos(AResourceAction: TclInternetResourceAction);
var
  s: string;
begin
  if (FBytesToProceed > -1) then
  begin
    s := Format('Range: bytes=%d-%d', [ResourcePos, ResourcePos + FBytesToProceed]);
    HttpAddRequestHeaders(AResourceAction.hResource, PChar(s), Length(s), HTTP_ADDREQ_FLAG_ADD_IF_NEW);
  end else
  if (TempErrorCode <> 12152) then
  begin
    s := 'Range: bytes=0-';
    HttpAddRequestHeaders(AResourceAction.hResource, PChar(s), Length(s), HTTP_ADDREQ_FLAG_ADD_IF_NEW);
  end;
end;

procedure TclDownLoadThreader.Dump(AResourceAction: TclInternetResourceAction);
var
  BytesToRead: Integer;
  ReadFileAction: TclInternetReadFileAction;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Dump');{$ENDIF}
  if (DataStream <> nil) then
  begin
    BeginDataStreamAccess();
    try
      if (FBytesToProceed < 0) then
      begin
        DataStream.Position := 0;
      end;
    finally
      EndDataStreamAccess();
    end;
  end;
  ReadFileAction := nil;
  GetMem(FDataProceed, FBatchSize + 1);
  try
    ReadFileAction := TclInternetReadFileAction.Create(Connection, AResourceAction.Internet,
      AResourceAction.hResource, FDataProceed);
    repeat
      ZeroMemory(FDataProceed, FBatchSize + 1);
      if (FBytesToProceed > -1) and ((FBytesToProceed - FTotalDownloaded) < FBatchSize) then
      begin
        BytesToRead := (FBytesToProceed - FTotalDownloaded);
      end else
      begin
        BytesToRead := FBatchSize;
      end;
      ReadFileAction.dwNumberOfBytesToRead := BytesToRead;
      ReadFileAction.FireAction(GetNormTimeOut(TimeOut));
      FDataProceedSize := ReadFileAction.lpdwNumberOfBytesRead;
      if (FDataProceedSize = 0)
        or ((FBytesToProceed > -1) and (FTotalDownloaded >= FBytesToProceed)) then Break;
      if (DataStream <> nil) then
      begin
        BeginDataStreamAccess();
        try
          if (FBytesToProceed > -1) then
          begin
            DataStream.Position := ResourcePos;
          end;
          DataStream.Write(FDataProceed^, FDataProceedSize);
        finally
          EndDataStreamAccess();
        end;
      end;
      FTotalDownloaded := FTotalDownloaded + FDataProceedSize;
      ResourcePos := ResourcePos + FDataProceedSize;
      InternalSynchronize(SyncDoDataItemProceed);
    until (Terminated);
  finally
    ReadFileAction.Free();
    FreeMem(FDataProceed);
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Dump'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Dump', E); raise; end; end;{$ENDIF}
end;

procedure TclDownLoadThreader.ProcessFTP(AConnect: TclConnectAction);
var
  OpenFileAction: TclFtpOpenFileAction;
begin
  inherited ProcessFTP(AConnect);
  if FIsGetResourceInfo or (FBytesToProceed = 0) then Exit;
  if Terminated then Exit;
  OpenFileAction := nil;
  try
    OpenFileAction := (Connection.GetActionByClass(TclFtpOpenFileAction) as TclFtpOpenFileAction);
    if (OpenFileAction = nil) then
    begin
      OpenFileAction := TclFtpOpenFileAction.Create(Connection, AConnect.Internet, AConnect.hResource,
        URLParser.Urlpath, GENERIC_READ, FTP_TRANSFER_TYPE_BINARY);
      OpenFileAction.FireAction(GetNormTimeOut(TimeOut));
    end;
    if Terminated then Exit;
    Dump(OpenFileAction);
  finally
    FreeObjectIfNeed(OpenFileAction);
  end;
end;

procedure TclDownLoadThreader.PrepareHeader;
var
  i: Integer;
begin
  for i := RequestHeader.Count - 1 downto 0 do
  begin
    if (system.Pos('content-', LowerCase(RequestHeader[i])) > 0) then
    begin
      RequestHeader.Delete(i);
    end;
  end;
end;

procedure TclDownLoadThreader.ProcessHTTP(AConnect: TclConnectAction);
var
  OpenRequestAction: TclHttpOpenRequestAction;
begin
  PrepareHeader();
  inherited ProcessHTTP(AConnect);
  if FIsGetResourceInfo or (FBytesToProceed = 0) then Exit;
  if Terminated then Exit;
  OpenRequestAction := nil;
  try
    OpenRequestAction := (Connection.GetActionByClass(TclHttpOpenRequestAction) as TclHttpOpenRequestAction);
    if (OpenRequestAction = nil) then
    begin
      OpenRequestAction := TclHttpOpenRequestAction.Create(Connection, AConnect.Internet, AConnect.hResource,
        'GET', URLParser.Urlpath + URLParser.Extra, '', '', nil, GetOpenRequestFlags(False));
      OpenRequestAction.FireAction(GetNormTimeOut(TimeOut));
    end;
    if Terminated then Exit;

    SetHttpHeader(OpenRequestAction);
    SetResourcePos(OpenRequestAction);
    SendRequest(OpenRequestAction);
    if Terminated then Exit;

    if DoNotGetResourceInfo then
    begin
      QueryHeadInfo(OpenRequestAction);
      QueryGetInfo(OpenRequestAction);
      InternalSynchronize(SyncDoGetResourceInfo);
    end;

    Dump(OpenRequestAction);
  finally