TidFTP in Thread

[nru]

Verdammte Hacke. Ich dreh mich schon seit Stunden im Kreis.
Ob ihr mir bitte beim CodeReview helfen würdet.

Gegeben ist D7, Indy9
Vorhaben: Download-Threads mit TIdFTP. Die einzelnen Threads werden in einer TObjectList abgelegt (OwnObjects=False). Threads werden über eine class function erstellt und in ObjectList geadded. FreeOnTerminate=True erstellt. Aus den OnWork-Eventfunctions werden PostMessages an GUI geschickt.

Aktuelles Problem: Zugriffsverletzung beim Destroy, nach Fertigstellung des Downloads. Und ich komm einfach nicht drauf, woran es hängt. Ich meine, dass das gefühlsmäßig mit den neu aufgenommenen PostMessages zu tun hat. Denn als die noch nicht dabei waren (gestern) liefs eigentlich rund.

Vielen Dank schonmal fürs Reviewen ;)

So siehts (in Auszügen) aus:

Delphi-Quellcode:

uses windows, messages, sysutils, classes, SyncObjs, Contnrs,
     idComponent, idFTP, IdFTPList, IdFTPCommon, xProcs, ExtCtrls;

const

  WM_START_FTPDOWN = WM_USER + 401;
  WM_FINISH_FTPDOWN = WM_USER + 402;
  WM_FTP_MESSAGE = WM_USER + 403;
  WM_FTP_STATUSMSG = WM_USER + 404;

type
  PTransfer = ^TTransfer;
  TTransfer = record
    Percent: Integer;
    Aktuell,
    Overall,
    Total: Int64;
  end;

  TFTPDown = class(TThread)
  private
    FTransferInfo: TTransfer;
    FInfoTimer: TTimer;
    FLastWorkCount: Int64;
    FGesamt: Int64;
    Fmsg: PChar;
    FMainWndHandle: HWND;
    FLocalPath,
    FToLoad: String;
    FFTPClient: TidFTP;
    procedure OnStartThread();
    procedure OnPreTerminate();
    procedure OnMessage();
  protected
    procedure DownloadFolder(AFTP: TIdFtp; ARemotePath, ALocalPath:string; bOverwrite:Boolean);
    function FindFile( AFTP: TIdFtp ): Boolean;
    function GetFolderSize( ARemotePath: String ): Int64;
    procedure DoTimer( Sender: TObject );

    procedure FTPWork(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer);
    procedure FTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer);
    procedure FTPWorkEnd( Sender: TObject; AWorkMode: TWorkMode);
  public
    class function DoDownLoad( mainwnd: HWND; const dlItem: String ): boolean;
    class procedure ClearDownloads;
    class function HasActiveDownloads: Boolean;

    constructor create( mainthr: HWND;  const _Item: String );
    destructor Destroy(); override;
    procedure Execute; override;
    property DownFilename: string read FToLoad;
    property Size: Int64 read FGesamt;
  end;


implementation

var
  FDownList: TObjectList;


class function TFTPDown.DoDownLoad( mainwnd: HWND; const dlItem: String ): boolean;
begin
  FDownList.Add( Create( mainwnd, dlItem ) );
end;
class function TFTPDown.HasActiveDownloads: Boolean;
begin
  result := (FDownList.Count > 0);
end;
class procedure TFTPDown.ClearDownloads;
var
  i: integer;
begin
  for i := Pred(FDownList.Count) downto 0 do begin
    if Assigned((FDownList.Items[i] as TFTPDown)) then begin
      (FDownList.Items[i] as TFTPDown).Terminate;
    end;
  end;
end;

constructor TFTPDown.create( mainthr: HWND; const _Item: String );
begin
  FMainWndHandle := mainthr;        {Hauptanwendung bekommt Messages}
  FToLoad := _Item;                 {Datei- oder Verzeichnisname des DL}
  FLocalPath := strAddSlash(regReadDefValue( HKEY_CURRENT_USER, 'software\FloSoft\DVBase\TSRSS\btFTPDLDir', dtString, ExtractFilePath(ParamStr(0))) );

  FFTPClient := TidFTP.Create(nil);
  FFTPClient.Username := regReadValue( HKEY_CURRENT_USER, 'software\FloSoft\DVBase\TSRSS\btUser', dtString);
  FFTPClient.Password := regReadValue( HKEY_CURRENT_USER, 'software\FloSoft\DVBase\TSRSS\btPass', dtString);
  FFTPClient.Host     := regReadValue( HKEY_CURRENT_USER, 'software\FloSoft\DVBase\TSRSS\btHost', dtString);
  FFTPClient.Port     := 21;
  FFTPClient.Passive  := True;
  FFTPClient.TransferType := ftBinary;
  FFTPClient.OnWork   := FTPWork;
  FFTPClient.OnWorkBegin := FTPWorkBegin;
  FFTPClient.OnWorkEnd := FTPWorkEnd;


  FInfoTimer := TTimer.Create( nil );
  FInfoTimer.Enabled := False;
  FInfoTimer.Interval := 1000;
  FInfoTimer.OnTimer := DoTimer;

  inherited Create( false );
  FreeOnTerminate := True;
end;

destructor TFTPDown.Destroy();
begin
  FreeAndNil( FInfoTimer );
  FreeAndNil( FFTPClient );
  FDownList.Remove(self);
  inherited Destroy;
end;


procedure TFTPDown.Execute;
var
  cRemotePath: String;
  lSingleFile: Boolean;
begin

  FLastWorkCount := 0;
  FTransferInfo.Percent := 0;
  FTransferInfo.Aktuell := 0;
  FTransferInfo.Overall := 0;
  FTransferInfo.Total   := 0;

  Synchronize( OnStartThread );
  FInfoTimer.Enabled := True;

  try
    FFTPClient.Connect;
  except
    on E:Exception do begin
      FMsg := PChar('Fehler bei der Verbindungsaufnahme ('+e.Message+')');
      Synchronize( OnMessage );
      FFTPClient.Disconnect;
      FFTPClient.Quit;
      exit;
    end;
  end;

  // Prüfen - Datei oder Ordner?
  try
      lSingleFile := False;
      cRemotePath := 'files/'+FToLoad;
      FFTPClient.ChangeDir(cRemotePath);
  except
      // Only Dateidownload
      lSingleFile := True;
      cRemotePath := 'files/';
      FFTPClient.ChangeDir(cRemotePath);
  end;

  // Transfer einleiten
  if not Terminated then begin
    FMsg := 'Download startet';
    Synchronize( OnMessage );

    if lSingleFile then begin
      if FindFile( FFTPClient ) then begin
        FTransferInfo.Total := FGesamt;
        if Fileexists(FLocalPath+FToLoad) then DeleteFile(FLocalPath+FToLoad);
        FFTPClient.Get(FToLoad, FLocalPath+FToLoad);
      end;
    end else begin
      FGesamt := GetFolderSize( cRemotePath );
      FTransferInfo.Total := FGesamt;
      ForceDirectories(FLocalPath+FToLoad);
      DownloadFolder(FFTPClient, cRemotePath, FLocalPath+FToLoad, true);
    end;
  end;

  // = Disconnect and Free FTP-Instance
  FFTPClient.Disconnect;
  FFTPClient.Quit;

  FInfoTimer.Enabled := False;

  if not Terminated then
    Synchronize( OnPreTerminate );

end;

DownloadFolder ist eine rekursiv aufgerufene Function, die evtl. vorhandene SubDirs berücksichtigt.

Delphi-Quellcode:

procedure TFTPDown.FTPWork(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer);
begin
  // Abbruch des Get wird hier ermöglicht.
  // Das geschieht in Indy via Exception. Und das muss passieren, wenn der Thread
  // gekillt werden soll (z.B. Programmende)
  if Terminated then Abort;

  Inc( FTransferInfo.Overall, AWorkCount-FLastWorkCount );
  FLastWorkCount := AWorkCount;
  if FTransferInfo.Total > 0 then
    FTransferInfo.Percent := round((100 / FTransferInfo.Total) * FTransferInfo.Overall);
end;
procedure TFTPDown.FTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer);
begin
end;
procedure TFTPDown.FTPWorkEnd( Sender: TObject; AWorkMode: TWorkMode);
begin
  FLastWorkCount := 0;
end;


procedure TFTPDown.OnStartThread();
begin
  if FMainWndHandle <> 0 then
    PostMessage( FMainWndHandle, WM_START_FTPDOWN, Integer(self), 0 );
end;
procedure TFTPDown.OnPreTerminate();
begin
  if FMainWndHandle <> 0 then
    PostMessage( FMainWndHandle, WM_FINISH_FTPDOWN, Integer(self), 0 );
end;
procedure TFTPDown.OnMessage();
begin
  if FMainWndHandle <> 0 then
    PostMessage( FMainWndHandle, WM_FTP_MESSAGE, Integer(Fmsg), 0 );
end;
procedure TFTPDown.DoTimer( Sender: TObject );
begin
  if FMainWndHandle <> 0 then
    PostMessage( FMainWndHandle, WM_FTP_STATUSMSG, 0, LPARAM(@FTransferInfo) );
end;



initialization
  FDownList := TObjectList.Create( false );    // OwnObjects=False, damit Freigabe gesteuert werden kann
finalization
  FreeAndNil( FDownList );

Start des Threads und Messagehandling in der GUI wie folgt:

Delphi-Quellcode:

procedure TfrmMain.dxFTPDownClick(Sender: TObject);
var
  cOrdner: String;
begin

  RSSView.DataController.DataSource.DataSet.Bookmark := RSSView.DataController.GetSelectedBookmark(RSSView.Controller.SelectedRecordCount-1);
  cOrdner := RSSDB.ap.GetTrimString('FTPNAME');

  if cOrdner = '' then begin
    AddLog( 'FTP: Verzeichnis od. Dateiname nicht hinterlegt!' );
    exit;
  end;

  // DownloadThread starten und in interne ObjectList setzen
  TFTPDown.DoDownload( self.Handle, cOrdner );

end;

procedure TfrmMain.OnStartFTPDownloadThread( var Msg: TMessage );
begin
  AddLog( 'FTP: Transfer Thread gestartet - ' + TFTPDown(msg.wparam).DownFilename );
end;
procedure TfrmMain.OnFinishFTPDownloadThread( var Msg: TMessage );
begin
  AddLog( 'FTP: FTPTransfer abgschlossen - ' + TFTPDown(msg.wparam).DownFilename );
  jvStatusbar1.Panels[1].Text := '';
end;
procedure TfrmMain.OnFTPThreadMessage( var Msg: TMessage );
begin
  AddLog( 'FTP: ' + PChar(msg.wparam) );
end;
procedure TfrmMain.OnFTPStatusMessage( var Msg: TMessage );
var
  cLog: String;
begin
  cLog := Format('FTP: %s / %s geladen ( %d%% )',
                  [FileSizeToStr(PTransfer(msg.lparam)^.Overall),
                   FileSizeToStr(PTransfer(msg.lparam)^.Total),
                   PTransfer(msg.lparam)^.Percent ]);
  AddLog( cLog );
  jvStatusbar1.Panels[1].Text := cLog;
end;

[nru]

:idea:

War der Timer, nicht die Messages.

TTimer gegen TJvTimer ersetzt und nun läufts.

[sx2008]

Da ist noch ein Bug:

Delphi-Quellcode:

try
  FFTPClient.Connect;
except
  on E:Exception do begin
    // FMsg ist ein Zeiger (PChar)
    FMsg := PChar('Fehler bei der Verbindungsaufnahme ('+e.Message+')');
    Synchronize( OnMessage );
    FFTPClient.Disconnect;
    FFTPClient.Quit;
    exit;
    // auf was wird der Zeiger wohl zeigen, wenn die Methode verlassen wird?
    // -> auf ungültigen Speicher !!
    // und was passiert dann in der Procedure OnMessage?
    // -> ungültiger Speicher wird ausgelesen
    // weil ja zuerst "exit" ausgeführt wird und wegen dem Synchronize-Aufruf
    // die Procedure OnMessage danach abgearbeitet wird
  end;
end;

Nachtrag:
da sind ZWEI Bugs.
Der 2. Bug ist der Aufruf von

Delphi-Quellcode:

FFTPClient.Disconnect;
FFTPClient.Quit;

Wenn man eine aktive FTP-Verbindung beenden möchte schickt man zuerst QUIT und danach kommt der Disconnect.
Also ist die Reihenfolge falsch.
Aber, da der Connect ja sowieso nicht geklappt hat, ist es unlogisch die Verbindung beenden zu wollen.

[nru]

Dankeschön fürs Feedback :thumb: