cldc.pas

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

begin
  i := 0;
  while (i < 4) do
  begin
    Inc(i);
    request := TclHttpSendRequestAction.Create(Connection, AOpenRequest.Internet,
      AOpenRequest.hResource, '', nil, 0);
    try
      PerformRequestOperation(AOpenRequest, SetCertOptionsOperation, request);
    finally
      request.Free();
    end;
    try
      GetHttpStatusCode(AOpenRequest);
      Break;
    except
      if (ResourceInfo.StatusCode = 401) then
      begin
        if UseInternetErrorDialog then
        begin
          SetCertOptions(AOpenRequest, 0);
        end else
        if (i < 4) then
        begin
          ServerAuthentication(AOpenRequest);
        end else
        begin
          raise;
        end;
      end else
      if (ResourceInfo.StatusCode = 407) then
      begin
        if UseInternetErrorDialog then
        begin
          SetCertOptions(AOpenRequest, 0);
        end else
        if (HttpProxySettings.AuthenticationType = atAutoDetect) then
        begin
          ProxyAuthentication(AOpenRequest);
        end else
        begin
          raise;
        end;
      end else
      begin
        raise;
      end;
    end;
    if Terminated then Exit;
  end;
end;

procedure TclCustomThreader.GetFTPResourceInfo(AConnect: TclConnectAction);
var
  OpenFileAction: TclFtpOpenFileAction;
  GetSizeAction: TclFtpGetFileSizeAction;
  FindFirstFileAction: TclFtpFindFirstFileAction;
  resDate: TDateTime;
begin
  if (FResourceInfo <> nil) then Exit;

  OpenFileAction := nil;
  GetSizeAction := 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;

    GetSizeAction := TclFtpGetFileSizeAction.Create(Connection, OpenFileAction.Internet,
      OpenFileAction.hResource);

    GetSizeAction.FireAction(GetNormTimeOut(TimeOut));
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetSize(GetSizeAction.FileSize);
  finally
    GetSizeAction.Free();
    FreeObjectIfNeed(OpenFileAction);
  end;

  if Terminated then Exit;

  try
    FindFirstFileAction := TclFtpFindFirstFileAction.Create(Connection, AConnect.Internet,
      AConnect.hResource, FURLParser.Urlpath, INTERNET_FLAG_RELOAD);
    try
      FindFirstFileAction.FireAction(GetNormTimeOut(TimeOut));
      AssignIfNeedResourceInfo();
      resDate := ConvertFileTimeToDateTime(FindFirstFileAction.lpFindFileData.ftLastWriteTime);
      if (resDate > 0) then
      begin
        TclResourceInfoAccess(ResourceInfo).SetDate(resDate);
      end;
    finally
      FindFirstFileAction.Free();
    end;
  except
    on EclInternetError do;
  end;
end;

procedure TclCustomThreader.GetAllHeaders(ARequest: TclHttpOpenRequestAction);
var
  buf: PChar;
  buflen, tmp: DWORD;
begin
  ResponseHeader.Clear();
  buflen := 0;
  tmp := 0;
  HttpQueryInfo(ARequest.hResource, HTTP_QUERY_RAW_HEADERS_CRLF, nil, buflen, tmp);
  if (buflen > 0) then
  begin
    GetMem(buf, buflen);
    try
      if HttpQueryInfo(ARequest.hResource, HTTP_QUERY_RAW_HEADERS_CRLF, buf, buflen, tmp) then
      begin
        ResponseHeader.Text := string(buf);
      end;
    finally
      FreeMem(buf);
    end;
  end;
end;

procedure TclCustomThreader.GetHttpStatusCode(ARequest: TclHttpOpenRequestAction);
var
  statuscode: Integer;
  buflen, tmp: DWORD;
begin
  GetAllHeaders(ARequest);

  buflen := SizeOf(statuscode);
  tmp := 0;
  if HttpQueryInfo(ARequest.hResource, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER,
    @statuscode, buflen, tmp) then
  begin
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetStatusCode(statuscode);
    if (ResourceInfo.StatusCode >= HTTP_STATUS_BAD_REQUEST) then
    begin
      raise EclInternetError.Create(Format(cResourceAccessError, [ResourceInfo.StatusCode]),
        ResourceInfo.StatusCode);
    end;
  end else
  begin
    AssignError('', HTTP_QUERY_STATUS_CODE_Msg, 0);
  end;
end;

procedure TclCustomThreader.QueryHeadInfo(AOpenRequestAction: TclHttpOpenRequestAction);
const
  cTypeLength = 1024;
var
  filedate: TFileTime;
  resdate: TSystemTime;
  resDateTime: TDateTime;
  reslen: Integer;
  restype: array[0..cTypeLength - 1] of Char;
  buflen, tmp: DWORD;
begin
  buflen := SizeOf(reslen);
  tmp := 0;
  if HttpQueryInfo(AOpenRequestAction.hResource, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
    @reslen, buflen, tmp) then
  begin
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetSize(reslen);
  end else
  begin
//    AssignError('', HTTP_QUERY_CONTENT_LENGTH_Msg, 0);
  end;
  if Terminated then Exit;
  buflen := SizeOf(resdate);
  tmp := 0;
  if HttpQueryInfo(AOpenRequestAction.hResource, HTTP_QUERY_LAST_MODIFIED or HTTP_QUERY_FLAG_SYSTEMTIME,
    @resdate, buflen, tmp) then
  begin
    AssignIfNeedResourceInfo();
    if SystemTimeToFileTime(resdate, filedate) then
    begin
      resDateTime := ConvertFileTimeToDateTime(filedate);
      if (resDateTime > 0) then
      begin
        TclResourceInfoAccess(ResourceInfo).SetDate(resDateTime);
      end;
    end;
  end else
  begin
//    AssignError('', HTTP_QUERY_LAST_MODIFIED_Msg, 0);
    if (ResourceInfo <> nil) then
    begin
      TclResourceInfoAccess(ResourceInfo).SetSize(0);
    end;
  end;
  if Terminated then Exit;
  buflen := cTypeLength;
  tmp := 0;
  if HttpQueryInfo(AOpenRequestAction.hResource, HTTP_QUERY_CONTENT_TYPE, restype + 0, buflen, tmp) then
  begin
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetContentType(restype);
  end else
  begin
//    AssignError('', HTTP_QUERY_CONTENT_TYPE_Msg, 0);
    if (ResourceInfo <> nil) then
    begin
      TclResourceInfoAccess(ResourceInfo).SetSize(0);
    end;
  end;
end;

procedure TclCustomThreader.QueryGetInfo(AOpenRequestAction: TclHttpOpenRequestAction);
const
  cTypeLength = 1024;
var
  disposition, encoding: array[0..cTypeLength - 1] of Char;
  buflen, tmp: DWORD;
  contlen: Integer;
begin
  buflen := cTypeLength;
  tmp := 0;
  if HttpQueryInfo(AOpenRequestAction.hResource, HTTP_QUERY_CONTENT_DISPOSITION, disposition + 0, buflen, tmp) then
  begin
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetContentDisposition(disposition);
  end;
  if Terminated then Exit;
  buflen := cTypeLength;
  tmp := 0;
  if HttpQueryInfo(AOpenRequestAction.hResource, HTTP_QUERY_CONTENT_ENCODING, encoding + 0, buflen, tmp) then
  begin
    AssignIfNeedResourceInfo();
    TclResourceInfoAccess(ResourceInfo).SetCompressed(system.Pos('gzip', LowerCase(encoding)) > 0);
  end;
  contlen := Integer(InternetSetFilePointer(AOpenRequestAction.hResource, 0, nil, FILE_END, 0));
  if contlen > 0 then
  begin
    AssignIfNeedResourceInfo();
    if (ResourceInfo.Size = 0) then
    begin
      TclResourceInfoAccess(ResourceInfo).SetSize(contlen);
    end else
    begin
      TclResourceInfoAccess(ResourceInfo).SetAllowsRandomAccess(True);
    end;
  end;
end;

procedure TclCustomThreader.GetHTTPResourceInfo(AConnect: TclConnectAction);
var
  OpenRequestAction: TclHttpOpenRequestAction;
  NeedAllInfo: Boolean;
begin
  NeedAllInfo := (FResourceInfo = nil);
  OpenRequestAction := nil;
  try
    OpenRequestAction := TclHttpOpenRequestAction.Create(Connection, AConnect.Internet, AConnect.hResource,
      'HEAD', URLParser.Urlpath + URLParser.Extra, '', '', nil, GetOpenRequestFlags(False));
    OpenRequestAction.FireAction(GetNormTimeOut(TimeOut));

    SetHttpHeader(OpenRequestAction);
    SendRequest(OpenRequestAction);

    if needAllInfo then
    begin
      QueryHeadInfo(OpenRequestAction);

      if Terminated then Exit;

      OpenRequestAction.Free();
      OpenRequestAction := nil;
      OpenRequestAction := TclHttpOpenRequestAction.Create(Connection, AConnect.Internet, AConnect.hResource,
        'GET', URLParser.Urlpath + URLParser.Extra, '', '', nil, GetOpenRequestFlags(True));
      OpenRequestAction.FireAction(GetNormTimeOut(TimeOut));

      SetHttpHeader(OpenRequestAction);
      SendRequest(OpenRequestAction);

      if Terminated then Exit;

      QueryGetInfo(OpenRequestAction);
    end;
  finally
    OpenRequestAction.Free();
  end;
end;

procedure TclCustomThreader.SyncDoError;
begin
  if Assigned(FOnError) then
  begin
    FOnError(Self, FLastError, FLastErrorCode);
  end;
end;

procedure TclCustomThreader.InternalSynchronize(Method: TThreadMethod);
begin
  FSynchronizer.Synchronize(Method);
end;

procedure TclCustomThreader.SyncDoGetResourceInfo;
begin
  if Assigned(FOnGetResourceInfo) then
  begin
    FOnGetResourceInfo(Self, ResourceInfo);
  end;
end;

procedure TclCustomThreader.Perform;
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;
{$ENDIF}
{$ENDIF}
  Resume();
end;

procedure TclCustomThreader.ClearInfo;
begin
  FSelfResourceInfo.Free();
  FSelfResourceInfo := nil;
end;

function TclCustomThreader.GetNormTimeOut(ATimeOut: Integer): Integer;
begin
  Result := ATimeOut;
end;

procedure TclCustomThreader.SetStatus(AStatus: TclProcessStatus);
begin
  if (FStatus <> AStatus) then
  begin
    FStatus := AStatus;
    InternalSynchronize(SyncDoStatusChanged);
  end;
end;

procedure TclCustomThreader.WaitForReconnect(ATimeOut: Integer);
begin
  WaitForSingleObject(FSleepEvent, DWORD(ATimeOut));
end;

procedure TclCustomThreader.Execute;
var
  Counter: Integer;
begin
  ResponseHeader.Clear();
  Counter := FTryCount;
  FTempErrorCode := 0;
  try
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Execute');{$ENDIF}
    SetStatus(psProcess);
    PrepareURL();
    repeat
      try
        ProcessURL();
        Break;
      except
        on E: EclInternetError do
          begin
            FTempErrorCode := E.ErrorCode;
            Dec(Counter);
            if (Counter < 1) then raise;
            WaitForReconnect(GetNormTimeOut(ReconnectAfter));
          end;
      end;
    until False;
    if Terminated then
    begin
      SetStatus(psTerminated);
    end else
    if (FLastError <> '') then
    begin
      SetStatus(psErrors);
    end else
    begin
      SetStatus(psSuccess);
    end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Execute'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Execute', E); raise; end; end;{$ENDIF}
  except
    on E: EclInternetError do
    begin
      AssignError(E.Message, '', E.ErrorCode);
      SetStatus(psFailed);
    end;
    on E: Exception do
    begin
      AssignError(E.Message, '', 0);
      SetStatus(psFailed);
    end;
  end;
end;

procedure TclCustomThreader.DoOnURLParsing(Sender: TObject; var UrlComponents: TURLComponents);
begin
  FUrlComponents := UrlComponents;
  InternalSynchronize(SyncDoURLParsing);
  UrlComponents := FUrlComponents;
end;

procedure TclCustomThreader.SyncDoURLParsing;
begin
  if Assigned(FOnUrlParsing) then
  begin
    FOnUrlParsing(Self, FUrlComponents);
  end;
end;

procedure TclCustomThreader.Wait;
var
  Msg: TMsg;
  H: THandle;
begin
  DuplicateHandle(GetCurrentProcess(), Handle, GetCurrentProcess(), @H, 0, False, DUPLICATE_SAME_ACCESS);
  try
    if GetCurrentThreadID = FSynchronizer.SyncBaseThreadID then
    begin
      while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
      begin
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          DispatchMessage(Msg);
        end;
      end;
    end else
    begin
      WaitForSingleObject(H, INFINITE);
    end;
  finally
    CloseHandle(H);
  end;
end;

function TclCustomThreader.GetProxyString: string;
  function GetProxyItem(const AProtocol, AServer: string; APort: Integer): string;
  begin
    if (AServer <> '') then
    begin
      Result := AServer;
      if (system.Pos('http', LowerCase(Result)) <> 1)
        and (system.Pos('ftp', LowerCase(Result)) <> 1) then
      begin
        Result := AProtocol + '://' + Result;
      end;
      Result := Format('%s=%s:%d', [AProtocol, Result, APort]);
    end else
    begin
      Result := '';
    end;
  end;

begin
  Result := '';
  case URLParser.UrlType of
    utHTTP: Result := GetProxyItem('http', HttpProxySettings.Server, HttpProxySettings.Port);
    utHTTPS: Result := GetProxyItem('https', HttpProxySettings.Server, HttpProxySettings.Port);
    utFTP: Result := GetProxyItem('ftp', FtpProxySettings.Server, FtpProxySettings.Port);
  end;
end;