Problems with FTP !?!

[Jens Borrisholt]

Hi

This is not a request for help, but the opposite : A little help to others ...

Here is an example of how you can write your own "Send bug via FTP" and integrate it in Eurekalog.

The same thing can posible be done to SendMail etc.. but I havent looked. :)


unit FTPSendFileU;

interface

{$DEFINE HOOK_EUREKALOG}

uses
Classes
{$IFDEF HOOK_EUREKALOG}
, EWebTools
{$ENDIF};

function FTPUploadFiles(const FTP_Host, FTP_Path, FTP_UserID, FTP_Password: AnsiString;
FTP_Port: Word; LocalFiles, RemoteFiles: TStrings;
ProgressProc: TInternetProgressFunction; var ResultMsg: AnsiString): Integer;

procedure HookEurekalog;
procedure UnHookEurekalog;

implementation
uses
Windows, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdExplicitTLSClientServerBase, IdFTP,
Sysutils, GlobalStrUtilsU;

type
TJumpOfs = Integer;
PPointer = ^Pointer;

PXRedirCode = ^TXRedirCode;
TXRedirCode = packed record
Jump: Byte;
Offset: TJumpOfs;
end;

PWin9xDebugThunk = ^TWin9xDebugThunk;
TWin9xDebugThunk = packed record
PUSH: Byte;
Addr: Pointer;
JMP: TXRedirCode;
end;

PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
TAbsoluteIndirectJmp = packed record
OpCode: Word; //$FF25(Jmp, FF /4)
Addr: PPointer;
end;

var
EWebTools_FTPUploadFiles: TXRedirCode;
OldFuncPtr, NewFuncPtr: Pointer;

{ Hooking }

function GetActualAddr(Proc: Pointer): Pointer;

function IsWin9xDebugThunk(AAddr: Pointer): Boolean;
begin
Result := (AAddr <> nil) and
(PWin9xDebugThunk(AAddr).PUSH = $68) and
(PWin9xDebugThunk(AAddr).JMP.Jump = $E9);
end;
begin
if Proc <> nil then
begin
if (Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(Proc) then
Proc := PWin9xDebugThunk(Proc).Addr;
if (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
Result := PAbsoluteIndirectJmp(Proc).Addr^
else
Result := Proc;
end
else
Result := nil;
end;

procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
n: DWORD;
Code: TXRedirCode;
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
if ReadProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n) then
begin
Code.Jump := $E9;
Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
WriteProcessMemory(GetCurrentProcess, Proc, @Code, SizeOf(Code), n);
end;
end;

procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
n: Cardinal;
begin
if (BackupCode.Jump <> 0) and (Proc <> nil) then
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
WriteProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n);
BackupCode.Jump := 0;
end;
end;

function FTPUploadFiles(const FTP_Host, FTP_Path, FTP_UserID, FTP_Password: AnsiString;
FTP_Port: Word; LocalFiles, RemoteFiles: TStrings;
ProgressProc: TInternetProgressFunction; var ResultMsg: AnsiString): Integer;
var
aFile: string;
FileExt: string;
begin
ResultMsg := '';
Result := 0;

with TIdFTP.Create(nil) do
try
Host := FTP_Host;
Username := FTP_UserID;
Password := FTP_Password;
Port := FTP_Port;

Passive := True;
try
Connect;

for aFile in LocalFiles do
begin
FileExt := ExtractFileExt(aFile);
Put(aFile, 'BugReport_' + GuidToText(NewGUID) + FileExt);
end;
except on e: Exception do
begin
ResultMsg := e.Message;
Result := GetLastError;
end;

end;
finally
Free;
end;
end;

procedure HookEurekalog;
begin
OldFuncPtr := @EWebTools.FTPUploadFiles;
NewFuncPtr := @FTPSendFileU.FTPUploadFiles;

HookProc(OldFuncPtr, NewFuncPtr, EWebTools_FTPUploadFiles);
end;

procedure UnHookEurekalog;
begin
UnhookProc(NewFuncPtr, EWebTools_FTPUploadFiles);
end;

{$IFDEF HOOK_EUREKALOG}
initialization
HookEurekalog;
finalization
UnHookEurekalog;
{$ENDIF}
end.