clconnection.pas

来自「Clever_Internet_Suite_6.2的代码 Clever_Int」· PAS 代码 · 共 990 行 · 第 1/2 页

  begin
    FActionList.Add(Action);
    DoActionAdded(Action);
  end;
end;

procedure TclInternetConnection.RemoveAction(Action: TclInternetAction);
begin
  if (FActionList <> nil) then
  begin
    FActionList.Remove(Action);
    DoActionRemoved(Action);
  end;
end;

procedure TclInternetConnection.DoActionAdded(Action: TclInternetAction);
begin
  if Assigned(OnActionAdded) then
  begin
    FEventAction := Action;
    InternalSynchronize(SyncActionAdded);
  end;
end;

procedure TclInternetConnection.SyncActionAdded;
begin
  OnActionAdded(Self, FEventAction);
end;

procedure TclInternetConnection.DoActionRemoved(Action: TclInternetAction);
begin
  if Assigned(OnActionRemoved) then
  begin
    FEventAction := Action;
    InternalSynchronize(SyncActionRemoved);
  end;
end;

procedure TclInternetConnection.SyncActionRemoved;
begin
  OnActionRemoved(Self, FEventAction);
end;

procedure TclInternetConnection.DoAfterFireAction(Action: TclInternetAction);
begin
  if Assigned(OnAfterFireAction) then
  begin
    FEventAction := Action;
    InternalSynchronize(SyncAfterFireAction);
  end;
end;

procedure TclInternetConnection.SyncAfterFireAction;
begin
  OnAfterFireAction(Self, FEventAction);
end;

procedure TclInternetConnection.DoBeforeFireAction(Action: TclInternetAction);
begin
  if Assigned(OnBeforeFireAction) then
  begin
    FEventAction := Action;
    InternalSynchronize(SyncBeforeFireAction);
  end;
end;

procedure TclInternetConnection.SyncBeforeFireAction;
begin
  OnBeforeFireAction(Self, FEventAction);
end;

procedure TclInternetConnection.DoStatusCallback(
  Action: TclInternetAction; AInternetStatus: Integer;
  AStatusInformation: PChar; AStatusInformationLength: Integer);
begin
  if Assigned(OnStatusCallback) then
  begin
    FEventAction := Action;
    FEventInternetStatus := AInternetStatus;
    FEventStatusInfo := AStatusInformation;
    FEventStatusInfoLength := AStatusInformationLength;
    InternalSynchronize(SyncStatusCallback);
  end;
end;

procedure TclInternetConnection.SyncStatusCallback;
begin
  OnStatusCallback(Self, FEventAction, FEventInternetStatus,
    FEventStatusInfo, FEventStatusInfoLength);
end;

function TclInternetConnection.GetActionByHandle(hInet: HINTERNET): TclInternetAction;
var
  i: Integer;
begin
  if not (csDestroying in ComponentState) then
  begin
    for i := 0 to FActionList.Count - 1 do
    begin
      Result := GetAction(i);
      if (Result is TclInternetResourceAction)
        and ((Result as TclInternetResourceAction).hResource = hInet) then Exit;
    end;
  end;
  Result := nil;
end;

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

{ TclInternetAction }

constructor TclInternetAction.Create(AOwner: TclInternetConnection; AInternet: HINTERNET);
begin
  inherited Create();
  FAccessor := TCriticalSection.Create();
  FInternet := AInternet;
  FOwner := AOwner;
  if (FOwner <> nil) then
  begin
    FOwner.AddAction(Self);
  end;
end;

destructor TclInternetAction.Destroy;
begin
  if (FOwner <> nil) then
  begin
    FOwner.RemoveAction(Self);
  end;
  FAccessor.Free();
  inherited Destroy();
end;

procedure TclInternetAction.Execute;
begin
  FErrorCode := GetLastError();
  FErrorText := GetLastErrorText(FErrorCode);
end;

function TclInternetAction.FireAction(ATimeOut: Integer; AIsSilent: Boolean): Boolean;
begin
  FErrorCode := 0;
  FErrorText := '';
  Assert(FOwner <> nil);
  FOwner.FireInternetAction(Self, ATimeOut);
  Result := (FErrorText = '');
  if (not Result) and (not AIsSilent) then
  begin
    raise EclInternetError.Create(FErrorText, FErrorCode);
  end;
end;

procedure TclInternetAction.NotifyTerminate(AInternet: HINTERNET);
begin
end;

procedure TclInternetAction.Terminate;
begin
  FAccessor.Enter();
  try
    if (FInternet <> nil) then
    begin
      if (FOwner <> nil) then
      begin
        FOwner.FireNotifyTerminate(FInternet);
      end;
      InternetCloseHandle(FInternet);
      FInternet := nil;
    end;
  finally
    FAccessor.Leave();
  end;
end;

{ TclConnectAction }

constructor TclConnectAction.Create(AOwner: TclInternetConnection; hInet: HINTERNET;
  lpszServerName: string; nServerPort: INTERNET_PORT;
  lpszUsername, lpszPassword: string; dwService, dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FlpszServerName := lpszServerName;
  FnServerPort := nServerPort;
  FlpszUsername := lpszUsername;
  FlpszPassword := lpszPassword;
  FdwService := dwService;
  FdwFlags := dwFlags;
end;

procedure TclConnectAction.Execute;
var
  Username, Password: PChar;
begin
  FhResource := nil;
  Username := nil;
  Password := nil;
  if (FlpszUsername <> '') then
  begin
    Username := PChar(FlpszUsername);
  end;
  if (FlpszPassword <> '') then
  begin
    Password := PChar(FlpszPassword);
  end;
  FhResource := InternetConnect(Internet, PChar(FlpszServerName), FnServerPort, Username,
    Password, FdwService, FdwFlags, DWORD(FOwner));
  inherited Execute();
end;

{ TclFtpFindFirstFileAction }

constructor TclFtpFindFirstFileAction.Create(AOwner: TclInternetConnection; hInet, hConnect: HINTERNET;
  lpszSearchFile: string; dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FhConnect := hConnect;
  FlpszSearchFile := lpszSearchFile;
  FdwFlags := dwFlags;
end;

procedure TclFtpFindFirstFileAction.Execute;
begin
  FhResource := nil;
  FhResource := FtpFindFirstFile(FhConnect, PChar(FlpszSearchFile), FlpFindFileData, FdwFlags, DWORD(FOwner));
  inherited Execute();
end;

{ TclInternetResourceAction }

procedure TclInternetResourceAction.CloseResource;
begin
  if (FhResource <> nil) then
  begin
    InternetCloseHandle(FhResource);
    FhResource := nil;
  end;
end;

destructor TclInternetResourceAction.Destroy;
begin
  CloseResource();
  inherited Destroy;
end;

procedure TclInternetResourceAction.Execute;
begin
  if FhResource = nil then
  begin
    inherited Execute();
  end;
end;

procedure TclInternetResourceAction.NotifyTerminate(AInternet: HINTERNET);
begin
  if (FhResource = AInternet) then
  begin
    FhResource := nil;
  end;
end;

{ TclInternetOpenAction }

constructor TclInternetOpenAction.Create(AOwner: TclInternetConnection; lpszAgent: string;
  dwAccessType: DWORD; lpszProxy, lpszProxyBypass: string; dwFlags: DWORD);
begin
  inherited Create(AOwner, nil);
  FlpszAgent := lpszAgent;
  FdwAccessType := dwAccessType;
  FlpszProxy := Trim(lpszProxy);
  FlpszProxyBypass := Trim(lpszProxyBypass);
  FdwFlags := dwFlags;
end;

procedure TclInternetOpenAction.Execute;
var
  Proxy, ProxyBypass: PChar;
begin
  FhResource := nil;
  Proxy := nil;
  ProxyBypass := nil;
  if (FlpszProxy <> '') then
  begin
    Proxy := PChar(FlpszProxy);
  end;
  if (FlpszProxyBypass <> '') then
  begin
    ProxyBypass := PChar(FlpszProxyBypass);
  end;
  FhResource := InternetOpen(PChar(FlpszAgent), FdwAccessType, Proxy, ProxyBypass, FdwFlags);
  inherited Execute();
end;

{ TclFtpOpenFileAction }

constructor TclFtpOpenFileAction.Create(AOwner: TclInternetConnection;
  hInet, hConnect: HINTERNET; lpszFileName: string; dwAccess, dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FhConnect := hConnect;
  FlpszFileName := lpszFileName;
  FdwAccess := dwAccess;
  FdwFlags := dwFlags;
end;

procedure TclFtpOpenFileAction.Execute;
begin
  FhResource := nil;
  FhResource := FtpOpenFile(FhConnect, PChar(FlpszFileName), FdwAccess, FdwFlags, DWORD(FOwner));
  inherited Execute();
end;

{ TclHttpOpenRequestAction }

constructor TclHttpOpenRequestAction.Create(AOwner: TclInternetConnection;
  hInet, hConnect: HINTERNET; lpszVerb, lpszObjectName, lpszVersion, lpszReferrer: string;
  lplpszAcceptTypes: PLPSTR; dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FhConnect := hConnect;
  FlpszVerb := lpszVerb;
  FlpszObjectName := lpszObjectName;
  FlpszVersion := lpszVersion;
  FlpszReferrer := lpszReferrer;
  FlplpszAcceptTypes := lplpszAcceptTypes;
  FdwFlags := dwFlags;
end;

procedure TclHttpOpenRequestAction.Execute;
var
  Verb, Version, Referrer: PChar;
begin
  FhResource := nil;
  Verb := nil;
  Version := nil;
  Referrer := nil;
  if (FlpszVerb <> '') then
  begin
    Verb := PChar(FlpszVerb);
  end;
  if (FlpszVersion <> '') then
  begin
    Version := PChar(FlpszVersion);
  end;
  if (FlpszReferrer <> '') then
  begin
    Referrer := PChar(FlpszReferrer);
  end;
  FhResource := HttpOpenRequest(FhConnect, Verb, PChar(FlpszObjectName), Version,
    Referrer, FlplpszAcceptTypes, FdwFlags, DWORD(FOwner));
  inherited Execute();
end;

{ TclHttpSendRequestExAction }

constructor TclHttpSendRequestExAction.Create(AOwner: TclInternetConnection;
  hInet, hRequest: HINTERNET;
  lpBuffersIn, lpBuffersOut: PInternetBuffers; dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FhRequest := hRequest;
  FlpBuffersIn := lpBuffersIn;
  FlpBuffersOut := lpBuffersOut;
  FdwFlags := dwFlags;
end;

procedure TclHttpSendRequestExAction.Execute;
begin
  if not HttpSendRequestEx(FhRequest, FlpBuffersIn, FlpBuffersOut, FdwFlags, DWORD(FOwner)) then
  begin
    inherited Execute();
  end;
end;

{ TclHttpEndRequestAction }

constructor TclHttpEndRequestAction.Create(AOwner: TclInternetConnection;
  hInet, hRequest: HINTERNET; lpBuffersOut: PInternetBuffers; dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FhRequest := hRequest;
  FlpBuffersOut := lpBuffersOut;
  FdwFlags := dwFlags;
end;

procedure TclHttpEndRequestAction.Execute;
begin
  if not HttpEndRequest(FhRequest, FlpBuffersOut, FdwFlags, DWORD(FOwner)) then
  begin
    inherited Execute();
  end;
end;

{ TclHttpSendRequestAction }

constructor TclHttpSendRequestAction.Create(AOwner: TclInternetConnection;
  hInet, hRequest: HINTERNET; lpszHeaders: string;
  lpOptional: Pointer; dwOptionalLength: DWORD);
begin
  inherited Create(AOwner, hInet);
  FhRequest := hRequest;
  FlpszHeaders := lpszHeaders;
  FlpOptional := lpOptional;
  FdwOptionalLength := dwOptionalLength;
end;

procedure TclHttpSendRequestAction.Execute;
var
  Headers: PChar;
begin
  Headers := nil;
  if (FlpszHeaders <> '') then
  begin
    Headers := PChar(FlpszHeaders);
  end;
  if not HttpSendRequest(FhRequest, Headers, Length(FlpszHeaders), FlpOptional, FdwOptionalLength) then
  begin
    inherited Execute();
  end;
end;

{ TclInternetReadFileAction }

constructor TclInternetReadFileAction.Create(AOwner: TclInternetConnection;
  hInet, hFile: HINTERNET; lpBuffer: Pointer);
begin
  inherited Create(AOwner, hInet);
  FhFile := hFile;
  FlpBuffer := lpBuffer;
end;

procedure TclInternetReadFileAction.Execute;
begin
  if not InternetReadFile(FhFile, FlpBuffer, FdwNumberOfBytesToRead, FlpdwNumberOfBytesRead) then
  begin
    inherited Execute();
  end;
end;

{ TclInternetWriteFileAction }

constructor TclInternetWriteFileAction.Create(AOwner: TclInternetConnection;
  hInet, hFile: HINTERNET);
begin
  inherited Create(AOwner, hInet);
  FhFile := hFile;
end;

procedure TclInternetWriteFileAction.Execute;
begin
  if (not InternetWriteFile(FhFile, FlpBuffer, FdwNumberOfBytesToWrite, FlpdwNumberOfBytesWritten))
    or (FdwNumberOfBytesToWrite <> FlpdwNumberOfBytesWritten) then
  begin
    inherited Execute();
  end;
end;

{ TclFtpCreateDirectoryAction }

constructor TclFtpCreateDirectoryAction.Create(AOwner: TclInternetConnection;
  hInet, hConnect: HINTERNET; lpszDirectory: string);
begin
  inherited Create(AOwner, hInet);
  FhConnect := hConnect;
  FlpszDirectory := lpszDirectory;
end;

procedure TclFtpCreateDirectoryAction.Execute;
begin
  if not (FtpCreateDirectory(FhConnect, PChar(FlpszDirectory))) then
  begin
    inherited Execute();
  end;
end;

{ TclFtpGetFileSizeAction }

constructor TclFtpGetFileSizeAction.Create(AOwner: TclInternetConnection;
  hInet, hFile: HINTERNET);
begin
  inherited Create(AOwner, hInet);
  FhFile := hFile;
end;

procedure TclFtpGetFileSizeAction.Execute;
var
  p: DWORD;
begin
  FFileSize := FtpGetFileSize(FhFile, @p);
end;

end.