clftp.pas

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

  end;
  s := system.Copy(s, ind + 1, 1000);
  ind := TextPos(')', s);
  if (ind > 0) then
  begin
    system.Delete(s, ind, 1000);
  end;

  ParseFtpHostStr(s, AHost, ADataPort);
end;

procedure TclCustomFtp.SetTransferType(const Value: TclFtpTransferType);
begin
  if (FTransferType <> Value) then
  begin
    FTransferType := Value;
    Changed();
  end;
end;

procedure TclCustomFtp.GetFile(const AFileName: string;
  ADestination: TStream; APosition, ASize: Int64);
begin
  BeginAccess();
  try
    if (ADestination.Size < (APosition + ASize)) then
    begin
      ADestination.Size := (APosition + ASize);
    end;
    FResourcePos := APosition;
  finally
    EndAccess();
  end;
  InternalGetData(Format('RETR %s', [AFileName]), ADestination, ASize, GetFileSizeIfNeed(AFileName));
end;

procedure TclCustomFtp.Abort;
begin
  //check for FXP mode
  if Active and (FDataConnection <> nil) then
  begin
    SendCommand('ABOR');
    FDataConnection.Abort();
  end;
end;

procedure TclCustomFtp.PutFile(const AFileName: string; ASource: TStream;
  APosition, ASize: Int64);
const
  cmd: array[Boolean] of string = ('STOR ', 'APPE ');
begin
  FResourcePos := APosition;
  InternalPutData(cmd[(APosition > 0)] + AFileName, ASource, ASize);
end;

function TclCustomFtp.FileExists(const AFileName: string): Boolean;
  function GetFtpFileName(const AFullName: string): string;
  var
    ind: Integer;
  begin
    ind := LastDelimiter('/', AFullName);
    Result := system.Copy(AFullName, ind + 1, MaxInt);
  end;
  
var
  list: TStrings;
begin
  try
    list := TStringList.Create();
    try
      GetList(list, AFileName, False);
      Result := SameText(Trim(list.Text), Trim(GetFtpFileName(AFileName)));
    finally
      list.Free();
    end;
  except
    on EclSocketError do
    begin
      Result := False;
    end;
  end;
end;

procedure TclCustomFtp.SetProxySettings(const Value: TclFtpProxySettings);
begin
  FProxySettings.Assign(Value);
end;

function TclCustomFtp.GetFtpHost: string;
begin
  if (Port = cDefaultFtpPort) then
  begin
    Result := Server;
  end else
  begin
    Result := Server + ':' + IntToStr(Port);
  end;
end;

function TclCustomFtp.GetLoginPassword: string;
begin
  // ? OTP ?
  Result := Password;
end;

procedure TclCustomFtp.DoCustomFtpProxy;
begin
  if Assigned(OnCustomFtpProxy) then
  begin
    OnCustomFtpProxy(Self);
  end else
  begin
    raise EclSocketError.Create(cOnCustomFtpProxyRequired, -1);
  end;
end;

procedure TclCustomFtp.Noop;
begin
  SendCommandSync('NOOP', [200]);
end;

procedure TclCustomFtp.DoDirectoryListing(AFileInfo: TclFtpFileInfo; const Source: string);
begin
  if Assigned(OnDirectoryListing) then
  begin
    OnDirectoryListing(Self, AFileInfo, Source);
  end;
end;

procedure TclCustomFtp.DirectoryListing(const AParam: string);
var
  list: TStrings;
begin
  list := TStringList.Create();
  try
    GetList(list, AParam, True);
    ParseDirectoryListing(list);
  finally
    list.Free();
  end;
end;

procedure TclCustomFtp.BeginAccess;
begin
  if (DataAccessor <> nil) then
  begin
    DataAccessor.Enter();
  end;
end;

procedure TclCustomFtp.EndAccess;
begin
  if (DataAccessor <> nil) then
  begin
    DataAccessor.Leave();
  end;
end;

procedure TclCustomFtp.FxpAppendFile(const ASourceFile, ADestinationFile: string;
  ASourceSite: TclCustomFtp);
begin
  InternalFxpOperation('APPE', ASourceFile, ADestinationFile, ASourceSite, Self);
end;

procedure TclCustomFtp.InternalFxpOperation(const APutMethod, ASourceFile, ADestinationFile: string;
  ASourceSite, ADestinationSite: TclCustomFtp);
var
  cmd, dataIP: string;
  dataPort: Integer;
begin
  Assert(ASourceSite <> ADestinationSite);
  
  ASourceSite.SetTransferParams();
  ADestinationSite.SetTransferParams();

  if PassiveMode then
  begin
    ASourceSite.SetDataPassiveMode(dataIP, dataPort);
    ADestinationSite.SetDataPortMode(dataIP, dataPort);
  end else
  begin
    ADestinationSite.SetDataPassiveMode(dataIP, dataPort);
    ASourceSite.SetDataPortMode(dataIP, dataPort);
  end;

  ASourceSite.ClearResponse();
  ASourceSite.SendCommand('RETR ' + ASourceFile);
  ASourceSite.WaitingMultipleResponses([125, 150, 154]);

  cmd := ADestinationFile;
  if (cmd <> '') then
  begin
    cmd := #32 + cmd;
  end;
  cmd := APutMethod + cmd;
  ADestinationSite.ClearResponse();
  ADestinationSite.SendCommand(cmd);
  ADestinationSite.WaitingMultipleResponses([110, 125, 150]);

  ASourceSite.WaitingMultipleResponses([225, 226, 250, 426, 450]);

  if (ASourceSite.LastResponseCode = 426) or (ASourceSite.LastResponseCode = 450) then
  begin
    ASourceSite.WaitingMultipleResponses([225, 226]);
  end;

  ADestinationSite.WaitingMultipleResponses([225, 226, 250, 426, 450]);

  if (ADestinationSite.LastResponseCode = 426) or (ADestinationSite.LastResponseCode = 450) then
  begin
    ADestinationSite.WaitingMultipleResponses([225, 226]);
  end;
end;

procedure TclCustomFtp.FxpGetFile(const ASourceFile, ADestinationFile: string;
  ADestinationSite: TclCustomFtp);
begin
  InternalFxpOperation('STOR', ASourceFile, ADestinationFile, Self, ADestinationSite);
end;

procedure TclCustomFtp.FxpPutFile(const ASourceFile, ADestinationFile: string;
  ASourceSite: TclCustomFtp);
begin
  InternalFxpOperation('STOR', ASourceFile, ADestinationFile, ASourceSite, Self);
end;

procedure TclCustomFtp.FxpPutUniqueFile(const ASourceFile: string; ASourceSite: TclCustomFtp);
begin
  InternalFxpOperation('STOU', ASourceFile, '', ASourceSite, Self);
end;

function TclCustomFtp.GetFileSizeIfNeed(const AFileName: string): Int64;
begin
  Result := 0;
  if Assigned(OnProgress) or Assigned(OnProgress64) then
  begin
    try
      Result := GetFileSize(AFileName);
    except
      on EclSocketError do ;
    end;
  end;
end;

procedure TclCustomFtp.SetUseTLS(const Value: TclClientTlsMode);
var
  oldUseTls: TclClientTlsMode;
begin
  if (UseTLS <> Value) then
  begin
    if not (csLoading in ComponentState) then
    begin
      if (Value <> ctNone) then
      begin
        PassiveMode := True;
      end;
      if (Value = ctNone) then
      begin
        DataProtection := False;
      end;
    end;

    oldUseTls := UseTLS;
    inherited SetUseTLS(Value);

    if not (csLoading in ComponentState) then
    begin
      if (oldUseTls = ctNone) and (Value <> ctNone) then
      begin
        DataProtection := True;
      end;
    end;
  end;
end;

function TclCustomFtp.GetDefaultPort: Integer;
begin
  Result := cDefaultFtpPort;
end;

procedure TclCustomFtp.SetDataProtection(const Value: Boolean);
begin
  if (UseTLS <> ctNone) and (FDataProtection <> Value) then
  begin
    FDataProtection := Value;
    Changed();
  end;
end;

procedure TclCustomFtp.SetFilePermissions(const AFileName: string; AOwner,
  AGroup, AOther: TclFtpFilePermissions);
var
  perm: string;
begin
  perm := Format('%d%d%d',
    [GetFtpFilePermissionsInt(AOwner), GetFtpFilePermissionsInt(AGroup), GetFtpFilePermissionsInt(AOther)]);
  SendCommandSync('SITE CHMOD %s %s', [200], [perm, AFileName]);
end;

procedure TclCustomFtp.InternalSendCommandSync(const ACommand: string;
  const AOkResponses: array of Integer);
var
  i: Integer;
  okResps: array of Integer;
begin
  SetLength(okResps, SizeOf(AOkResponses) + 1);
  okResps[0] := 225;

  for i := Low(AOkResponses) to High(AOkResponses) do
  begin
    okResps[i + 1] := AOkResponses[i];
  end;

  ClearResponse();
  SendCommand(ACommand);

  WaitingMultipleResponses(okResps);
  if (LastResponseCode = 225) then
  begin
    WaitingMultipleResponses(AOkResponses);
  end;
end;

procedure TclCustomFtp.ClearResponse;
begin
  Response.Clear();
  FResponsePos := 0;
end;

procedure TclCustomFtp.WaitingMultipleResponses(
  const AOkResponses: array of Integer);
var
  ind: Integer;
begin
  if (Response.Count > FResponsePos) then
  begin
    ind := ParseResponse(FResponsePos, AOkResponses);

    if (ind > -1) then
    begin
      FResponsePos := ind + 1;
    end else
    begin
      if not ((Length(AOkResponses) = 1) and (AOkResponses[Low(AOkResponses)] = SOCKET_DOT_RESPONSE))
        and (LastResponseCode <> SOCKET_WAIT_RESPONSE) then
      begin
        RaiseSocketError(Trim(Response.Text), LastResponseCode);
      end;
      
      FResponsePos := InternalWaitingResponse(FResponsePos, AOkResponses) + 1;
      DoReceiveResponse(Response);
    end;
  end else
  begin
    FResponsePos := InternalWaitingResponse(FResponsePos, AOkResponses) + 1;
    DoReceiveResponse(Response);
  end;
end;

end.