Mtp - Memory Transfer Protocol. Client e Server
Nello scrivere Scintilla ho incontrato la necessità di trasferire molto velocemente gli screenshot del client al server.D'altra parte anche il server spedisce a client un piccolo file di testo quindi in realtà le necessità erano due: una era quella di attivare una trasmissione ricezione di memoria o file da un client verso un server, l'altra era quella di trasferire molto velocemente quantità di byte elevate.
Ho quindi scritto queste due classi, MtpServer e MtpClient, derivandole dalle classi presenti negli Overbyte ICS. Si tratta di una reinterpretazione delle già presenti classi Tftpserver e tftpClient, ma partendo dal presupposto che non vi è alcuna necessità di spogliare directory, ottenere informazioni su files e addirittura autenticarsi. In pratica, scremando un server FTP e un ftp client, si ottiene proprio un memory transfer. Nel demo allegato qui sotto viene dimostrato come sia possibile spedire la mappa di bit di un bitmap da client verso server e viceversa. Per assurdo potrebbe essere addirittura possibile lavorare direttamente con un puntatore alla memoria delle scanlines del bitmap senza passare da uno stream locale ma in questa versione ho utilizzato comunque uno stream su cui poter effettuare delle modifiche.
███╗ ███╗████████╗██████╗ ███████╗███████╗██████╗ ██╗ ██╗███████╗██████╗
████╗ ████║╚══██╔══╝██╔══██╗ ██╔════╝██╔════╝██╔══██╗██║ ██║██╔════╝██╔══██╗
██╔████╔██║ ██║ ██████╔╝ ███████╗█████╗ ██████╔╝██║ ██║█████╗ ██████╔╝
██║╚██╔╝██║ ██║ ██╔═══╝ ╚════██║██╔══╝ ██╔══██╗╚██╗ ██╔╝██╔══╝ ██╔══██╗
██║ ╚═╝ ██║ ██║ ██║ ███████║███████╗██║ ██║ ╚████╔╝ ███████╗██║ ██║
╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚══════╝╚══════╝╚═╝ ╚═╝ ╚═══╝ ╚══════╝╚═╝ ╚═╝
unit iraMtpSrv;
{$B-} { Enable partial boolean evaluation }
{$T-} { Untyped pointers }
{$X+} { Enable extended syntax }
{$H+} { Use long strings }
{$J+} { Allow typed constant to be modified }
interface
uses
Winapi.Windows,
Winapi.Messages,
OverbyteIcsWinSock,
System.SysUtils,
System.Classes,
{$IFNDEF NOFORMS}
{$IFDEF FMX}
FMX.Forms,
{$ELSE}
Vcl.Forms,
{$ENDIF}
{$ENDIF}
OverbyteIcsTypes,
OverbyteIcsUtils,
{$IFDEF FMX}
Ics.Fmx.OverbyteIcsSocketUtils,
Ics.Fmx.OverbyteIcsWndControl,
Ics.Fmx.OverbyteIcsWSocket,
Ics.Fmx.OverbyteIcsWSocketS,
{$ELSE}
OverbyteIcsWndControl,
OverbyteIcsWSocket,
OverbyteIcsSocketUtils,
OverbyteIcsWSocketS,
{$ENDIF}
OverbyteIcsFtpSrvT,
OverbyteIcsWSockBuf,
StrUtils
;
const
DefaultRcvSize = 16384;
const
ftpcPORT = 0;
ftpcSTOR = 1;
ftpcRETR = 2;
ftpcQUIT = 3;
ftpcABOR = 4;
type
PBoolean = ^Boolean;
FtpServerException = class(Exception);
TFtpString = type String;
type
EFtpCtrlSocketException = class(Exception);
TFtpCtrlState = (ftpcInvalid, ftpcWaitingUserCode,
ftpcReady, ftpcWaitingAnswer, ftpcFailedAuth);
TFtpCmdType = Byte;
type
TDisplayEvent = procedure (Sender : TObject; Msg : String) of object;
TCommandEvent = procedure (Sender : TObject; CmdBuf : PAnsiChar; CmdLen : Integer) of object;
TMtpCtrlSocket = class;
TClientProcessingThread = class(TThread)
public
Client : TMtpCtrlSocket;
Keyword : String;
Params : String;
InData : String;
OutData : String;
AuxData : String;
ClientID : Integer;
StartTick : LongWord;
Sender : TObject;
protected
procedure TriggerEnterSecurityContext;
procedure TriggerLeaveSecurityContext;
procedure Execute; override;
end;
TMtpServer = class;
TMtpCtrlSocket = class(TWSocketClient)
protected
FDataSocket : TWSocket;
FRcvBuf : PAnsiChar;
FRcvCnt : Integer;
FRcvSize : Integer;
FBusy : Boolean;
FLastCommand : TDateTime;
FCommandCount : LongInt;
FCloseRequest : Boolean;
FFtpState : TFtpCtrlState;
FAbortingTransfer : Boolean;
FUserData : LongInt;
FPeerAddr : String;
FPeerSAddr : TSockAddr;
FHost : String;
FOnDisplay : TDisplayEvent;
FOnCommand : TCommandEvent;
FEpsvAllArgReceived: Boolean;
FSndBufSize : Integer;
FRcvBufSize : Integer;
FStreamSize : LongInt;
procedure TriggerSessionConnected(Error : Word); override;
function TriggerDataAvailable(Error : Word) : boolean; override;
procedure TriggerCommand(CmdBuf : PAnsiChar; CmdLen : Integer); virtual;
procedure SetRcvSize(newValue : Integer);
procedure SetOnBgException(const Value: TIcsBgExceptionEvent); override;
procedure SetRcvBufSize(newValue : Integer);
procedure SetSndBufSize(newValue : Integer);
procedure SetStreamSize(newValue : Integer);
public
FtpServer : TMtpServer;
BinaryMode : Boolean;
DataAddr : String;
DataPort : String;
MemoryName : String;
DataSessionActive : Boolean;
DataStream : TMemoryStream;
HasOpenedFile : Boolean;
TransferError : String;
DataSent : Boolean;
CurCmdType : TFtpCmdType;
ProcessingThread : TClientProcessingThread;
AnswerDelayed : Boolean;
ByteCount : Int64;
RestartPos : Int64;
LastTick : Longword;
SessStartTick : Longword;
ReqStartTick : Longword;
XferStartTick : Longword;
ReqDurMilliSecs : Integer;
TotGetBytes : Int64;
TotPutBytes : Int64;
SessIdInfo : String;
FailedAttempts : Integer;
DelayAnswerTick : Longword;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SendAnswer(const Answer : RawByteString);
procedure SetAbortingTransfer(newValue : Boolean);
procedure TriggerSessionClosed(Error : Word); override;
procedure DataStreamWriteString(const Str: AnsiString); overload;
procedure DataStreamWriteString(const Str: AnsiString; DstCodePage: LongWord); overload;
procedure DataStreamWriteString(const Str: UnicodeString; DstCodePage: LongWord); overload;
procedure DataStreamWriteString(const Str: UnicodeString); overload;
procedure DataStreamReadString(var Str: AnsiString; Len: TFtpBigInt); overload;
procedure DataStreamReadString(var Str: AnsiString; Len: TFtpBigInt; SrcCodePage: LongWord); overload;
procedure DataStreamReadString(var Str: UnicodeString; Len: TFtpBigInt); overload;
property DataSocket : TWSocket read FDataSocket;
property LastCommand : TDateTime read FLastCommand;
property CommandCount : LongInt read FCommandCount;
property RcvBuf : PAnsiChar read FRcvBuf;
property RcvdCount;
property CloseRequest : Boolean read FCloseRequest write FCloseRequest;
property AbortingTransfer : Boolean read FAbortingTransfer write SetAbortingTransfer;
property ID : LongInt read FCliId write FCliId;
property PeerSAddr : TSockAddr read FPeerSAddr;
property ReadCount : Int64 read FReadCount;
published
property FtpState : TFtpCtrlState read FFtpState write FFtpState;
property RcvSize : Integer read FRcvSize write SetRcvSize;
property Busy : Boolean read FBusy write FBusy;
property UserData : LongInt read FUserData write FUserData;
property Host : String read FHost write FHost;
property SndBufSize : Integer read FSndBufSize write SetSndBufSize;
property RcvBufSize : Integer read FRcvBufSize write SetRcvBufSize;
property StreamSize : Integer read FStreamSize write SetStreamSize;
property OnDisplay : TDisplayEvent read FOnDisplay write FOnDisplay;
property OnCommand : TCommandEvent read FOnCommand write FOnCommand;
property OnSessionClosed;
property OnDataSent;
property HSocket;
property AllSent;
property State;
end;
TMtpCtrlSocketClass = class of TMtpCtrlSocket;
TFtpSrvClientConnectEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; AError: Word) of object;
TFtpSrvDataSessionConnectedEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; Data : TWSocket; AError: Word) of object;
TFtpSrvClientCommandEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; var Keyword : TFtpString; var Params: TFtpString;
var Answer: TFtpString) of object;
TFtpSrvAnswerToClientEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; var Answer : TFtpString) of object;
TFtpSrvDataAvailableEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; Data : TWSocket; Buf: PAnsiChar; Len: LongInt;
AError: Word) of object;
TFtpSrvRetrDataSentEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; Data : TWSocket; AError: Word) of object;
TFtpSrvGetProcessingEvent = procedure (Sender : TObject; Client: TMtpCtrlSocket; var DelayedSend: Boolean) of object;
TFtpSrvCommandProc = procedure (Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params : TFtpString; var Answer : TFtpString) of object;
TFtpSrvCommandTableItem = record
KeyWord : String;
Proc : TFtpSrvCommandProc;
end;
TFtpSrvCommandTable = array of TFtpSrvCommandTableItem;
TFtpSecurityContextEvent = procedure (Sender: TObject;Client: TMtpCtrlSocket) of object;
TFtpSrvGeneralEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; var Params: TFtpString; var Answer: TFtpString) of object;
TFtpSrvTimeoutEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; Duration: Integer; var Abort: Boolean) of object;
TFtpSrvDisplayEvent = procedure (Sender: TObject; Client: TMtpCtrlSocket; Msg: TFtpString) of object;
TMtpServer = class(TIcsWndControl)
protected
FAddr : String;
FSocketFamily : TSocketFamily;
FPort : String;
FListenBackLog : Integer;
FSocketServer : TWSocketServer ;
FClientClass : TMtpCtrlSocketClass;
FMaxClients : LongInt;
FCmdTable : TFtpSrvCommandTable;
FLastCmd : Integer;
FUserData : LongInt;
FTimeoutSecsLogin : Integer;
FTimeoutSecsIdle : Integer;
FTimeoutSecsXfer : Integer;
FEventTimer : TIcsTimer;
FAlloExtraSpace : Integer;
FMaxAttempts : Integer;
FBindFtpData : Boolean;
FMsg_WM_FTPSRV_CLOSE_REQUEST : UINT;
FMsg_WM_FTPSRV_ABORT_TRANSFER : UINT;
FMsg_WM_FTPSRV_CLOSE_DATA : UINT;
FMsg_WM_FTPSRV_START_SEND : UINT;
FOnStart : TNotifyEvent;
FOnStop : TNotifyEvent;
FOnClientConnect : TFtpSrvClientConnectEvent;
FOnClientDisconnect : TFtpSrvClientConnectEvent;
FOnClientCommand : TFtpSrvClientCommandEvent;
FOnAnswerToClient : TFtpSrvAnswerToClientEvent;
FOnStorSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnStorSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnStorDataAvailable : TFtpSrvDataAvailableEvent;
FOnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnRetrSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnRetrDataSent : TFtpSrvRetrDataSentEvent;
FOnGetProcessing : TFtpSrvGetProcessingEvent;
FOnEnterSecurityContext : TFtpSecurityContextEvent;
FOnLeaveSecurityContext : TFtpSecurityContextEvent;
FOnTimeout : TFtpSrvTimeoutEvent;
FOnDisplay : TFtpSrvDisplayEvent;
procedure CreateSocket; virtual;
function GetMultiListenIndex: Integer;
function GetMultiListenSockets: TWSocketMultiListenCollection;
procedure SetMultiListenSockets(const Value: TWSocketMultiListenCollection);
procedure SetOnBgException(const Value: TIcsBgExceptionEvent); override;
procedure ClientProcessingThreadTerminate(Sender : TObject);
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure ServSocketStateChange(Sender: TObject; OldState, NewState: TSocketState);
procedure ClientDataSent(Sender: TObject; AError : Word); virtual;
procedure ClientCommand(Sender: TObject; CmdBuf: PAnsiChar; CmdLen: Integer);
procedure ClientStorSessionConnected(Sender: TObject; AError : Word);
procedure ClientStorSessionClosed(Sender: TObject; AError : Word);
procedure ClientStorDataAvailable(Sender: TObject; AError : word); virtual;
procedure ClientRetrSessionConnected(Sender: TObject; AError : Word); virtual;
procedure ClientRetrSessionClosed(Sender: TObject; AError : Word);
procedure ClientRetrDataSent(Sender: TObject; AError : Word);
procedure SendAnswer(Client: TMtpCtrlSocket; Answer: TFtpString); virtual;
procedure SendNextDataChunk(Client: TMtpCtrlSocket; Data: TWSocket); virtual;
procedure StartSendData(Client: TMtpCtrlSocket);
procedure PrepareStorDataSocket(Client: TMtpCtrlSocket);
procedure EventTimerOnTimer(Sender: TObject);
procedure ServerClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word);
procedure ServerClientDisconnect(Sender: TObject; Client: TWSocketClient; Error: Word);
procedure TriggerServerStart; virtual;
procedure TriggerServerStop; virtual;
procedure TriggerSendAnswer(Client: TMtpCtrlSocket; var Answer: TFtpString); virtual;
procedure TriggerClientConnect(Client: TMtpCtrlSocket; AError: Word); virtual;
procedure TriggerClientDisconnect(Client: TMtpCtrlSocket; AError: Word); virtual;
procedure TriggerClientCommand(Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params: TFtpString; var Answer: TFtpString); virtual;
procedure TriggerStorSessionConnected(Client: TMtpCtrlSocket; Data: TWSocket; AError: Word); virtual;
procedure TriggerStorSessionClosed(Client: TMtpCtrlSocket; Data: TWSocket; AError: Word); virtual;
procedure TriggerRetrSessionConnected(Client: TMtpCtrlSocket; Data: TWSocket; AError: Word); virtual;
procedure TriggerRetrSessionClosed(Client: TMtpCtrlSocket; Data: TWSocket; AError: Word); virtual;
procedure TriggerStorDataAvailable(Client: TMtpCtrlSocket; Data: TWSocket; Buf: PAnsiChar; Len: LongInt; AError: Word); virtual;
procedure TriggerRetrDataSent(Client: TMtpCtrlSocket;Data: TWSocket; AError: Word); virtual;
procedure TriggerEnterSecurityContext(Client: TMtpCtrlSocket); virtual;
procedure TriggerLeaveSecurityContext(Client: TMtpCtrlSocket); virtual;
procedure TriggerTimeout (Client: TMtpCtrlSocket; Duration: Integer; var Abort : Boolean); virtual;
procedure TriggerDisplay (Client : TMtpCtrlSocket; Msg: TFtpString); virtual;
function GetClientCount: Integer; virtual;
function GetClient(nIndex: Integer): TMtpCtrlSocket; virtual;
function GetActive: Boolean;
procedure SetActive(newValue: Boolean);
procedure SetClientClass(const NewValue: TMtpCtrlSocketClass);
procedure AddCommand(const Keyword: String; const Proc: TFtpSrvCommandProc); virtual;
procedure WMFtpSrvCloseRequest(var msg: TMessage); virtual;
procedure WMFtpSrvAbortTransfer(var msg: TMessage); virtual;
procedure WMFtpSrvCloseData(var msg: TMessage); virtual;
procedure WMFtpSrvStartSend(var msg: TMessage); virtual;
procedure CommandQUIT(Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params: TFtpString; var Answer: TFtpString); virtual;
procedure CommandPORT(Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params: TFtpString; var Answer: TFtpString); virtual;
procedure CommandSTOR(Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params: TFtpString; var Answer: TFtpString); virtual;
procedure CommandRETR(Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params: TFtpString; var Answer: TFtpString); virtual;
procedure CommandABOR(Client: TMtpCtrlSocket; var Keyword: TFtpString; var Params: TFtpString; var Answer: TFtpString); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Start;
procedure Stop;
procedure Disconnect(Client : TMtpCtrlSocket);
procedure DisconnectAll;
procedure DoStartSendData(Client: TMtpCtrlSocket; var Answer : TFtpString); virtual;
procedure AllocateMsgHandlers; override;
procedure FreeMsgHandlers; override;
function MsgHandlersCount: Integer; override;
procedure WndProc(var MsgRec: TMessage); override;
function IsClient(SomeThing : TObject) : Boolean;
function OpenMemoryStream( ): TMemoryStream;
procedure CloseMemoryStreams(Client : TMtpCtrlSocket);
property ServSocket : TWSocketServer read FSocketServer;
property ClientCount : Integer read GetClientCount;
property Active : Boolean read GetActive write SetActive;
property ClientClass : TMtpCtrlSocketClass read FClientClass write SetClientClass;
property Client[nIndex : Integer] : TMtpCtrlSocket read GetClient;
property MultiListenIndex : Integer read GetMultiListenIndex;
published
property Addr : String read FAddr write FAddr;
property BindFtpData : Boolean read FBindFtpData write FBindFtpData default True;
property SocketFamily : TSocketFamily read FSocketFamily write FSocketFamily;
property Port : String read FPort write FPort;
property ListenBackLog : Integer read FListenBackLog write FListenBackLog;
property MultiListenSockets : TWSocketMultiListenCollection read GetMultiListenSockets write SetMultiListenSockets;
property UserData : LongInt read FUserData write FUserData;
property MaxClients : LongInt read FMaxClients write FMaxClients;
property TimeoutSecsLogin : Integer read FTimeoutSecsLogin write FTimeoutSecsLogin;
property TimeoutSecsIdle : Integer read FTimeoutSecsIdle write FTimeoutSecsIdle;
property TimeoutSecsXfer : Integer read FTimeoutSecsXfer write FTimeoutSecsXfer;
property AlloExtraSpace : Integer read FAlloExtraSpace write FAlloExtraSpace;
property MaxAttempts : Integer read FMaxAttempts write FMaxAttempts ;
property OnStart : TNotifyEvent read FOnStart write FOnStart;
property OnStop : TNotifyEvent read FOnStop write FOnStop;
property OnClientDisconnect : TFtpSrvClientConnectEvent read FOnClientDisconnect write FOnClientDisconnect;
property OnClientConnect : TFtpSrvClientConnectEvent read FOnClientConnect write FOnClientConnect;
property OnClientCommand : TFtpSrvClientCommandEvent read FOnClientCommand write FOnClientCommand;
property OnAnswerToClient : TFtpSrvAnswerToClientEvent read FOnAnswerToClient write FOnAnswerToClient;
property OnStorSessionConnected : TFtpSrvDataSessionConnectedEvent read FOnStorSessionConnected write FOnStorSessionConnected;
property OnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent read FOnRetrSessionConnected write FOnRetrSessionConnected;
property OnStorSessionClosed : TFtpSrvDataSessionConnectedEvent read FOnStorSessionClosed write FOnStorSessionClosed;
property OnRetrSessionClosed : TFtpSrvDataSessionConnectedEvent read FOnRetrSessionClosed write FOnRetrSessionClosed;
property OnRetrDataSent : TFtpSrvRetrDataSentEvent read FOnRetrDataSent write FOnRetrDataSent;
property OnStorDataAvailable : TFtpSrvDataAvailableEvent read FOnStorDataAvailable write FOnStorDataAvailable;
property OnGetProcessing : TFtpSrvGetProcessingEvent read FOnGetProcessing write FOnGetProcessing;
property OnEnterSecurityContext : TFtpSecurityContextEvent read FOnEnterSecurityContext write FOnEnterSecurityContext;
property OnLeaveSecurityContext : TFtpSecurityContextEvent read FOnLeaveSecurityContext write FOnLeaveSecurityContext;
property OnTimeout : TFtpSrvTimeoutEvent read FOnTimeout write FOnTimeout;
property OnDisplay : TFtpSrvDisplayEvent read FOnDisplay write FOnDisplay;
property OnBgException;
end;
procedure UpdateThreadOnProgress(Obj: TObject; Count: Int64; var Cancel: Boolean);
procedure register;
implementation
const
msgCmdUnknown = '500 ''%s'': command not understood.';
msgOptRespRequired = '331 Response to %s required for %s.';
msgQuit = '221 Goodbye.';
msgPortSuccess = '200 Port command successful.';
msgPortFailed = '501 Invalid PORT command.';
msgStorDisabled = '501 Permission Denied'; {'500 Cannot STOR.';}
msgStorSuccess = '150 Opening data connection for %s.';
msgStorFailed = '501 Cannot STOR. %s';
msgStorAborted = '426 Connection closed; %s.';
msgStorOk = '226 File received ok';
{ msgStorOk = '226-Multiple lines answer'#13#10' Test'#13#10#13#10'226 File received OK'; }
msgStorError = '426 Connection closed; transfer aborted. Error %s';
msgRetrDisabled = '500 Cannot RETR.';
msgRetrSuccess = '150 Opening retrieve data connection for ';
msgRetrFailed = '501 Cannot RETR. %s';
msgRetrAborted = '426 Connection closed; %s.';
msgRetrOk = '226 File sent ok';
msgRetrError = '426 Connection closed; transfer aborted. Error %s';
msgRetrNotExists = '550 ''%s'': no such file or directory.';
msgRetrFileErr = '451 Cannot open file: %s.';
msgAborOk = '225 ABOR command successful.';
msgTimeout = '421 Connection closed, timed out after %d secs.';
msgNotAllowed = '421 Connection not allowed.';
procedure register;
begin
RegisterComponents('ira Mtp', [TMtpServer]);
end;
function atosi(const value : String) : Integer;
var
i, j : Integer;
begin
Result := 0;
i := 1;
while (i <= Length(Value)) and (Value[i] = ' ') do
i := i + 1;
j := i;
while (i <= Length(Value)) and ((Value[i] = '+') or (Value[i] = '-')) do
i := i + 1;
while (i <= Length(Value)) and (Value[i] >= '0') and (Value[i] <= '9')do begin
Result := Result * 10 + ord(Value[i]) - ord('0');
i := i + 1;
end;
if j < Length(Value) then begin
if value[j] = '-' then
Result := -Result;
end;
end;
procedure TMtpServer.CreateSocket;
begin
FSocketServer := TWSocketServer.Create(Self);
end;
constructor TMtpServer.Create(AOwner: TComponent);
var
Len : Cardinal;
begin
inherited Create(AOwner);
AllocateHWnd;
FClientClass := TMtpCtrlSocket;
//FSocketServer := TWSocketServer.Create(Self);
CreateSocket;
FSocketServer.Name := 'WSocketServer';
FSocketServer.ClientClass := FClientClass;
FSocketServer.OnClientConnect := ServerClientConnect;
FSocketServer.OnClientDisconnect := ServerClientDisconnect;
FPort := 'ftp';
FSocketFamily := DefaultSocketFamily;
FAddr := ICS_ANY_HOST_V4;
FListenBackLog := 5;
FTimeoutSecsLogin := 60;
FTimeoutSecsIdle := 300;
FTimeoutSecsXfer := 60;
FAlloExtraSpace := 1000000;
FEventTimer := TIcsTimer.Create(Self);
FEventTimer.Enabled := false;
FEventTimer.OnTimer := EventTimerOnTimer;
FEventTimer.Interval := 5000;
FMaxAttempts := 12 ;
FBindFtpData := True;
SetLength(FCmdTable, 5 + 1 + 5);
AddCommand('PORT', CommandPORT);
AddCommand('STOR', CommandSTOR);
AddCommand('RETR', CommandRETR);
AddCommand('QUIT', CommandQUIT);
AddCommand('ABOR', CommandABOR);
end;
destructor TMtpServer.Destroy;
begin
if Assigned(FEventTimer) then begin
FEventTimer.Destroy;
FEventTimer := nil;
end;
if Assigned(FSocketServer) then begin
FSocketServer.Destroy;
FSocketServer := nil;
end;
SetLength(FCmdTable, 0);
inherited Destroy;
end;
function TMtpServer.MsgHandlersCount : Integer;
begin
Result := 5 + inherited MsgHandlersCount;
end;
procedure TMtpServer.AllocateMsgHandlers;
begin
inherited AllocateMsgHandlers;
FMsg_WM_FTPSRV_CLOSE_REQUEST := FWndHandler.AllocateMsgHandler(Self);
FMsg_WM_FTPSRV_ABORT_TRANSFER := FWndHandler.AllocateMsgHandler(Self);
FMsg_WM_FTPSRV_CLOSE_DATA := FWndHandler.AllocateMsgHandler(Self);
FMsg_WM_FTPSRV_START_SEND := FWndHandler.AllocateMsgHandler(Self);
end;
procedure TMtpServer.FreeMsgHandlers;
begin
if Assigned(FWndHandler) then begin
FWndHandler.UnregisterMessage(FMsg_WM_FTPSRV_CLOSE_REQUEST);
FWndHandler.UnregisterMessage(FMsg_WM_FTPSRV_ABORT_TRANSFER);
FWndHandler.UnregisterMessage(FMsg_WM_FTPSRV_CLOSE_DATA);
FWndHandler.UnregisterMessage(FMsg_WM_FTPSRV_START_SEND);
end;
inherited FreeMsgHandlers;
end;
procedure TMtpServer.WndProc(var MsgRec: TMessage);
begin
try
with MsgRec do begin
if Msg = FMsg_WM_FTPSRV_CLOSE_REQUEST then
WMFtpSrvCloseRequest(MsgRec)
else if Msg = FMsg_WM_FTPSRV_ABORT_TRANSFER then
WMFtpSrvAbortTransfer(MsgRec)
else if Msg = FMsg_WM_FTPSRV_CLOSE_DATA then
WMFtpSrvCloseData(MsgRec)
else if Msg = FMsg_WM_FTPSRV_START_SEND then
WMFtpSrvStartSend(MsgRec)
else
inherited WndProc(MsgRec);
end;
except
on E:Exception do
HandleBackGroundException(E);
end;
end;
procedure TMtpServer.WMFtpSrvCloseRequest(var msg: TMessage);
var
Client : TMtpCtrlSocket;
begin
Client := TMtpCtrlSocket(msg.LParam);
if FSocketServer.IsClient(Client) then begin
{ Check if client.ID is still the same as when message where posted }
if WPARAM(Client.ID) = Msg.WParam then begin
if Client.AllSent then
Client.Close
else
Client.CloseRequest := TRUE;
end;
end;
end;
procedure TMtpServer.Notification(AComponent: TComponent; operation: TOperation);
begin
inherited Notification(AComponent, operation);
if operation = opRemove then begin
if AComponent = FSocketServer then
FSocketServer := nil;
end;
end;
function TMtpServer.OpenMemoryStream ( ): TMemoryStream;
begin
Result := TMemoryStream.Create ; //( MAX_BUFSIZE);
end ;
procedure TMtpServer.CloseMemoryStreams(Client : TMtpCtrlSocket);
begin
if Client.HasOpenedFile then begin
if Assigned(Client.DataStream) then Client.DataStream.Destroy;
Client.DataStream := nil;
Client.HasOpenedFile := FALSE;
end;
end;
procedure TMtpServer.AddCommand(
const Keyword : String;
const Proc : TFtpSrvCommandProc);
begin
if FLastCmd > High(FCmdTable) then
raise FtpServerException.Create('Too many command');
FCmdTable[FLastCmd].KeyWord := KeyWord;
FCmdTable[FLastCmd].Proc := Proc;
Inc(FLastCmd);
end;
procedure TMtpServer.Start;
begin
if FSocketServer.State = wsListening then
Exit;
FSocketServer.Port := Port;
FSocketServer.Proto := 'tcp';
FSocketServer.SocketFamily := FSocketFamily;
FSocketServer.Addr := FAddr;
FSocketServer.ListenBacklog := FListenBackLog;
FSocketServer.banner := '';
FSocketServer.MaxClients := FMaxClients;
FSocketServer.OnChangeState := ServSocketStateChange;
FSocketServer.ComponentOptions := [wsoNoReceiveLoop];
FSocketServer.MultiListen;
FEventTimer.Enabled := true;
end;
procedure TMtpServer.Stop;
begin
FEventTimer.Enabled := false;
FSocketServer.Close;
end;
procedure TMtpServer.DisconnectAll;
begin
FSocketServer.DisconnectAll;
end;
procedure TMtpServer.Disconnect(Client : TMtpCtrlSocket);
begin
if NOT FSocketServer.IsClient(Client) then
raise FtpServerException.Create('Disconnect: Not one of our clients');
FSocketServer.Disconnect(Client);
end;
function TMtpServer.GetActive : Boolean;
begin
Result := (FSocketServer.State = wsListening);
end;
procedure TMtpServer.SetActive(newValue : Boolean);
begin
if newValue then
Start
else
Stop;
end;
procedure TMtpServer.SetClientClass(const NewValue: TMtpCtrlSocketClass);
begin
if NewValue <> FSocketServer.ClientClass then begin
FClientClass := NewValue;
FSocketServer.ClientClass := NewValue;
end;
end;
procedure TMtpServer.ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
begin
if csDestroying in ComponentState then
Exit;
if NewState = wsListening then
TriggerServerStart
else if NewState = wsClosed then
TriggerServerStop;
end;
procedure TMtpServer.ServerClientConnect(Sender: TObject;
Client: TWSocketClient; Error: Word);
var
MyClient: TMtpCtrlSocket;
begin
if Error <> 0 then
raise FtpServerException.Create('Session Available Error - ' +
GetWinsockErr(Error));
MyClient := Client as TMtpCtrlSocket;
MyClient.DataSocket.Name := Name + '_DataWSocket' + IntToStr(MyClient.ID);
MyClient.OnCommand := ClientCommand;
MyClient.OnDataSent := ClientDataSent;
MyClient.FtpServer := Self;
MyClient.SessIdInfo := Client.GetPeerAddr + ' [' + IntToStr (Client.CliId) + ']' ;
MyClient.FLastCommand := 0;
MyClient.FCommandCount := 0;
MyClient.FFtpState := ftpcWaitingUserCode; // ftpcReady;
end;
procedure TMtpServer.SendAnswer(Client : TMtpCtrlSocket; Answer : TFtpString);
begin
try
Client.ReqDurMilliSecs := IcsElapsedMsecs (Client.ReqStartTick);
TriggerSendAnswer(Client, Answer);
Client.SendAnswer(Answer);
except
end;
end;
procedure TMtpServer.ClientCommand(Sender : TObject; CmdBuf : PAnsiChar; CmdLen : Integer);
const
TELNET_IAC = #255;
TELNET_IP = #244;
TELNET_DATA_MARK = #242;
var
Client : TMtpCtrlSocket;
Answer : TFtpString;
Params : TFtpString;
KeyWord : TFtpString;
I : Integer;
RawParams: RawByteString;
begin
Client := Sender as TMtpCtrlSocket;
Answer := '';
try
Client.ReqStartTick := IcsGetTickCountX;
Client.ReqDurMilliSecs := 0;
RawParams := '';
I := 0;
while I < CmdLen do begin
if CmdBuf[I] <> TELNET_IAC then begin
RawParams := RawParams + CmdBuf[I];
Inc(I);
end
else begin
Inc(I);
if CmdBuf[I] = TELNET_IAC then
RawParams := RawParams + CmdBuf[I];
Inc(I);
end;
end;
Params := RawParams;
I := 1;
KeyWord := UpperCase(ScanGetAsciiArg (Params, I));
ScanFindArg (Params, I);
Params := Copy(Params, I, Length(Params));
TriggerClientCommand(Client, Keyword, Params, Answer);
if Answer <> '' then begin
SendAnswer(Client, Answer);
Exit;
end;
if Keyword = '' then begin
SendAnswer(Client, Format(msgCmdUnknown, [Params]));
Exit;
end;
I := 0;
while I <= High(FCmdTable) do begin
if FCmdTable[I].KeyWord = KeyWord then begin
if I <> ftpcABOR then { AG V8.02 }
Client.CurCmdType := I;
Client.AnswerDelayed := FALSE;
FCmdTable[I].Proc(Client, KeyWord, Params, Answer);
if not Client.AnswerDelayed then
SendAnswer(Client, Answer);
Exit;
end;
Inc(I);
end;
SendAnswer(Client, Format(msgCmdUnknown, [KeyWord]));
except
on E:Exception do begin
SendAnswer(Client, '501 ' + E.Message);
end;
end;
end;
procedure TMtpServer.ClientDataSent(Sender : TObject; AError : Word);
var
Client : TMtpCtrlSocket;
begin
Client := Sender as TMtpCtrlSocket;
if Client.CloseRequest then begin
PostMessage(Handle, FMsg_WM_FTPSRV_CLOSE_REQUEST,
WPARAM(Client.ID), LPARAM(Client));
end;
end;
procedure TMtpServer.ServerClientDisconnect(Sender: TObject; Client: TWSocketClient; Error: Word);
var
MyClient: TMtpCtrlSocket;
begin
try
MyClient := Client as TMtpCtrlSocket;
if MyClient.DataSocket.State = wsConnected then begin
MyClient.TransferError := 'ABORT on Disconnect';
MyClient.AbortingTransfer := TRUE;
MyClient.DataSocket.Close;
end;
CloseMemoryStreams(MyClient);
TriggerClientDisconnect(MyClient, Error);
except
end;
end;
procedure TMtpServer.WMFtpSrvAbortTransfer(var msg: TMessage);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
begin
Client := TMtpCtrlSocket(Msg.LParam);
if FSocketServer.IsClient(Client) then begin
if WPARAM(Client.ID) = Msg.WParam then begin
Data := Client.DataSocket;
if Assigned(Data) then begin
Data.ShutDown(2);
Data.Close;
end;
Client.DataStream.position:=0;
end;
end;
end;
procedure TMtpServer.WMFtpSrvCloseData(var msg: TMessage);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
begin
Client := TMtpCtrlSocket(Msg.LParam);
if FSocketServer.IsClient(Client) then begin
{ Check if client.ID is still the same as when message where posted }
if WPARAM(Client.ID) = Msg.WParam then begin
Data := Client.DataSocket;
if Assigned(Data) then begin
Data.ShutDown(1); { Wilfried 24/02/04 }
end;
Client.DataStream.position:=0;
end;
end;
end;
function TMtpServer.GetClient(nIndex : Integer) : TMtpCtrlSocket;
begin
Result := FSocketServer.Client [nIndex] as TMtpCtrlSocket;
end;
function TMtpServer.IsClient(SomeThing : TObject) : Boolean;
begin
Result := FSocketServer.IsClient(Something);
end;
function TMtpServer.GetClientCount : Integer;
begin
Result := FSocketServer.ClientCount;
end;
procedure TMtpServer.TriggerServerStart;
begin
if Assigned(FOnStart) then
FOnStart(Self);
end;
procedure TMtpServer.TriggerServerStop;
begin
if Assigned(FOnStop) then
FOnStop(Self);
end;
procedure TMtpServer.TriggerSendAnswer(Client : TMtpCtrlSocket; var Answer : TFtpString);
begin
if Assigned(FOnAnswerToClient) then
FOnAnswerToClient(Self, Client, Answer);
end;
procedure TMtpServer.TriggerClientDisconnect(Client : TMtpCtrlSocket; AError : Word);
begin
if Assigned(FOnClientDisconnect) then
FOnClientDisconnect(Self, Client, AError);
end;
procedure TMtpServer.TriggerClientConnect(Client : TMtpCtrlSocket; AError : Word);
begin
if Assigned(FOnClientConnect) then
FOnClientConnect(Self, Client, AError);
end;
procedure TMtpServer.TriggerStorSessionConnected(Client : TMtpCtrlSocket; Data : TWSocket; AError : Word);
begin
if Assigned(FOnStorSessionConnected) then
FOnStorSessionConnected(Self, Client, Data, AError);
end;
procedure TMtpServer.TriggerRetrSessionConnected(Client : TMtpCtrlSocket; Data : TWSocket; AError : Word);
begin
if Assigned(FOnRetrSessionConnected) then
FOnRetrSessionConnected(Self, Client, Data, AError);
end;
procedure TMtpServer.TriggerStorSessionClosed( Client : TMtpCtrlSocket; Data : TWSocket; AError : Word);
begin
if Assigned(FOnStorSessionClosed) then
FOnStorSessionClosed(Self, Client, Data, AError);
end;
procedure TMtpServer.TriggerRetrSessionClosed(Client : TMtpCtrlSocket; Data : TWSocket; AError : Word);
begin
if Assigned(FOnRetrSessionClosed) then
FOnRetrSessionClosed(Self, Client, Data, AError);
end;
procedure TMtpServer.TriggerClientCommand(
Client : TMtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Assigned(FOnClientCommand) then
FOnClientCommand(Self, Client, KeyWord, Params, Answer);
end;
procedure TMtpServer.TriggerStorDataAvailable(
Client : TMtpCtrlSocket;
Data : TWSocket;
Buf : PAnsiChar;
Len : LongInt;
AError : Word);
begin
if Assigned(FOnStorDataAvailable) then
FOnStorDataAvailable(Self, Client, Data, Buf, Len, AError);
end;
procedure TMtpServer.TriggerRetrDataSent(
Client : TMtpCtrlSocket;
Data : TWSocket;
AError : Word);
begin
if Assigned(FOnRetrDataSent) then
FOnRetrDataSent(Self, Client, Data, AError);
end;
procedure TMtpServer.TriggerEnterSecurityContext(Client : TMtpCtrlSocket);
begin
if Assigned(FOnEnterSecurityContext) then
FOnEnterSecurityContext(Self, Client);
end;
procedure TMtpServer.TriggerLeaveSecurityContext( Client : TMtpCtrlSocket);
begin
if Assigned(FOnLeaveSecurityContext) then
FOnLeaveSecurityContext(Self, Client);
end;
procedure TMtpServer.TriggerTimeout( Client: TMtpCtrlSocket; Duration: Integer; var Abort : Boolean);
begin
if Assigned(FOnTimeout) then
FOnTimeout(Self, Client, Duration, Abort);
end;
procedure TMtpServer.TriggerDisplay(Client : TMtpCtrlSocket; Msg: TFtpString);
begin
if Assigned(FOnDisplay) then
FOnDisplay(Self, Client, Msg);
end;
procedure TMtpServer.CommandQUIT(Client: TMtpCtrlSocket; var Keyword : TFtpString; var Params : TFtpString; var Answer : TFtpString);
begin
Client.CurCmdType := ftpcQUIT;
Answer := msgQuit;
PostMessage(Handle, FMsg_WM_FTPSRV_CLOSE_REQUEST,
WPARAM(Client.ID), LPARAM(Client));
end;
function GetInteger(var I : Integer; const Src : String) : LongInt;
begin
while (I <= Length(Src)) and IsSpace(Src[I]) do
Inc(I);
Result := 0;
while (I <= Length(Src)) and IsDigit(Src[I]) do begin
Result := Result * 10 + Ord(Src[I]) - Ord('0');
Inc(I);
end;
{ Skip trailing white spaces }
while (I <= Length(Src)) and IsSpace(Src[I]) do
Inc(I);
if I <= Length(Src) then begin
if Src[I] = ',' then
Inc(I)
else
raise FtpServerException.Create('GetInteger: unexpected char');
end;
end;
procedure TMtpServer.CommandPORT(Client: TMtpCtrlSocket; var Keyword : TFtpString; var Params : TFtpString; var Answer : TFtpString);
var
I : Integer;
N : LongInt;
begin
try
Client.CurCmdType := ftpcPORT;
I := 1;
Client.DataAddr := IntToStr(GetInteger(I, Params));
Client.DataAddr := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
Client.DataAddr := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
Client.DataAddr := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
N := GetInteger(I, Params);
N := (N shl 8) + GetInteger(I, Params);
Client.DataPort := IcsIntToStrA(N);
Answer := msgPortSuccess;
except
Answer := msgPortFailed;
end;
end;
procedure TMtpServer.CommandSTOR(Client: TMtpCtrlSocket; var Keyword : TFtpString; var Params : TFtpString; var Answer : TFtpString);
var
Allowed : Boolean;
FilePath : TFtpString;
n: Integer;
begin
try
if Client.FtpState <> ftpcWaitingUserCode then begin
Answer := 'not ftpcWaitingUserCode';
Exit;
end;
if Params = '' then begin
Answer := Format(msgStorFailed, ['Size not specified']);
Exit;
end
else
n:= Pos ( ' ', Params , 1);
if n = 0 then begin
Answer := 'MemoryName not specified';
Exit;
end;
Client.StreamSize := StrToIntDef( LeftStr ( Params,n-1) , 0);
Client.MemoryName := rightStr ( Params , length(params) - n ) ;
if Assigned(Client.DataStream ) then begin
Client.DataStream.SetSize( Client.StreamSize) ;
Client.DataStream.Position :=0;
end;
try
Client.CurCmdType := ftpcSTOR;
//Client.MemoryName := Client.PeerAddr ;
Client.HasOpenedFile := FALSE;
Allowed := True;
PrepareStorDataSocket(Client); // <--- connect al client
Answer := Format(msgStorSuccess, [Params]);
except
on E:Exception do begin
Answer := Format(msgStorFailed, [E.Message]);
end;
end;
finally
end;
end;
procedure TMtpServer.PrepareStorDataSocket(Client : TMtpCtrlSocket);
begin
Client.AbortingTransfer := FALSE;
Client.TransferError := 'Transfer Ok';
Client.DataSocket.Proto := 'tcp';
Client.DataSocket.Addr := Client.DataAddr;
Client.DataSocket.Port := Client.DataPort;
Client.DataSocket.OnSessionConnected := ClientStorSessionConnected;
Client.DataSocket.OnSessionClosed := ClientStorSessionClosed;
Client.DataSocket.OnDataAvailable := ClientStorDataAvailable;
Client.DataSocket.OnDataSent := nil;
Client.DataSocket.LingerOnOff := wsLingerOff;
Client.DataSocket.LingerTimeout := 0;
if FBindFtpData then begin
Client.DataSocket.LocalAddr := Client.GetXAddr;
Client.DataSocket.LocalPort := 'ftp-data'; {20}
end;
Client.DataSocket.ComponentOptions := [wsoNoReceiveLoop];
Client.DataSocket.Connect;
if Client.DataSocket.SocketRcvBufSize <> Client.FRcvBufSize then
Client.DataSocket.SocketRcvBufSize := Client.FRcvBufSize;
end;
procedure TMtpServer.ClientStorSessionConnected(Sender : TObject; AError : Word);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TMtpCtrlSocket(Data.Owner);
Client.DataSessionActive := TRUE;
Client.ByteCount := 0;
Client.TotPutBytes :=0; // ogni volta inizia da 0.
if Assigned (Client.DataStream) then begin
Client.DataStream.SetSize(Client.StreamSize );
Client.DataStream.Position :=0;
end;
Client.XferStartTick := IcsGetTickCountX;
Client.LastTick := IcsGetTickCountX;
if Client.AbortingTransfer then
Exit;
TriggerStorSessionConnected(Client, Data, AError);
end;
procedure TMtpServer.ClientStorSessionClosed(Sender : TObject; AError : Word);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
Duration : Integer;
S : String;
BytesSec : Int64;
Answer : String;
begin
Data := TWSocket(Sender);
Client := TMtpCtrlSocket(Data.Owner);
Client.DataSessionActive := FALSE;
Client.RestartPos := 0;
Client.DataPort := 'ftp-data';
if Assigned(FOnDisplay) then begin
Duration := IcsElapsedMsecs (Client.XferStartTick);
S := Client.MemoryName + ' ' +
IntToKbyte(Client.ByteCount) + 'bytes received in ';
if Duration < 2000 then
S := S + IntToStr(Duration) + ' milliseconds'
else begin
S := S + IntToStr(Duration div 1000) + ' seconds';
if Client.ByteCount > 32767 then
BytesSec := 1000 * (Client.ByteCount div Duration)
else
BytesSec := (1000 * Client.ByteCount) div Duration;
S := S + ' (' + IntToKbyte(BytesSec) + 'bytes/sec)';
end;
TriggerDisplay (Client, S);
end;
if Client.AbortingTransfer and (Client.TransferError = '') then
Exit;
Answer := '';
case Client.CurCmdType of
ftpcSTOR :
begin
if Client.AbortingTransfer then
Answer := Format(msgStorAborted, [Client.TransferError])
else if AError = 0 then
Answer := msgStorOk + ':' + Client.memoryName
else
Answer := Format(msgStorError, [GetWinsockErr(AError)]);
end;
else
raise Exception.Create('Program error in ClientStorSessionClosed');
exit;
end;
Client.DataStream.position:=0;
TriggerStorSessionClosed(Client, Data, AError);
SendAnswer(Client, Answer);
end;
procedure TMtpServer.ClientStorDataAvailable(Sender: TObject; AError : word);
var
Len : Integer;
Client : TMtpCtrlSocket;
Data : TWSocket;
NewPos : TFtpBigInt;
begin
Data := TWSocket(Sender);
Client := TMtpCtrlSocket(Data.Owner);
Len := Data.Receive(Client.RcvBuf, Client.RcvSize);
if Len <= 0 then
Exit;
if Client.AbortingTransfer then
Exit;
Client.LastTick := IcsGetTickCountX;
try
TriggerStorDataAvailable(Client, Data, Client.RcvBuf, Len, AError);
if (not Client.HasOpenedFile) and (not Assigned(Client.DataStream)) then begin
TriggerEnterSecurityContext(Client);
try
Client.DataStream := OpenMemoryStream( );
finally
TriggerLeaveSecurityContext(Client);
end;
NewPos := 0;
Client.HasOpenedFile := TRUE;
end;
if Assigned(Client.DataStream) then begin
Client.ByteCount := Client.ByteCount + Len;
Client.TotPutBytes := Client.TotPutBytes + Len;
TriggerEnterSecurityContext(Client);
try
// CopyMemory ( DirectMemoryPtr^, Client.RcvBuf^, Len);
Client.DataStream.WriteBuffer(Client.RcvBuf^, Len);
finally
TriggerLeaveSecurityContext(Client);
end;
end;
except
on E:Exception do begin
Client.TransferError := E.Message;
Client.AbortingTransfer := TRUE;
PostMessage(Handle, FMsg_WM_FTPSRV_ABORT_TRANSFER,
WPARAM(Client.ID), LPARAM(Client));
end;
end;
end;
procedure TMtpServer.CommandRETR( Client: TMtpCtrlSocket; var Keyword : TFtpString; var Params : TFtpString; var Answer : TFtpString);
var
Allowed : Boolean;
FilePath : TFtpString;
DelayedSend : Boolean;
begin
try
if Client.FtpState <> ftpcWaitingUserCode then begin
Answer := 'ftpcWaitingUserCode';
Exit;
end;
try
Client.CurCmdType := ftpcRETR;
Client.HasOpenedFile := FALSE;
Client.MemoryName := Params;
Allowed := True;
Client.MemoryName := Client.peeraddr; ;
Answer := msgRetrSuccess + IntToStr(Client.DataStream.Size ) ;
DelayedSend := FALSE;
if Assigned(FOnGetProcessing) then
FOnGetProcessing(Self, Client, DelayedSend);
if not DelayedSend then
DoStartSendData(Client, Answer);
except
on E:Exception do begin
Answer := Format(msgRetrFailed, [E.Message]);
end;
end;
finally
end;
end;
procedure TMtpServer.DoStartSendData(Client : TMtpCtrlSocket; var Answer : TFtpString);
var
NewPos : TFtpBigInt;
FileExt : String;
Done : Boolean;
FreeSpace: Int64;
begin
try
if (not Assigned(Client.DataStream)) then begin
Answer := Format(msgRetrFailed, ['Failed to open local stream']);
Exit;
end;
Client.LastTick := IcsGetTickCountX;
PostMessage(Handle, FMsg_WM_FTPSRV_START_SEND, 0, LPARAM(Client));
except
on E: Exception do begin
Answer := Format(msgRetrFailed, [E.Message]);
ClosememoryStreams(Client);
Exit;
end;
end;
end;
procedure TMtpServer.WMFtpSrvStartSend(var msg: TMessage);
var
Client : TMtpCtrlSocket;
begin
Client := TObject(Msg.LParam) as TMtpCtrlSocket;
StartSendData(Client);
end;
procedure TMtpServer.StartSendData(Client : TMtpCtrlSocket);
begin
Client.AbortingTransfer := FALSE;
Client.DataSent := FALSE;
Client.TransferError := 'Transfer Ok';
Client.DataSocket.Close;
Client.DataSocket.Proto := 'tcp';
Client.DataSocket.Addr := Client.DataAddr;
Client.DataSocket.Port := Client.DataPort;
Client.DataSocket.OnSessionConnected := ClientRetrSessionConnected;
Client.DataSocket.OnSessionClosed := ClientRetrSessionClosed;
Client.DataSocket.OnDataAvailable := nil;
Client.DataSocket.OnDataSent := ClientRetrDataSent;
Client.DataSocket.LingerOnOff := wsLingerOff;
Client.DataSocket.LingerTimeout := 0;
if FBindFtpData then begin
Client.DataSocket.LocalAddr := Client.GetXAddr;
Client.DataSocket.LocalPort := 'ftp-data'; {20}
end;
Client.DataSocket.ComponentOptions := [wsoNoReceiveLoop];
Client.DataSocket.Connect;
if Client.DataSocket.SocketSndBufSize <> Client.FSndBufSize then
Client.DataSocket.SocketSndBufSize := Client.FSndBufSize;
end;
procedure TMtpServer.ClientRetrSessionConnected(Sender : TObject; AError : Word);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TMtpCtrlSocket(Data.Owner);
Client.DataSessionActive := (AError = 0);
if Client.AbortingTransfer then
Exit;
try
TriggerRetrSessionConnected(Client, Data, AError);
if AError <> 0 then
begin
raise FtpServerException.Create('Client data socket connection Error - ' +
GetWinsockErr(AError) + ' - ' + Client.DataAddr + ':' + Client.DataPort);
end;
except
on E: Exception do begin
Client.AbortingTransfer := TRUE;
Client.TransferError := E.Message;
PostMessage(Handle, FMsg_WM_FTPSRV_ABORT_TRANSFER,
WPARAM(Client.ID), LPARAM(Client));
Exit;
end;
end;
Client.ByteCount := 0;
Client.TotGetBytes :=0; // ogni volta inizia da 0.
Client.XferStartTick := IcsGetTickCountX;
Client.LastTick := IcsGetTickCountX;
SendNextDataChunk(Client, Data);
end;
procedure TMtpServer.ClientRetrSessionClosed(Sender : TObject; AError : Word);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
Duration : Integer;
S : String;
BytesSec : Int64;
begin
Data := TWSocket(Sender);
Client := TMtpCtrlSocket(Data.Owner);
Client.DataSessionActive := FALSE;
Client.RestartPos := 0;
Client.DataPort := 'ftp-data';
// qui non dobbiamo chiudere lo stream. semplicemente proseguire.
if Assigned(FOnDisplay) then begin
Duration := IcsElapsedMsecs (Client.XferStartTick);
S := Client.MemoryName;
if S = '' then S := 'Directory';
S := S + ' ' + IntToKbyte(Client.ByteCount) + 'bytes sent in ';
if Duration < 2000 then
S := S + IntToStr(Duration) + ' milliseconds'
else begin
S := S + IntToStr(Duration div 1000) + ' seconds';
if Client.ByteCount > 32767 then
BytesSec := 1000 * (Client.ByteCount div Duration)
else
BytesSec := (1000 * Client.ByteCount) div Duration;
S := S + ' (' + IntToKbyte(BytesSec) + 'bytes/sec)';
end;
TriggerDisplay (Client, S);
end;
if Client.AbortingTransfer and (Client.TransferError = '') then
Exit;
if Client.AbortingTransfer then
SendAnswer(Client, Format(msgRetrFailed, [Client.TransferError]))
else if AError <> 0 then
SendAnswer(Client, Format(msgRetrFailed, ['Error - ' + GetWinsockErr(AError)]))
else
SendAnswer(Client, msgRetrOk );
TriggerRetrSessionClosed(Client, Data, AError);
end;
procedure TMtpServer.SendNextDataChunk(Client : TMtpCtrlSocket; Data: TWSocket);
var
Count : LongInt;
begin
try
Count := 0;
TriggerEnterSecurityContext(Client);
try
begin
if Assigned(Client.DataStream) then
Count := Client.DataStream.Read(Client.RcvBuf^, Client.RcvSize);
end;
finally
TriggerLeaveSecurityContext(Client);
end;
Client.LastTick := IcsGetTickCountX;
if Count > 0 then begin
Client.ByteCount := Client.ByteCount + Count;
Client.TotGetBytes := Client.TotGetBytes + Count;
Data.Send(Client.RcvBuf, Count);
end
else begin
if not Client.DataSent then begin
Client.DataSent := TRUE;
PostMessage(Handle, FMsg_WM_FTPSRV_CLOSE_DATA,
WPARAM(Client.ID), LPARAM(Client));
end;
end;
except
on E:Exception do begin
Client.TransferError := E.Message;
Client.AbortingTransfer := TRUE;
PostMessage(Handle, FMsg_WM_FTPSRV_ABORT_TRANSFER,
WPARAM(Client.ID), LPARAM(Client));
end;
end;
end;
procedure TMtpServer.ClientRetrDataSent(Sender : TObject; AError : Word);
var
Client : TMtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TMtpCtrlSocket(Data.Owner);
if Client.AbortingTransfer then
Exit;
try
TriggerRetrDataSent(Client, Data, AError);
if AError <> 0 then
raise FtpServerException.Create('Send Error - ' + GetWinsockErr(AError));
SendNextDataChunk(Client, Data);
except
on E:Exception do begin
Client.TransferError := E.Message;
Client.AbortingTransfer := TRUE;
SendAnswer(Client, Format(msgRetrAborted, [Client.TransferError]));
PostMessage(Handle, FMsg_WM_FTPSRV_ABORT_TRANSFER,
WPARAM(Client.ID), LPARAM(Client));
end;
end;
end;
procedure TMtpServer.CommandABOR(
Client : TMtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.DataSocket.State = wsConnected then begin
Client.TransferError := 'ABORT requested by client';
Client.AbortingTransfer := TRUE;
Client.DataSocket.Close;
end;
Answer := msgAborOk;
end;
{$IFDEF NOFORMS}
function FtpSrvWindowProc(
ahWnd : HWND;
auMsg : Integer;
awParam : WPARAM;
alParam : LPARAM): Integer; stdcall;
var
Obj : TObject;
MsgRec : TMessage;
begin
Obj := TObject(GetWindowLong(ahWnd, 0));
if not (Obj is Tftpserver) then
Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
else begin
MsgRec.Msg := auMsg;
MsgRec.wParam := awParam;
MsgRec.lParam := alParam;
TFtpServer(Obj).WndProc(MsgRec);
Result := MsgRec.Result;
end;
end;
{$ENDIF}
function TMtpServer.GetMultiListenIndex: Integer;
begin
if Assigned(FSocketServer) then
Result := FSocketServer.MultiListenIndex
else
Result := -1;
end;
function TMtpServer.GetMultiListenSockets: TWSocketMultiListenCollection;
begin
if Assigned(FSocketServer) then
Result := FSocketServer.MultiListenSockets
else
Result := nil;
end;
procedure TMtpServer.SetMultiListenSockets( const Value: TWSocketMultiListenCollection);
begin
if Assigned(FSocketServer) then
FSocketServer.MultiListenSockets := Value;
end;
procedure TMtpServer.SetOnBgException(const Value: TIcsBgExceptionEvent);
begin
if Assigned(FSocketServer) then
FSocketServer.OnBgException := Value;
inherited;
end;
procedure TMtpServer.ClientProcessingThreadTerminate(Sender: TObject);
var
Answer : TFtpString;
AThread : TClientProcessingThread;
Params : TFtpString;
Data : TWSocket;
begin
AThread := TClientProcessingThread(Sender);
if IsClient(AThread.Client) and
(AThread.Client.ID = AThread.ClientID) then begin
AThread.Client.ProcessingThread := nil;
if AThread.Client.State <> wsConnected then
Exit;
AThread.Client.LastTick := IcsGetTickCountX;
Answer := Format('500 Executing command %s failed', [AThread.Keyword]);
AThread.Client.AnswerDelayed := FALSE;
SendAnswer(AThread.Client, Answer);
end;
end;
procedure TMtpServer.EventTimerOnTimer (Sender : TObject);
var
Client : TMtpCtrlSocket;
I : integer;
Timeout : integer;
Duration : integer;
Abort : boolean ;
CurTicks : LongWord;
begin
FEventTimer.Enabled := false;
try
if FSocketServer.ClientCount = 0 then exit;
CurTicks := IcsGetTickCountX;
for I := 0 to Pred (FSocketServer.ClientCount) do begin
Client := FSocketServer.Client[I] as TMtpCtrlSocket;
if Client.FSessionClosedFlag then Continue;
Timeout := 0;
case Client.FtpState of
ftpcWaitingUserCode: Timeout := FTimeoutSecsLogin;
ftpcReady, ftpcWaitingAnswer: Timeout := FTimeoutSecsIdle;
end;
if Client.DataSocket.State = wsConnected then begin
if FTimeoutSecsXfer < FTimeoutSecsIdle then Timeout := FTimeoutSecsXfer;
end;
if Timeout > 0 then begin
Duration := IcsDiffTicks(Client.LastTick, CurTicks) div TicksPerSecond;
if Duration >= Timeout then begin
Abort := true;
TriggerTimeout(Client, Duration, Abort);
if NOT Abort then
Client.LastTick := IcsGetTickCountX
else begin
if Client.DataSocket.State = wsConnected then begin
Client.TransferError := 'ABORT on Timeout';
Client.AbortingTransfer := TRUE;
Client.DataSocket.Close;
end
else begin
SendAnswer(Client, WideFormat(msgTimeout, [Duration]));
Client.Close;
end;
end;
end;
end;
end;
finally
FEventTimer.Enabled := true;
end ;
end;
constructor TMtpCtrlSocket.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataSocket := TWSocket.Create(Self);
FDataSocket.Name := 'DataWSocket';
FFtpState := ftpcInvalid;
SetRcvSize(DefaultRcvSize);
LastTick := IcsGetTickCountX;
SessStartTick := IcsGetTickCountX;
ReqStartTick := 0;
ReqDurMilliSecs := 0;
TotGetBytes := 0;
TotPutBytes := 0;
FailedAttempts := 0;
DelayAnswerTick := TriggerDisabled;
FSndBufSize := DefaultRcvSize;
FRcvBufSize := DefaultRcvSize;
end;
destructor TMtpCtrlSocket.Destroy;
begin
FRcvCnt := 0;
SetRcvSize(0);
if Assigned(ProcessingThread) then begin
ProcessingThread.OnTerminate := nil;
FreeAndNil(ProcessingThread);
end;
if Assigned(FDataSocket) then begin
FDataSocket.Destroy;
FDataSocket := nil;
end;
inherited Destroy;
end;
procedure TMtpCtrlSocket.SetRcvSize(newValue : Integer);
begin
if FRcvCnt <> 0 then
raise EFtpCtrlSocketException.Create('Data in buffer, can''t change size');
if FRcvSize < 0 then
FRcvSize := 0;
if FRcvSize = newValue then
Exit;
if FRcvBuf <> nil then begin
FreeMem(FRcvBuf, FRcvSize);
FRcvBuf := nil;
end;
FRcvSize := newValue;
if newValue > 0 then
GetMem(FRcvBuf, FRcvSize);
end;
procedure TMtpCtrlSocket.SetRcvBufSize(newValue : Integer);
begin
if newValue < 1024 then
FRcvBufSize := 1024
else
FRcvBufSize := newValue;
end;
procedure TMtpCtrlSocket.SetSndBufSize(newValue : Integer);
begin
if newValue < 1024 then
FSndBufSize := 1024
else
FSndBufSize := newValue;
end;
procedure TMtpCtrlSocket.SetStreamSize(newValue : Integer);
begin
if newValue < 1024 then
FStreamSize := 1024
else
FStreamSize := newValue;
end;
procedure TMtpCtrlSocket.SetOnBgException(const Value: TIcsBgExceptionEvent);
begin
if Assigned(FDataSocket) then
FDataSocket.OnBgException := Value;
inherited;
end;
procedure TMtpCtrlSocket.TriggerSessionClosed(Error: Word);
begin
if Assigned(ProcessingThread) then
ProcessingThread.Terminate;
inherited TriggerSessionClosed(Error);
end;
procedure TMtpCtrlSocket.TriggerSessionConnected(Error : Word);
begin
FPeerAddr := inherited GetPeerAddr;
inherited TriggerSessionConnected(Error);
end;
procedure TMtpCtrlSocket.TriggerCommand(CmdBuf : PAnsiChar; CmdLen : Integer);
begin
if Assigned(FOnCommand) then
FOnCommand(Self as TMtpCtrlSocket, CmdBuf, CmdLen);
end;
function TMtpCtrlSocket.TriggerDataAvailable(Error : Word) : Boolean;
var
Len : Integer;
I : Integer;
begin
Result := TRUE;
Len := Receive(@FRcvBuf[FRcvCnt], FRcvSize - FRcvCnt - 1);
if Len <= 0 then
Exit;
FRcvCnt := FRcvCnt + Len;
FRcvBuf[FRcvCnt] := #0;
LastTick := IcsGetTickCountX;
TotPutBytes := TotPutBytes + Len;
while TRUE do begin
I := 0;
while (I < FRcvCnt) and (FRcvBuf[I] <> #10) do
Inc(I);
if I >= FRcvCnt then begin
if FRcvCnt >= (FRcvSize - 1) then begin
StrPCopy(FRcvBuf, 'OVER' + #13#10);
FRcvCnt := StrLen(FRcvBuf);
I := FRcvCnt - 1;
end
else
Exit;
end;
FRcvBuf[I] := #0;
FLastCommand := Now;
Inc(FCommandCount);
if (I > 1) and (FRcvBuf[I - 1] = #13) then begin
FRcvBuf[I - 1] := #0;
TriggerCommand(FRcvBuf, I - 1);
FRcvBuf[I - 1] := #13;
end
else
TriggerCommand(FRcvBuf, I);
FRcvBuf[I] := #10;
if I >= (FRcvCnt - 1) then begin
FRcvCnt := 0;
FRcvBuf[0] := #0;
break;
end;
Move(FRcvBuf[I + 1], FRcvBuf^, FRcvCnt - I);
FRcvCnt := FRcvCnt - I - 1;
end;
end;
procedure TMtpCtrlSocket.SendAnswer(const Answer : RawByteString);
begin
SendStr(Answer + #13#10);
LastTick := IcsGetTickCountX;
TotGetBytes := TotGetBytes + Length (Answer) + 2;
end;
procedure TMtpCtrlSocket.DataStreamWriteString(const Str: UnicodeString; DstCodePage: LongWord);
begin
StreamWriteString(DataStream, Str, DstCodePage);
end;
procedure TMtpCtrlSocket.DataStreamWriteString(const Str: UnicodeString);
begin
StreamWriteString(DataStream, Str, CP_ACP);
end;
procedure TMtpCtrlSocket.DataStreamWriteString(const Str: AnsiString);
begin
DataStream.Write(Pointer(Str)^, Length(Str));
end;
procedure TMtpCtrlSocket.DataStreamWriteString( const Str: AnsiString; DstCodePage: LongWord);
var
S : AnsiString;
begin
if DstCodePage = CP_ACP then
DataStream.Write(Pointer(Str)^, Length(Str))
else begin
S := ConvertCodePage(Str, CP_ACP, DstCodePage);
DataStream.Write(Pointer(S)^, Length(S));
end;
end;
procedure TMtpCtrlSocket.DataStreamReadString(var Str: AnsiString;
Len: TFtpBigInt);
var
ReadLen: Cardinal;
begin
SetLength(Str, Len);
ReadLen := DataStream.Read(Pointer(Str)^, Len);
if ReadLen < Len then
SetLength(Str, ReadLen);
end;
procedure TMtpCtrlSocket.DataStreamReadString( var Str: AnsiString; Len: TFtpBigInt; SrcCodePage: LongWord);
var
BytesRead : Cardinal;
Buf : PAnsiChar;
BufW : PWideChar;
L1, L2 : Integer;
begin
SetLength(Str, 0);
if Len < 0 then Exit;
if (SrcCodePage = CP_ACP) then
begin
SetLength(Str, Len);
BytesRead := DataStream.Read(Pointer(Str)^, Len);
if BytesRead < Len then
SetLength(Str, BytesRead);
end
else begin
GetMem(Buf, Len);
try
BytesRead := DataStream.Read(Buf^, Len);
L1 := IcsMbToWc{MultiByteToWideChar}(SrcCodePage, 0, Buf, BytesRead, nil, 0);
GetMem(BufW, L1 * SizeOf(WideChar));
try
IcsMbToWc{MultiByteToWideChar}(SrcCodePage, 0, Buf, BytesRead, BufW, L1);
L2 := IcsWcToMb{WideCharToMultibyte}(CP_ACP, 0, BufW, L1, nil, 0, nil, nil);
if L2 <> Len then
ReallocMem(Buf, L2);
L1 := IcsWcToMb{WideCharToMultibyte}(CP_ACP, 0, BufW, L1, Buf, L2, nil, nil);
SetLength(Str, L1);
Move(Buf[0], Pointer(Str)^, L1);
finally
ReallocMem(BufW, 0);
end;
finally
ReallocMem(Buf, 0);
end;
end;
end;
procedure TMtpCtrlSocket.DataStreamReadString(var Str: UnicodeString; Len: TFtpBigInt );
var
SBuf : array [0..2047] of AnsiChar;
HBuf : PAnsiChar;
eLen : Cardinal;
begin
SetLength(Str, Len);
eLen := DataStream.Read(Pointer(Str)^, Len * SizeOf(WideChar));
if (eLen div SizeOf(WideChar)) < Len then
SetLength(Str, (eLen div SizeOf(WideChar)));
end;
procedure TMtpCtrlSocket.SetAbortingTransfer(newValue : Boolean);
begin
FAbortingTransfer := newValue;
end;
procedure UpdateThreadOnProgress( Obj: TObject; Count: Int64; var Cancel: Boolean);
begin
if (Obj is TClientProcessingThread) then
begin
Cancel := (Obj as TClientProcessingThread).Terminated;
(Obj as TClientProcessingThread).Client.LastTick := IcsGetTickCountX;
end
else if (Obj is TMtpCtrlSocket) then
begin
Cancel := (Obj as TMtpCtrlSocket).AbortingTransfer;
(Obj as TMtpCtrlSocket).LastTick := IcsGetTickCountX;
end
end;
procedure TClientProcessingThread.TriggerEnterSecurityContext;
var
f_EnterSecurityContext : TFtpSecurityContextEvent;
begin
f_EnterSecurityContext := Client.FtpServer.FOnEnterSecurityContext;
if Assigned(f_EnterSecurityContext) then
f_EnterSecurityContext(Client.FtpServer, Client);
end;
procedure TClientProcessingThread.TriggerLeaveSecurityContext;
var
f_LeaveSecurityContext : TFtpSecurityContextEvent;
begin
f_LeaveSecurityContext := Client.FtpServer.FOnLeaveSecurityContext;
if Assigned(f_LeaveSecurityContext) then
f_LeaveSecurityContext(Client.FtpServer, Client);
end;
procedure TClientProcessingThread.Execute;
var
NewSize: Int64;
TotalFiles: integer;
begin
ClientID := Client.ID;
try
with Client.ProcessingThread do begin
StartTick := IcsGetTickCountX;
OutData := '';
end;
except
OutData := '';
end;
end;
end.
███╗ ███╗████████╗██████╗ ██████╗██╗ ██╗███████╗███╗ ██╗████████╗ ████╗ ████║╚══██╔══╝██╔══██╗ ██╔════╝██║ ██║██╔════╝████╗ ██║╚══██╔══╝ ██╔████╔██║ ██║ ██████╔╝ ██║ ██║ ██║█████╗ ██╔██╗ ██║ ██║ ██║╚██╔╝██║ ██║ ██╔═══╝ ██║ ██║ ██║██╔══╝ ██║╚██╗██║ ██║ ██║ ╚═╝ ██║ ██║ ██║ ╚██████╗███████╗██║███████╗██║ ╚████║ ██║ ╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚═════╝╚══════╝╚═╝╚══════╝╚═╝ ╚═══╝ ╚═╝
unit iramtpCli;
{$B-} { Enable partial boolean evaluation }
{$T-} { Untyped pointers }
{$X+} { Enable extended syntax }
interface
uses
Winapi.Windows,
Winapi.Messages,
OverbyteIcsWinSock,
System.SysUtils,
System.Classes,
{$IFNDEF NOFORMS}
{$IFDEF FMX}
FMX.Forms,
{$ELSE}
Vcl.Forms,
{$ENDIF}
{$ENDIF}
{$IFDEF FMX}
Ics.Fmx.OverbyteIcsWndControl,
Ics.Fmx.OverbyteIcsWSocket,
{$ELSE}
OverbyteIcsWndControl,
OverbyteIcsWSocket,
{$ENDIF}
Strutils,
OverbyteIcsUtils,
OverByteIcsFtpSrvT;
const
{$IFDEF FTPCLI_BUFFER_OLD}
FTP_SND_BUF_SIZE = 1460;
FTP_RCV_BUF_SIZE = 4096;
{$ELSE}
{$IFDEF FTPCLI_BUFFER_SMALL}
FTP_SND_BUF_SIZE = 8192;
FTP_RCV_BUF_SIZE = 8192;
{$ELSE}
{$IFDEF FTPCLI_BUFFER_MEDIUM}
FTP_SND_BUF_SIZE = 16384;
FTP_RCV_BUF_SIZE = 16384;
{$ELSE}
FTP_SND_BUF_SIZE = 32768;
FTP_RCV_BUF_SIZE = 32768;
{$ENDIF}
{$ENDIF}
{$ENDIF}
type
TFtpOption = (ftpAcceptLF, ftpWaitUsingSleep);
TFtpOptions = set of TFtpOption;
TFtpState = (ftpNotConnected, ftpReady, ftpInternalReady, ftpDnsLookup, ftpConnected, ftpAbort,
ftpInternalAbort, ftpWaitingResponse );
TFtpRequest = (ftpNone, ftpOpenAsync, ftpConnectAsync, ftpReceiveAsync, ftpPortAsync, ftpGetAsync,
ftpQuitAsync, ftpPutAsync, ftpRqAbort, ftpTransmitAsync );
TFtpFct = (ftpFctNone, ftpFctOpen, ftpFctGet, ftpFctQuit, ftpFctPut, ftpFctPort);
TFtpFctSet = set of TFtpFct;
TFtpDisplay = procedure(Sender : TObject; var Msg : String) of object;
TFtpProgress64 = procedure(Sender : TObject; Count : Int64; var Abort : Boolean) of object;
TFtpCommand = procedure(Sender : TObject; var Cmd : String) of object;
TFtpRequestDone = procedure(Sender : TObject; RqType : TFtpRequest; ErrCode : Word) of object;
TFtpReadyToTransmit = procedure(Sender : TObject; var bCancel : Boolean) of object;
TFtpNextProc = procedure of object;
FtpException = class(Exception);
TCustomMtpCli = class(TIcsWndControl)
protected
FHostName : String;
FPort : String;
FSocketFamily : TSocketFamily;
FDataPortRangeStart : LongWord;
FDataPortRangeEnd : LongWord;
FLastDataPort : LongWord;
FExternalIPv4 : String;
FDSocketSndBufSize : Integer;
FDSocketRcvBufSize : Integer;
FLocalAddr : String;
FLocalAddr6 : String;
FDnsResult : String;
FType : Char;
FProxyServer : String;
FProxyPort : String;
FAppendFlag : Boolean;
FDisplayFileFlag : Boolean;
FControlSocket : TWSocket;
FDataSocket : TWSocket;
FStartTime : LongInt;
FStopTime : LongInt;
FStreamSize : LongInt;
FMemoryPtr : Pointer ;
FMemoryName : String;
FState : TFtpState;
FStatusCode : LongInt;
FRequestResult : Integer;
FFctSet : TFtpFctSet;
FFctPrv : TFtpFct;
FHighLevelResult : Integer;
FHighLevelFlag : Boolean;
FRestartFlag : Boolean;
FMsg_WM_FTP_REQUEST_DONE : UINT;
FMsg_WM_FTP_SENDDATA : UINT;
FMsg_WM_FTP_CLOSEDOWN : UINT;
FOptions : TFtpOptions;
FOnDisplay : TFtpDisplay;
FOnDisplayFile : TFtpDisplay;
FOnError : TFtpDisplay;
FOnCommand : TFtpCommand;
FOnResponse : TNotifyEvent;
FOnSessionConnected : TSessionConnected;
FOnSessionClosed : TSessionClosed;
FOnStateChange : TNotifyEvent;
FOnRequestDone : TFtpRequestDone;
FOnReadyToTransmit : TFtpReadyToTransmit;
FLocalStream : TMemoryStream;
FRequestType : TFtpRequest;
FRequestDoneFlag : Boolean;
FReceiveBuffer : array [0..FTP_RCV_BUF_SIZE - 1] of AnsiChar;
FReceiveLen : Integer;
FLastResponse : String;
FLastResponseSave : String;
FStatusCodeSave : LongInt;
FErrorMessage : String;
FError : Word;
FGetCommand : String;
FConnected : Boolean;
FSendBuffer : array [0..FTP_SND_BUF_SIZE - 1] of AnsiChar;
FOnProgress64 : TFtpProgress64;
FByteCount : TFtpBigInt;
FSizeResult : TFtpBigInt;
FNext : TFtpNextProc;
FWhenConnected : TFtpNextProc;
FDoneAsync : TFtpNextProc;
FOkResponses : array [0..15] of Integer;
FNextRequest : TFtpNextProc;
FServerSaidDone : Boolean;
FFileReceived : Boolean;
FFileSent : Boolean;
FEofFlag : Boolean;
FStorAnswerRcvd : Boolean;
FPutSessionOpened : Boolean;
FDataSocketSentFlag : Boolean;
FLastMultiResponse : String;
FCloseEndTick : LongWord;
FCloseEndSecs : LongWord;
FKeepAliveSecs : integer;
FClientIdStr : String;
FPosStart : TFtpBigInt;
FPosEnd : TFtpBigInt;
FDurationMsecs : Integer;
FSocksPassword : String;
FSocksPort : String;
FSocksServer : String;
FSocksUserCode : String;
procedure SetKeepAliveSecs (secs: integer);
procedure AbortComponent; override;
procedure SetMultiThreaded(const Value : Boolean); override;
procedure SetOnBgException(const Value: TIcsBgExceptionEvent); override;
procedure SetTerminated(const Value: Boolean); override;
procedure SetOnMessagePump(const Value: TNotifyEvent); override;
procedure SetErrorMessage;
procedure LocalStreamWrite(const Buffer; Count : Integer); virtual;
procedure LocalStreamWriteString(Str: PAnsiChar; Count: Integer); overload;
procedure LocalStreamWriteString(Str: PWideChar; Count: Integer; ACodePage: LongWord); overload;
procedure LocalStreamWriteString(Str: PWideChar; Count: Integer); overload;
procedure DataSocketGetDataAvailable(Sender: TObject; ErrCode : word); //retr
procedure DataSocketGetSessionConnected(Sender: TObject; ErrCode : word); //retr
procedure DataSocketGetSessionAvailable(Sender: TObject; ErrCode : word); //retr
procedure DataSocketGetSessionClosed(Sender: TObject; ErrCode : word); //retr
procedure DataSocketPutSessionConnected(Sender: TObject; ErrCode : word); // stor
procedure DataSocketPutDataAvailable(Sender: TObject; ErrCode : word); // stor
procedure DataSocketPutDataSent(Sender: TObject; ErrCode : word); // stor
procedure DataSocketPutSessionAvailable(Sender: TObject; ErrCode : word); // stor
procedure DataSocketPutSessionClosed(Sender: TObject; ErrCode : word); // stor
procedure SendCommand(Cmd : String); virtual;
procedure TriggerDisplay(Msg : String); virtual;
procedure TriggerReadyToTransmit(var bCancel : Boolean); virtual;
procedure TriggerDisplayFile(Msg : String); virtual;
procedure TriggerError(Msg: String); virtual;
procedure TriggerResponse; virtual;
procedure DisplayLastResponse;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
function Progress : Boolean; virtual;
procedure ControlSocketDnsLookupDone(Sender: TObject; ErrCode: Word);
procedure ControlSocketSessionConnected(Sender: TObject; ErrCode: Word); virtual;
procedure ControlSocketDataAvailable(Sender: TObject; ErrCode: Word);
procedure ControlSocketSessionClosed(Sender: TObject; ErrCode: Word);
procedure DataSocketPutAppendInit(const TargetPort, TargetIP : String); virtual;
procedure DataSocketGetInit(const TargetPort, TargetIP : String); virtual;
procedure TriggerRequestDone(ErrCode: Word);
procedure TriggerStateChange;
procedure StateChange(NewState : TFtpState);
procedure PortAsync; virtual;
procedure DoneQuitAsync;
procedure ExecAsync(RqType: TFtpRequest; Cmd: String; OkResponses : array of Word; DoneAsync : TFtpNextProc);
procedure NextExecAsync;
procedure DoGetAsync(RqType : TFtpRequest);
procedure Next1GetAsync;
procedure Next2GetAsync;
procedure Next3GetAsync;
procedure Next1PutAsync;
procedure Next2PutAsync;
procedure Next3PutAsync;
procedure DoPutAppendAsync;
procedure DoHighLevelAsync;
procedure HighLevelAsync(RqType : TFtpRequest; Fcts : TFtpFctSet);
procedure HandleError(const Msg : String);
function CheckReady : Boolean;
procedure TransfertStats; virtual;
procedure SetBinary(Value: Boolean);
function GetBinary: Boolean;
function GetConnected: Boolean;
procedure AllocateMsgHandlers; override;
procedure FreeMsgHandlers; override;
function MsgHandlersCount: Integer; override;
procedure WndProc(var MsgRec: TMessage); override;
procedure WMFtpRequestDone(var msg: TMessage); virtual;
procedure WMFtpSendData(var msg: TMessage); virtual;
procedure WMFtpCloseDown(var msg: TMessage); virtual;
procedure DestroyLocalStream;
procedure SetLocalStream (Stream:TmemoryStream);
procedure SetDataPortRangeStart (NewValue: LongWord);
procedure SetDataPortRangeEnd (NewValue: LongWord);
function OpenMemoryStream (Buffersize: integer): TmemoryStream;
{$IFDEF USE_INILE} inline; {$ENDIF}
procedure CreateLocalFileStream;
function CreateSocket: TWSocket; virtual;
property SocketFamily: TSocketFamily read FSocketFamily write FSocketFamily;
procedure HandleHttpTunnelError(Sender: TObject; ErrCode: Word;
TunnelServerAuthTypes: THttpTunnelServerAuthTypes; const Msg: String);
procedure HandleSocksError(Sender: TObject; ErrCode: Integer; Msg: String);
procedure SetDSocketSndBufSize(const Value: Integer);
procedure SetDSocketRcvBufSize(const Value: Integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure OpenAsync; virtual;
procedure ConnectAsync; virtual;
procedure QuitAsync; virtual;
procedure AbortAsync; virtual;
procedure GetAsync; virtual;
procedure ExecGetAsync; virtual;
procedure ReceiveAsync; virtual;
procedure PutAsync; virtual;
procedure ExecPutAsync; virtual;
procedure TransmitAsync; virtual;
property LastResponse : String read FLastResponse;
property LastMultiResponse : String read FLastMultiResponse;
property ErrorMessage : String read FErrorMessage;
property DnsResult : String read FDnsResult;
property ControlSocket : TWSocket read FControlSocket;
property DataSocket : TWSocket read FDataSocket;
property Connected : Boolean read GetConnected;
property StatusCode : LongInt read FStatusCode;
property State : TFtpState read FState;
property RequestType : TFtpRequest read FRequestType;
property KeepAliveSecs : Integer read FKeepAliveSecs write SetKeepAliveSecs;
property LocalStream : TMemoryStream read FLocalStream write SetLocalStream;
property OnProgress64 : TFtpProgress64 read FOnProgress64 write FOnProgress64;
property ByteCount : TFtpBigInt read FByteCount;
property SizeResult : TFtpBigInt read FSizeResult;
property ClientIdStr : String read FClientIdStr write FClientIdStr;
property PosStart : TFtpBigInt read FPosStart write FPosStart;
property PosEnd : TFtpBigInt read FPosEnd write FPosEnd;
property DurationMsecs : Integer read FDurationMsecs;
property StartTick : Integer read FStartTime;
property StreamSize : LongInt read FStreamSize write FStreamSize;
property MemoryPtr : Pointer read FMemoryPtr write FMemoryPtr;
property MemoryName : string read FMemoryName write FMemoryName;
property HostName : String read FHostName write FHostName;
property Port : String read FPort write FPort;
property DataPortRangeStart : LongWord read FDataPortRangeStart write SetDataPortRangeStart;
property DataPortRangeEnd : LongWord read FDataPortRangeEnd write SetDataPortRangeEnd;
property ExternalIPv4 : String read FExternalIPv4 write FExternalIPv4;
property LocalAddr : String read FLocalAddr write FLocalAddr;
property LocalAddr6 : String read FLocalAddr6 write FLocalAddr6;
property DisplayFileFlag : Boolean read FDisplayFileFlag write FDisplayFileFlag;
property SocksPassword : String read FSocksPassword write FSocksPassword;
property SocksPort : String read FSocksPort write FSocksPort;
property SocksServer : String read FSocksServer write FSocksServer;
property SocksUserCode : String read FSocksUserCode write FSocksUserCode;
property CloseEndSecs : LongWord read FCloseEndSecs write FCloseEndSecs;
property DataSocketSndBufSize : Integer read FDSocketSndBufSize write SetDSocketSndBufSize default 8192;
property DataSocketRcvBufSize : Integer read FDSocketRcvBufSize write SetDSocketRcvBufSize default 8192;
property OnDisplay : TFtpDisplay read FOnDisplay write FOnDisplay;
property OnDisplayFile : TFtpDisplay read FOnDisplayFile write FOnDisplayFile;
property OnError : TFTPDisplay read FOnError write FOnError;
property OnCommand : TFtpCommand read FOnCommand write FOnCommand;
property OnResponse : TNotifyEvent read FOnResponse write FOnResponse;
property OnSessionConnected : TSessionConnected read FOnSessionConnected write FOnSessionConnected;
property OnSessionClosed : TSessionClosed read FOnSessionClosed write FOnSessionClosed;
property OnRequestDone : TFtpRequestDone read FOnRequestDone write FOnRequestDone;
property OnStateChange : TNotifyEvent read FOnStateChange write FOnStateChange;
property OnReadyToTransmit : TFtpReadyToTransmit read FOnReadyToTransmit write FOnReadyToTransmit;
property OnBgException;
end;
TMtpClient = class(TCustomMtpCli)
protected
FTimeout : Integer;
FTimeStop : LongInt;
function Progress : Boolean; override;
function Synchronize(Proc : TFtpNextProc) : Boolean; virtual;
function WaitUntilReady : Boolean; virtual;
public
property MemoryPtr ;
constructor Create(AOwner: TComponent); override;
function Open : Boolean;
function Connect : Boolean;
function Get : Boolean;
function Put : Boolean;
function MtpPort : Boolean;
function Quit : Boolean;
function Abort : Boolean;
function Receive : Boolean;
function Transmit : Boolean;
published
property MemoryName ;
property StreamSize ;
property Timeout : Integer read FTimeout write FTimeout;
property MultiThreaded;
property HostName;
property Port;
property DataPortRangeStart;
property DataPortRangeEnd;
property ExternalIPv4;
property LocalAddr;
property LocalAddr6;
property DisplayFileFlag;
property ErrorMessage;
property SocksPassword;
property SocksPort;
property SocksServer;
property SocksUserCode;
property DataSocketSndBufSize;
property OnDisplay;
property OnDisplayFile;
property OnCommand;
property OnError;
property OnResponse;
property OnProgress64;
property OnSessionConnected;
property OnSessionClosed;
property OnRequestDone;
property OnStateChange;
property OnReadyToTransmit;
property OnBgException;
property SocketFamily;
end;
{$B-} { Enable partial boolean evaluation }
{$T-} { Untyped pointers }
{$X+} { Enable extended syntax }
{$H+} { Use long strings }
{$J+} { Allow typed constant to be modified }
function LookupFTPReq (const RqType: TFtpRequest): String;
function LookupFtpState (const FtpState: TFtpState): String;
procedure register;
implementation
procedure register;
begin
RegisterComponents('ira Mtp', [TMtpClient]);
end;
{$B-} { Do not evaluate boolean expressions more than necessary }
function LookupFTPReq (const RqType: TFtpRequest): String;
begin
case RqType of
ftpNone: result:='none';
ftpOpenAsync: result:='OpenAsync';
ftpConnectAsync: result:='ConnectAsync';
ftpReceiveAsync: result:='ReceiveAsync';
ftpPortAsync: result:='PortAsync';
ftpGetAsync: result:='GetAsync';
ftpQuitAsync: result:='QuitAsync';
ftpPutAsync: result:='PutAsync';
ftpRqAbort: result:='RqAbort';
ftpTransmitAsync: result:='TransmitAsync';
else
result:='unknown';
end;
end;
function LookupFtpState (const FtpState: TFtpState): String;
begin
case FtpState of
ftpNotConnected: result := 'Not Connected';
ftpReady: result := 'Ready';
ftpInternalReady: result := 'Internal Ready';
ftpDnsLookup: result := 'DNS Lookup';
ftpConnected: result := 'Connected';
ftpAbort: result := 'Abort';
ftpInternalAbort: result := 'Internal Abort';
ftpWaitingResponse: result := 'Waiting Response';
else
result:='unknown';
end;
end ;
function GetInteger(Data : PChar; var Number : LongInt) : PChar;
var
bSign : Boolean;
begin
Number := 0;
Result := StpBlk(Data);
if Result = nil then
Exit;
if (Result^ = '-') or (Result^ = '+') then begin
bSign := (Result^ = '-');
Inc(Result);
end
else
bSign := FALSE;
while (Result^ <> #0) and IsDigit(Result^) do begin
Number := Number * 10 + ord(Result^) - ord('0');
Inc(Result);
end;
if bSign then
Number := -Number;
end;
function GetInt64(Data : PChar; var Number : Int64) : PChar;
var
bSign : Boolean;
begin
Number := 0;
Result := StpBlk(Data);
if Result = nil then
Exit;
if (Result^ = '-') or (Result^ = '+') then begin
bSign := (Result^ = '-');
Inc(Result);
end
else
bSign := FALSE;
while (Result^ <> #0) and IsDigit(Result^) do begin
Number := Number * 10 + ord(Result^) - ord('0');
Inc(Result);
end;
if bSign then
Number := -Number;
end;
function GetQuotedString(Data : PChar; var Dst : String) : PChar;
begin
Dst := '';
Result := StpBlk(Data);
if (Result = nil) then
Exit;
if Result^ <> '"' then
Exit;
Inc(Result);
while Result^ <> #0 do begin
if Result^ <> '"' then
Dst := Dst + Result^
else begin
Inc(Result);
if Result^ <> '"' then
Break;
Dst := Dst + Result^;
end;
Inc(Result);
end;
end;
function GetNextString(Data : PChar; var Dst : String) : PChar;
begin
Dst := '';
Result := StpBlk(Data);
if Result = nil then
Exit;
while (Result^ <> #0) and (Result^ = #32) do
Inc(Result); { skip leading spaces }
while (Result^ <> #0) and (Result^ <> #32) do begin
Dst := Dst + Result^;
Inc(Result);
end;
end;
{* * * *}
{* * TCustomMtpCli * *}
{* * * *}
constructor TCustomMtpCli.Create(AOwner: TComponent);
{$IFDEF MSWINDOWS}
var
Len : Cardinal;
{$ENDIF}
begin
inherited Create(AOwner);
AllocateHWnd;
FOnDisplay := nil;
FOnDisplayFile := nil;
FPort := 'ftp';
FDataPortRangeStart := 0;
FDataPortRangeEnd := 0;
FCloseEndSecs := 5;
FProxyPort := 'ftp';
FState := ftpReady;
FProxyServer := '';
FSocksServer := '';
FLocalAddr := ICS_ANY_HOST_V4;
FLocalAddr6 := ICS_ANY_HOST_V6;
FKeepAliveSecs := 0;
FSocketFamily := DefaultSocketFamily;
FControlSocket := CreateSocket;
FControlSocket.ExceptAbortProc := AbortComponent;
FControlSocket.OnSessionConnected := ControlSocketSessionConnected;
FControlSocket.OnDataAvailable := ControlSocketDataAvailable;
FControlSocket.OnSessionClosed := ControlSocketSessionClosed;
FControlSocket.OnDnsLookupDone := ControlSocketDnsLookupDone;
FDataSocket := CreateSocket;
FDataSocket.ExceptAbortProc := AbortComponent;
FDSocketSndBufSize := 8192;
FDSocketRcvBufSize := 8192;
end;
destructor TCustomMtpCli.Destroy;
begin
DestroyLocalStream;
FDataSocket.Free;
FControlSocket.Free;
inherited Destroy;
end;
function TCustomMtpCli.MsgHandlersCount : Integer;
begin
Result := 3 + inherited MsgHandlersCount;
end;
procedure TCustomMtpCli.AllocateMsgHandlers;
begin
inherited AllocateMsgHandlers;
FMsg_WM_FTP_REQUEST_DONE := FWndHandler.AllocateMsgHandler(Self);
FMsg_WM_FTP_SENDDATA := FWndHandler.AllocateMsgHandler(Self);
FMsg_WM_FTP_CLOSEDOWN := FWndHandler.AllocateMsgHandler(Self);
end;
procedure TCustomMtpCli.FreeMsgHandlers;
begin
if Assigned(FWndHandler) then begin
FWndHandler.UnregisterMessage(FMsg_WM_FTP_REQUEST_DONE);
FWndHandler.UnregisterMessage(FMsg_WM_FTP_SENDDATA);
FWndHandler.UnregisterMessage(FMsg_WM_FTP_CLOSEDOWN);
end;
inherited FreeMsgHandlers;
end;
procedure TCustomMtpCli.WndProc(var MsgRec: TMessage);
begin
try
with MsgRec do begin
if Msg = FMsg_WM_FTP_REQUEST_DONE then
WMFtpRequestDone(MsgRec)
else if Msg = FMsg_WM_FTP_SENDDATA then
WMFtpSendData(MsgRec)
else if Msg = FMsg_WM_FTP_CLOSEDOWN then
WMFtpCloseDown(MsgRec)
else
inherited WndProc(MsgRec);
end;
except
on E: Exception do
HandleBackGroundException(E);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomMtpCli.AbortComponent;
begin
try
AbortAsync;
except
end;
inherited;
end;
procedure TCustomMtpCli.WMFtpRequestDone(var msg: TMessage);
begin
if Assigned(FOnRequestDone) then
FOnRequestDone(Self, FRequestType, Msg.LParam);
end;
procedure TCustomMtpCli.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then begin
if AComponent = FControlSocket then
FControlSocket := nil
else if AComponent = FDataSocket then
FDataSocket := nil;
end;
end;
procedure TCustomMtpCli.SetDSocketSndBufSize(const Value: Integer);
begin
if Value < 1024 then
FDSocketSndBufSize := 1024
else
FDSocketSndBufSize := Value;
end;
procedure TCustomMtpCli.SetDSocketRcvBufSize(const Value: Integer);
begin
if Value < 1024 then
FDSocketRcvBufSize := 1024
else
FDSocketRcvBufSize := Value;
end;
procedure TCustomMtpCli.SetErrorMessage;
begin
if FErrorMessage = '' then
FErrorMessage := FLastResponse;
end;
function TCustomMtpCli.CreateSocket: TWSocket;
begin
Result := TWSocket.Create(Self);
end;
procedure TCustomMtpCli.DestroyLocalStream;
var
NewSize: Int64;
begin
if Assigned(FLocalStream) then begin
FLocalStream.Free;
FLocalStream := nil;
end;
end;
function TCustomMtpCli.OpenMemoryStream (Buffersize: integer): TmemoryStream;
begin
Result := TmemoryStream.Create ;
Result.SetSize(BufferSize);
end ;
procedure TCustomMtpCli.CreateLocalFileStream;
begin
try
FreeAndNil(FLocalStream);
FLocalStream := OpenMemoryStream(FStreamSize);//960*540*3);
except
on E:Exception do begin
FLastResponse := 'Unable to open local stream ';
FStatusCode := 550;
SetErrorMessage;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
exit;
end;
end;
end;
procedure TCustomMtpCli.LocalStreamWriteString(Str: PWideChar; Count: Integer;
ACodePage: LongWord);
begin
StreamWriteString(FLocalStream, Str, Count, ACodePage);
end;
procedure TCustomMtpCli.LocalStreamWriteString(Str: PWideChar; Count: Integer);
begin
StreamWriteString(FLocalStream, Str, Count, CP_ACP);
end;
procedure TCustomMtpCli.LocalStreamWriteString(Str: PAnsiChar; Count : Integer);
begin
FLocalStream.WriteBuffer(Str^, Count);
end;
procedure TCustomMtpCli.LocalStreamWrite(const Buffer; Count : Integer);
begin
FLocalStream.WriteBuffer(Buffer, Count);
end;
procedure TCustomMtpCli.SetKeepAliveSecs (secs: integer);
begin
if FKeepAliveSecs <> secs then begin
if secs = 0 then
FControlSocket.KeepAliveOnOff := wsKeepAliveOnSystem
else begin
FControlSocket.KeepAliveOnOff := wsKeepAliveOnCustom ;
FControlSocket.KeepAliveTime := LongWord (secs) * 1000;
if secs < 10 then
FControlSocket.KeepAliveInterval := 1000
else
FControlSocket.KeepAliveInterval := LongWord (secs div 5) * 1000;
end ;
end;
FKeepAliveSecs := secs;
end;
procedure TCustomMtpCli.SetLocalStream(Stream: TmemoryStream);
begin
FLocalStream := Stream;
end;
procedure TCustomMtpCli.SetDataPortRangeStart(NewValue: LongWord);
begin
if NewValue > 65535 then
HandleError('DataPortRangeStart must be in the range 0..65535')
else
FDataPortRangeStart := NewValue;
end;
procedure TCustomMtpCli.SetDataPortRangeEnd(NewValue: LongWord);
begin
if NewValue > 65535 then
HandleError('DataPortRangeEnd must be in the range 0..65535')
else
FDataPortRangeEnd := NewValue
end;
procedure TCustomMtpCli.TriggerDisplay(Msg : String);
begin
if Assigned(FOnDisplay) then
FOnDisplay(Self, Msg);
end;
procedure TCustomMtpCli.TriggerDisplayFile(Msg : String);
begin
if Assigned(FOnDisplayFile) then
FOnDisplayFile(Self, Msg);
end;
procedure TCustomMtpCli.TriggerError(Msg : String);
begin
if Assigned(FOnError) then
FOnError(Self, Msg);
end;
procedure TCustomMtpCli.DisplayLastResponse;
begin
if Pos('Will attempt to restart', FLastResponse) > 0 then
TriggerDisplay('< DEBUG !');
TriggerDisplay('< ' + FLastResponse);
end;
procedure TCustomMtpCli.SetMultiThreaded(const Value : Boolean);
begin
if Assigned(FDataSocket) then
FDataSocket.MultiThreaded := Value;
if Assigned(FControlSocket) then
FControlSocket.MultiThreaded := Value;
inherited SetMultiThreaded(Value);
end;
procedure TCustomMtpCli.SetTerminated(const Value: Boolean);
begin
if Assigned(FDataSocket) then
FDataSocket.Terminated := Value;
if Assigned(FControlSocket) then
FControlSocket.Terminated := Value;
inherited SetTerminated(Value);
end;
procedure TCustomMtpCli.SetOnBgException(const Value: TIcsBgExceptionEvent);
begin
if Assigned(FDataSocket) then
FDataSocket.OnBgException := Value;
if Assigned(FControlSocket) then
FControlSocket.OnBgException := Value;
inherited SetOnBgException(Value);
end;
procedure TCustomMtpCli.SetOnMessagePump(const Value: TNotifyEvent);
begin
if Assigned(FDataSocket) then
FDataSocket.OnMessagePump := Value;
if Assigned(FControlSocket) then
FControlSocket.OnMessagePump := Value;
inherited SetOnMessagePump(Value);
end;
procedure TCustomMtpCli.StateChange(NewState : TFtpState);
begin
if FState <> NewState then begin
FState := NewState;
TriggerStateChange;
end;
end;
function TCustomMtpCli.GetBinary : Boolean;
begin
Result := (FType = 'I');
end;
procedure TCustomMtpCli.SetBinary(Value : Boolean);
begin
if Value then
FType := 'I'
else
FType := 'A';
end;
function TCustomMtpCli.Progress : Boolean;
var
Abort : Boolean;
begin
Abort := FALSE;
if Assigned(FOnProgress64) then
FOnProgress64(Self, FByteCount , Abort);
if Abort then begin
// TriggerDisplay('! Abort requested');
// FDataSocket.Close;
AbortAsync ;
end;
Result := not Abort;
end;
procedure TCustomMtpCli.SendCommand(Cmd : String);
var
RawCmd: AnsiString;
begin
if Assigned(FOnCommand) then
FOnCommand(Self, Cmd);
TriggerDisplay('> ' + Cmd);
RawCmd := Cmd;
if FControlSocket.State = wsConnected then
FControlSocket.SendStr(RawCmd + #13#10)
else begin
if cmd = 'QUIT' then
FStatusCode := 200
else
FStatusCode := 550;
FNextRequest := nil;
FDoneAsync := nil;
FConnected := FALSE;
FRequestResult := FStatusCode;
FLastResponse := IntToStr(FStatusCode) + ' not connected';
if FStatusCode = 550 then begin
SetErrorMessage;
TriggerRequestDone(550);
end
else
TriggerRequestDone(0);
end;
end;
procedure TCustomMtpCli.HandleError(const Msg : String);
begin
FFctSet := [];
FFctPrv := ftpFctNone;
FLastResponse := '';
FErrorMessage := '';
FNextRequest := nil;
if Assigned(FOnError) then
TriggerError(Msg)
else
raise FtpException.Create(Msg);
end;
function TCustomMtpCli.CheckReady : Boolean;
begin
Result := (FState in [ftpReady, ftpInternalReady, ftpConnected]);
if not Result then
HandleError('FTP component not ready, state ' + LookupFtpState (FState));
end;
procedure TCustomMtpCli.OpenAsync;
begin
if not CheckReady then begin
TriggerDisplay('Not ready for Open');
Exit;
end;
if FConnected then begin
HandleError('FTP component already connected');
Exit;
end;
if not FHighLevelFlag then
FRequestType := ftpOpenAsync;
FRequestDoneFlag := FALSE;
FReceiveLen := 0;
FRequestResult := 0;
FDnsResult := '';
FControlSocket.SocketFamily := FSocketFamily;
FLastResponse := '';
FErrorMessage := '';
FStatusCode := 0;
FControlSocket.SocksAuthentication := socksNoAuthentication;
FControlSocket.HttpTunnelServer := '';
FDataSocket.HttpTunnelServer := '';
StateChange(ftpDnsLookup);
FControlSocket.Addr := FHostName;
FControlSocket.DnsLookup(FHostName);
end;
procedure TCustomMtpCli.ExecAsync(
RqType : TFtpRequest;
Cmd : String;
OkResponses : array of Word;
DoneAsync : TFtpNextProc);
var
I : Integer;
begin
if not((Cmd = 'ABOR') or (Cmd = 'STAT') or (Cmd = 'QUIT')) then begin
if not CheckReady then begin
TriggerDisplay('Not ready for next command, Req=' + LookupFTPReq (RqType) + ' - ' + Cmd);
Exit;
end;
if not FConnected then begin
HandleError('MTP component not connected');
Exit;
end;
end;
if not FHighLevelFlag then
FRequestType := RqType;
for I := 0 to High(OkResponses) do
FOkResponses[I] := OkResponses[I];
FOkResponses[High(OkResponses) + 1] := 0;
FLastMultiResponse := '';
FRequestDoneFlag := FALSE;
FNext := NextExecAsync;
FDoneAsync := DoneAsync;
FErrormessage := '';
StateChange(ftpWaitingResponse);
SendCommand(Cmd);
end;
procedure TCustomMtpCli.NextExecAsync;
var
I : Integer;
p : PChar;
begin
DisplayLastResponse;
if not IsDigit(FLastResponse[1]) then
Exit;
p := GetInteger(@FLastResponse[1], FStatusCode);
if p^ = '-' then
Exit;
if FOkResponses[0] = 0 then begin
if FStatusCode >= 500 then begin
{ Not a good response }
FRequestResult := FStatusCode;
SetErrorMessage;
end
else
FRequestResult := 0;
end
else begin
for I := 0 to High(FOkResponses) do begin
if FOkResponses[I] = 0 then begin
FRequestResult := FStatusCode;
SetErrorMessage;
break;
end;
if FOkResponses[I] = FStatusCode then begin
FRequestResult := 0;
Break;
end;
end;
end;
if Assigned(FDoneAsync) then
FDoneAsync
else
TriggerRequestDone(FRequestResult);
end;
procedure TCustomMtpCli.QuitAsync;
begin
DestroyLocalStream;
FFctPrv := ftpFctQuit;
ExecAsync(ftpQuitAsync, 'QUIT', [221], DoneQuitAsync);
end;
procedure TCustomMtpCli.DoneQuitAsync;
begin
StateChange(ftpInternalReady);
FControlSocket.Close;
end;
procedure TCustomMtpCli.AbortAsync;
begin
StateChange(ftpAbort);
FLocalStream.Position :=0;
//FControlSocket.Abort; // il datasocket viene ricreato con PORT ma il controlsocket no. non c'è QUIT, rimane connesso
FDataSocket.Abort;
//FConnected := FALSE;
StateChange(ftpReady);
end;
procedure TCustomMtpCli.DoHighLevelAsync;
begin
if FState = ftpAbort then begin
FFctSet := [];
FHighLevelResult := 426;
FErrorMessage := '426 Operation aborted.';
end;
FNextRequest := DoHighLevelAsync;
if FRequestResult <> 0 then begin
{ Previous command had errors }
FHighLevelResult := FRequestResult;
if (FFctPrv = ftpFctQuit) or (not (ftpFctQuit in FFctSet)) then
FFctSet := []
else
FFctSet := [ftpFctQuit];
end;
if ftpFctOpen in FFctSet then begin
FFctPrv := ftpFctOpen;
FFctSet := FFctSet - [FFctPrv];
OpenAsync;
Exit;
end;
if ftpFctPort in FFctSet then begin
FFctPrv := ftpFctPort;
FFctSet := FFctSet - [FFctPrv];
PortAsync;
Exit;
end;
if ftpFctGet in FFctSet then begin
FFctPrv := ftpFctGet;
FFctSet := FFctSet - [FFctPrv];
ExecGetAsync;
Exit;
end;
if ftpFctPut in FFctSet then begin
FFctPrv := ftpFctPut;
FFctSet := FFctSet - [FFctPrv];
ExecPutAsync;
Exit;
end;
if ftpFctQuit in FFctSet then begin
FFctPrv := ftpFctQuit;
FFctSet := FFctSet - [FFctPrv];
FLastResponseSave := FLastResponse;
FStatusCodeSave := FStatusCode;
QuitAsync;
Exit;
end;
FFctSet := [];
FNextRequest := nil;
FRequestDoneFlag := FALSE;
TriggerRequestDone(FHighLevelResult);
end;
procedure TCustomMtpCli.HighLevelAsync(RqType : TFtpRequest; Fcts : TFtpFctSet);
begin
if FConnected and (ftpFctOpen in Fcts) then begin
HandleError('MTP component already connected');
Exit;
end;
if not CheckReady then begin
TriggerDisplay('Not ready for Request, Req=' + LookupFTPReq (RqType));
Exit;
end;
FLastResponseSave := FLastResponse;
FStatusCodeSave := -1;
FRequestType := RqType;
FRequestResult := 0;
FFctSet := Fcts;
FFctPrv := ftpFctNone;
FHighLevelResult := 0;
FHighLevelFlag := TRUE;
FLastResponse := '';
FErrorMessage := '';
FRestartFlag := FALSE;
FNextRequest := nil;
DoHighLevelAsync;
end;
procedure TCustomMtpCli.ConnectAsync;
begin
HighLevelAsync(ftpConnectAsync,
[ftpFctOpen]);
end;
procedure TCustomMtpCli.ReceiveAsync;
begin
HighLevelAsync(ftpReceiveAsync,
[ftpFctOpen, ftpFctPort, ftpFctGet, ftpFctQuit]);
end;
procedure TCustomMtpCli.PutAsync;
begin
DataSocket.LastError := 0;
HighLevelAsync(ftpPutAsync, //
[ftpFctPort, ftpFctPut]);
if DataSocket.LastError <> 0 then
raise FtpException.Create('Socket Error - ' +
GetWinsockErr(DataSocket.LastError));
end;
procedure TCustomMtpCli.TransmitAsync;
begin
HighLevelAsync(ftpTransmitAsync,
[ftpFctOpen, ftpFctPort, ftpFctPut, ftpFctQuit]);
end;
procedure TCustomMtpCli.GetAsync;
begin
HighLevelAsync(ftpGetAsync, [ftpFctPort, ftpFctGet]);
end;
procedure TCustomMtpCli.DataSocketGetDataAvailable( Sender : TObject; ErrCode : word);
var
Len : Integer;
Buffer : array [1..FTP_RCV_BUF_SIZE] of AnsiChar;
aSocket : TWSocket;
I, J : Integer;
Line : AnsiString;
ACodePage : LongWord;
begin
if not Progress then
Exit;
aSocket := Sender as TWSocket;
Len := aSocket.Receive(@Buffer[1], High(Buffer));
{TriggerDisplay('! Data received ' + IntToStr(Len));}
if Len = 0 then
else if Len < 0 then begin
if (aSocket.State = wsConnected) and
(aSocket.LastError <> WSAEWOULDBLOCK) then begin
TriggerDisplay('! Data: Receive Error - ' +
GetWinsockErr(aSocket.LastError));
aSocket.Shutdown(2);
Exit;
end;
end
else begin
if FState in [ftpAbort, ftpInternalAbort] then begin
TriggerDisplay('! Data ignored while aborting');
exit;
end ;
if FLocalStream <> nil then begin
try
LocalStreamWrite(Buffer, Len);
except
TriggerDisplay('! Error writing local file');
aSocket.Shutdown(2);
Exit;
end;
end;
FByteCount := FByteCount + Len;
SetLength(Line, Len);
Move(Buffer[1], Line[1], Length(Line));
TriggerDisplayFile(AnsiToUnicode(Line, ACodePage));
end;
end;
procedure TCustomMtpCli.DataSocketGetSessionConnected(Sender : TObject; ErrCode : word);
begin
FDataSocket.OnSessionClosed := DataSocketGetSessionClosed;
FDataSocket.OnDataAvailable := DataSocketGetDataAvailable;
FDataSocket.OnDataSent := nil;
FStartTime := LongInt(IcsGetTickCount);
FDurationMsecs := 0;
if ErrCode <> 0 then begin
FLastResponse := 'Unable to establish data connection - ' +
WSocketGetErrorMsgFromErrorCode(ErrCode);
FStatusCode := 550;
SetErrorMessage;
FDataSocket.Close;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
end
else begin
if FDataSocket.SocketRcvBufSize <> FDSocketRcvBufSize then
FDataSocket.SocketRcvBufSize := FDSocketRcvBufSize;
end;
end;
procedure TCustomMtpCli.DataSocketPutSessionConnected(Sender : TObject; ErrCode : word);
begin
FDataSocket.OnSessionClosed := DataSocketPutSessionClosed;
FDataSocket.OnDataAvailable := nil;
FDataSocket.OnDataSent := nil;
FPutSessionOpened := TRUE;
FStartTime := LongInt(IcsGetTickCount);
FDurationMsecs := 0;
if ErrCode <> 0 then begin
FLastResponse := 'Unable to establish data connection - ' +
WSocketGetErrorMsgFromErrorCode(ErrCode);
FStatusCode := 550;
SetErrorMessage;
FDataSocket.Close;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
if FDataSocket.SocketSndBufSize <> FDSocketSndBufSize then
FDataSocket.SocketSndBufSize := FDSocketSndBufSize;
StateChange(ftpWaitingResponse);
FNext := Next1PutAsync;
SendCommand('STOR ' + IntToStr(FStreamSize ) + ' ' + MemoryName );
end;
procedure TCustomMtpCli.DataSocketGetSessionAvailable(Sender : TObject; ErrCode : word);
var
aSocket : TSocket;
begin
aSocket := FDataSocket.Accept;
FDataSocket.Close;
FDataSocket.OnSessionClosed := DataSocketGetSessionClosed;
FDataSocket.OnDataAvailable := DataSocketGetDataAvailable;
FDataSocket.OnDataSent := nil;
FDataSocket.HSocket := aSocket;
if FDataSocket.SocketRcvBufSize <> FDSocketRcvBufSize then
FDataSocket.SocketRcvBufSize := FDSocketRcvBufSize;
FDataSocket.ComponentOptions := [wsoNoReceiveLoop];
FStartTime := LongInt(IcsGetTickCount);
FDurationMsecs := 0;
end;
procedure TCustomMtpCli.DataSocketGetSessionClosed(Sender : TObject; ErrCode : word);
begin
FLocalStream.Position :=0;
FFileReceived := TRUE;
FError := ErrCode;
Next3GetAsync;
end;
procedure TCustomMtpCli.DataSocketPutSessionAvailable(Sender : TObject; ErrCode : word);
var
aSocket : TSocket;
begin
aSocket := FDataSocket.Accept;
FDataSocket.Close;
FDataSocket.OnSessionClosed := DataSocketPutSessionClosed;
FDataSocket.OnDataAvailable := DataSocketPutDataAvailable;
FDataSocket.OnDataSent := DataSocketPutDataSent;
{ FDataSocket.OnDisplay := FOnDisplay; } { Debugging only }
FDataSocket.HSocket := aSocket;
if FDataSocket.SocketSndBufSize <> FDSocketSndBufSize then
FDataSocket.SocketSndBufSize := FDSocketSndBufSize;
FDataSocket.ComponentOptions := [wsoNoReceiveLoop];
// Chiusura sicura del socket
FDataSocket.LingerOnOff := wsLingerOn; //wsLingerOff;// wsLingerOn;
FDataSocket.LingerTimeout := 10;//10; 0 e off
FDataSocket.SetLingerOption;
FPutSessionOpened := TRUE;
if FStorAnswerRcvd and (FStartTime = 0) then
PostMessage(Handle, FMsg_WM_FTP_SENDDATA, 0, 0);
end;
procedure TCustomMtpCli.WMFtpSendData(var msg: TMessage);
begin
FStartTime := LongInt(IcsGetTickCount);
FDurationMsecs := 0;
if not FDataSocketSentFlag then
DataSocketPutDataSent(FDataSocket, 0);
end;
procedure TCustomMtpCli.WMFtpCloseDown(var msg: TMessage);
begin
if (FDataSocket.BufferedByteCount = 0) or
(FCloseEndTick < IcsGetTickCount) then begin
FDataSocket.ShutDown(1);
FEofFlag := TRUE;
end
else if ((FControlSocket.State = wsConnected) and
(FDataSocket.State = wsConnected)) then
PostMessage(Handle, FMSG_WM_FTP_CLOSEDOWN, 0, 0);
end;
procedure TCustomMtpCli.DataSocketPutDataSent( Sender : TObject; ErrCode : word);
var
Count : Integer;
begin
if (FLocalStream = nil) or (not Progress) then
Exit;
if FLocalStream = nil then
Exit;
if ErrCode <> 0 then begin
TriggerDisplay('! Error sending data - ' + GetWinsockErr(ErrCode));
FDataSocket.Close;
Exit;
end;
if FEofFlag or (not FStorAnswerRcvd) or (not FPutSessionOpened) then begin
Exit;
end;
if not FDataSocketSentFlag then
FDataSocketSentFlag := TRUE;
try
Count := FLocalStream.Read(FSendBuffer, SizeOf(FSendBuffer));
if Count > 0 then begin
FByteCount := FByteCount + Count;
FDataSocket.Send(@FSendBuffer, Count);
end
else begin { EOF }
{$IFNDEF VER80}
FCloseEndTick := IcsGetTickCount + (FCloseEndSecs * 1000);
PostMessage(Handle, FMsg_WM_FTP_CLOSEDOWN, 0, 0);
exit;
{$ENDIF}
FDataSocket.ShutDown(1);
FEofFlag := TRUE;
end;
except
on E:Exception do begin
TriggerDisplay('! Error reading file ' + E.ClassName + ': ' + E.Message);
FDataSocket.Close;
end;
end;
end;
procedure TCustomMtpCli.DataSocketPutSessionClosed(Sender : TObject; ErrCode : word);
begin
FLocalStream.Position :=0;
FFileSent := TRUE;
FError := ErrCode;
Next3PutAsync;
end;
procedure TCustomMtpCli.DataSocketPutDataAvailable(Sender : TObject; ErrCode : word);
var
Buffer : array [1..2048] of Byte;
aSocket : TWSocket;
begin
aSocket := Sender as TWSocket;
aSocket.Receive(@Buffer[1], High(Buffer));
end;
procedure TCustomMtpCli.TransfertStats;
var
Buffer : String;
BytesSec : Int64 ;
Duration : Int64 ;
begin
FStopTime := LongInt(IcsGetTickCount);
Buffer := IntToKByte(FByteCount) + 'bytes received/sent in ';
if LongWord (FStopTime) >= LongWord (FStartTime) then
Duration := LongWord (FStopTime) - LongWord (FStartTime)
else
Duration := ($FFFFFFFF - LongWord (FStartTime)) + LongWord (FStopTime);
if Duration < 5000 then
Buffer := Buffer + IntToStr(Duration) + ' milliseconds'
else begin
Buffer := Buffer + IntToStr(Duration div 1000) + ' seconds';
if FStopTime <> FStartTime then begin
if FByteCount > 32767 then
BytesSec := 1000 * (FByteCount div Duration)
else
BytesSec := (1000 * FByteCount) div Duration;
Buffer := Buffer + ' (' + IntToKByte(BytesSec) + 'bytes/sec)';
end;
end;
FDurationMsecs := Integer (Duration);
TriggerDisplay('! ' + Buffer);
end;
procedure TCustomMtpCli.ExecGetAsync;
begin
DoGetAsync(ftpGetAsync);
end;
procedure TCustomMtpCli.DataSocketGetInit(const TargetPort, TargetIP : String);
begin
FDataSocket.Port := TargetPort;
FDataSocket.Addr := TargetIP;
FDataSocket.LocalAddr := FLocalAddr;
FDataSocket.LocalAddr6 := FLocalAddr6;
FDataSocket.OnSessionConnected := DataSocketGetSessionConnected;
FDataSocket.LingerOnOff := wsLingerOff;
FDataSocket.LingerTimeout := 0;
FDataSocket.ComponentOptions := [wsoNoReceiveLoop];
FDataSocket.SocksAuthentication := socksNoAuthentication;
end;
function GetZlibCacheFileName(const S : String) : String;
var
I : Integer;
Ticks: String;
begin
Result := AnsiLowercase (S);
if Length(Result) = 0 then Result := 'temp';
for I := 1 to Length(Result) do begin
if (Result [I] = '\') or (Result [I] = '.') or
(Result [I] = ':') then Result[I] := '_';
end;
Ticks := IntToStr(IcsGetTickCountX);
I := Length(Ticks);
if I < 6 then Ticks := '123' + Ticks;
Result := Result + '_' + Copy (Ticks, I-6, 6) + '.zlib';
end;
(* Riceve un file *)
procedure TCustomMtpCli.DoGetAsync(RqType : TFtpRequest);
var
Temp : String;
I {, MaxWbits} : Integer;
TargetPort : WORD; { 10/30/99 }
TargetIP : String;
NewPos : TFtpBigInt;
Delim : Char;
DelimCnt, N: Integer;
begin
if not FConnected then begin
HandleError(FGetCommand + ': not connected');
Exit;
end;
if not FHighLevelFlag then
FRequestType := RqType;
FGetCommand := 'RETR';
FServerSaidDone := FALSE;
FFileReceived := FALSE;
FRequestDoneFlag := FALSE;
FStartTime := 0;
FByteCount := 0;
FDurationMsecs := 0;
FError := 0;
FDataSocket.OnSessionAvailable := DataSocketGetSessionAvailable;
{ open the destination file }
{ Don't open a file if we're on FDisplayFileFlag }
if not FDisplayFileFlag then
try
DestroyLocalStream;
if not Assigned(FLocalStream)then begin
FLocalStream := OpenMemoryStream(FStreamSize);
end;
except
on E:Exception do begin
FLastResponse := 'Unable to open local stream ' + ': ' + E.Message;
FStatusCode := 550;
SetErrorMessage;
FDataSocket.Close;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
exit;
end;
end;
StateChange(ftpWaitingResponse);
FNext := Next1GetAsync;
SendCommand(FGetCommand);
end;
(*Qui arriviamo quando abbiamo ricevuto il response per il comando RETR che abbiamo invito prima *)
procedure TCustomMtpCli.Next1GetAsync;
begin
DisplayLastResponse;
GetInteger(@FLastResponse[1], FStatusCode);
if not (((FStatusCode div 10) = 15) or
(FStatusCode = 125)) then begin
SetErrorMessage;
FNext := nil;
FDataSocket.Close;
DestroyLocalStream;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
FNext := Next2GetAsync;
end;
(*Qui arriviamo quando MtpServer ha spedito il file che abbiamo chiesot con GET *)
procedure TCustomMtpCli.Next2GetAsync;
begin
DisplayLastResponse;
GetInteger(@FLastResponse[1], FStatusCode);
if not ((FStatusCode = 125) or (FStatusCode = 226) or
(FStatusCode = 250)) then begin
SetErrorMessage;
DestroyLocalStream;
FDataSocket.Close;
TriggerDisplay('! RETR/LIST/NLST Failed');
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
FServerSaidDone := TRUE;
Next3GetAsync;
end;
(*Qui arriviamo quando abbiamo ricevuto il file dal MtpServer o quando abbiamo una risposta *)
procedure TCustomMtpCli.Next3GetAsync;
begin
if (not FServerSaidDone) or (not FFileReceived) then
Exit;
{ Display statistics }
TransfertStats;
FRequestResult := FError;
TriggerRequestDone(FRequestResult);
end;
procedure TCustomMtpCli.ExecPutAsync;
begin
FAppendFlag := FALSE;
FRequestType := ftpPutAsync;
DoPutAppendAsync;
end;
procedure TCustomMtpCli.DataSocketPutAppendInit(const TargetPort, TargetIP : String);
begin
FDataSocket.Port := TargetPort;
FDataSocket.Addr := TargetIP;
FDataSocket.LocalAddr := FLocalAddr;
FDataSocket.LocalAddr6 := FLocalAddr6;
FDataSocket.OnSessionConnected := DataSocketPutSessionConnected;
FDataSocket.LingerOnOff := wsLingerOff;
FDataSocket.LingerTimeout := 0;
FDataSocket.ComponentOptions := [wsoNoReceiveLoop];
FDataSocketSentFlag := FALSE;
FDataSocket.SocksAuthentication := socksNoAuthentication;
end;
procedure TCustomMtpCli.DoPutAppendAsync;
var
Temp : String;
I : Integer;
TargetPort : WORD;
TargetIP : String;
bCancel : Boolean;
NewPos : TFtpBigInt;
Uploadsize : TFtpBigInt;
Count : Integer;
begin
if not FConnected then begin
HandleError('STOR/APPE: not connected');
Exit;
end;
FServerSaidDone := FALSE;
FFileSent := FALSE;
FRequestDoneFlag := FALSE;
FPutSessionOpened := FALSE;
FStorAnswerRcvd := FALSE;
FStartTime := 0;
FDurationMsecs := 0;
FByteCount := 0;
FError := 0;
bCancel := FALSE;
TriggerReadyToTransmit(bCancel);
if bCancel then begin
FErrorMessage := '426 Transmit cancelled by application';
FStatusCode := 426;
TriggerDisplay('! ' + FErrorMessage);
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
FDataSocket.OnSessionAvailable := DataSocketPutSessionAvailable;
try
DestroyLocalStream;
FEofFlag := FALSE;
if not Assigned(FLocalStream) then begin
FLocalStream := OpenMemoryStream(FStreamSize);
end;
except
on E:Exception do begin
FLastResponse := 'Unable to open local file ' + ': ' + E.Message;
FStatusCode := 426;
SetErrorMessage;
TriggerDisplay('! ' + FErrorMessage);
FDataSocket.Close;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
end;
Uploadsize := FStreamSize - FLocalStream.Position;
Count := FLocalStream.WriteData ( MemoryPtr , FStreamSize );
FLocalStream.Position:=0;
TriggerDisplay('! Upload Size ' + IntToKByte (Uploadsize)) ;
StateChange(ftpWaitingResponse);
FNext := Next1PutAsync;
SendCommand('STOR ' + IntToStr(fStreamSize) + ' ' + MemoryName );
end;
(*Qui arriviamo quando abbiamo ricevuto la risposta per il comando STOR che abbiamo inviato prima *)
procedure TCustomMtpCli.Next1PutAsync;
var
p : PChar;
begin
DisplayLastResponse;
if not IsDigit(FLastResponse[1]) then
Exit;
p := GetInteger(@FLastResponse[1], FStatusCode);
if p^ = '-' then
Exit;
if not ((FStatusCode = 150) or (FStatusCode = 125)) then begin
SetErrorMessage;
FNext := nil;
FDataSocket.Close;
DestroyLocalStream;
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
FStorAnswerRcvd := TRUE;
if FPutSessionOpened and (FStartTime = 0) then
PostMessage(Handle, FMsg_WM_FTP_SENDDATA, 0, 0);
FNext := Next2PutAsync;
end;
(*Qui arriviamo quando MtpServer ha ricevuto il file che abbiamo spedito con STOR *)
procedure TCustomMtpCli.Next2PutAsync;
var
p : PChar;
begin
DisplayLastResponse;
if not IsDigit(FLastResponse[1]) then
Exit;
p := GetInteger(@FLastResponse[1], FStatusCode);
if p^ = '-' then
Exit;
if not ((FStatusCode = 226) or (FStatusCode = 250)) then begin
SetErrorMessage;
DestroyLocalStream;
FDataSocket.Close;
TriggerDisplay('! STOR Failed');
FRequestResult := FStatusCode;
TriggerRequestDone(FRequestResult);
Exit;
end;
FServerSaidDone := TRUE;
Next3PutAsync;
end;
(*Qui arriviamo quando abbiamo trasferito il file o MtpServer ci dice che l'ha ricevuto*)
procedure TCustomMtpCli.Next3PutAsync;
begin
if (not FServerSaidDone) or (not FFileSent) then
Exit;
TransfertStats;
// Resetta il puntatore dello stream
FLocalStream.Position :=0;
FRequestResult := FError;
TriggerRequestDone(FRequestResult);
end;
procedure TCustomMtpCli.PortAsync;
type
T4Bytes = array[0..3] of Byte;
P4Bytes = ^T4Bytes;
var
Msg : String;
saddr : TSockAddrIn6;
saddrlen : Integer;
DataPort : LongWord;
IPAddr : TInAddr;
StartDataPort: LongWord;
begin
if not FConnected then begin
HandleError('FTP component not connected');
Exit;
end;
FDataSocket.Proto := 'tcp';
if FControlSocket.CurrentSocketFamily = sfIPv6 then
FDataSocket.Addr := ICS_ANY_HOST_V6
else
FDataSocket.Addr := ICS_ANY_HOST_V4;
FDataSocket.Port := AnsiChar('0');
FDataSocket.OnSessionAvailable := nil;
FDataSocket.OnSessionClosed := nil;
FDataSocket.OnDataAvailable := nil;
FDataSocketSentFlag := FALSE;
if (ftpFctGet in FFctSet) then
FDataSocket.OnSessionAvailable := DataSocketGetSessionAvailable
else if ftpFctPut in FFctSet then
FDataSocket.OnSessionAvailable := DataSocketPutSessionAvailable;
FDataSocket.LingerOnOff := wsLingerOff;// wsLingerOn;
FDataSocket.LingerTimeout := 0;//10
if (FDataPortRangeStart = 0) and (FDataPortRangeEnd = 0) then begin
FDataSocket.Listen;
saddrLen := SizeOf(saddr);
FDataSocket.GetSockName(PSockAddrIn(@saddr)^, saddrLen);
DataPort := WSocket_ntohs(saddr.sin6_port);
end
else begin
if FDataPortRangeStart > FDataPortRangeEnd then begin
HandleError('DataPortRangeEnd must be greater than DataPortRangeStart');
Exit;
end;
if (FLastDataPort < FDataPortRangeStart) or
(FLastDataPort > FDataPortRangeEnd) then
FLastDataPort := FDataPortRangeStart;
DataPort := FLastDataPort;
StartDataPort := DataPort;
while TRUE do begin
FDataSocket.Port := IntToStr(DataPort);
try
FDataSocket.Listen;
break;
except
if FDataSocket.LastError = WSAEADDRINUSE then begin
DataPort := DataPort + 1;
if DataPort > FDataPortRangeEnd then
DataPort := FDataPortRangeStart;
if DataPort = StartDataPort then begin
HandleError('All ports in DataPortRange are in use');
Exit;
end;
end
else begin
HandleError('Data connection winsock bind failed - ' +
GetWinsockErr(FDataSocket.LastError));
Exit;
end;
end;
end;
FLastDataPort := DataPort + 1;
if FLastDataPort > FDataPortRangeEnd then
FLastDataPort := FDataPortRangeStart;
end;
saddrlen := SizeOf(saddr);
FControlSocket.GetSockName(PSockAddrIn(@saddr)^, saddrlen);
IPAddr := PSockAddrIn(@saddr).sin_addr;
if saddr.sin6_family = AF_INET6 then
begin
Msg := 'EPRT |2|' +
WSocketIPv6ToStr(PIcsIPv6Address(@saddr.sin6_addr)^) +
'|' + IntToStr(DataPort) + '|';
end
else
if WSocketIsIPv4(FExternalIPv4) then
Msg := Format('PORT %s,%d,%d',
[StringReplace(FExternalIPv4, '.', ',', [rfReplaceAll]),
IcsHiByte(DataPort),
IcsLoByte(DataPort)])
else
if FControlSocket.sin.sin_addr.s_addr = WSocket_htonl($7F000001) then
Msg := Format('PORT 127,0,0,1,%d,%d',
[IcsHiByte(DataPort),
IcsLoByte(DataPort)])
else
{$IFDEF MSWINDOWS}
Msg := Format('PORT %d,%d,%d,%d,%d,%d',
[ord(IPAddr. S_un_b.s_b1),
ord(IPAddr.S_un_b.s_b2),
ord(IPAddr.S_un_b.s_b3),
ord(IPAddr.S_un_b.s_b4),
IcsHiByte(DataPort),
IcsLoByte(DataPort)]);
{$ENDIF}
{$IFDEF POSIX}
Msg := Format('PORT %d,%d,%d,%d,%d,%d',
[P4Bytes(@IPAddr.s_addr)^[0],
P4Bytes(@IPAddr.s_addr)^[1],
P4Bytes(@IPAddr.s_addr)^[2],
P4Bytes(@IPAddr.s_addr)^[3],
IcsHiByte(DataPort),
IcsLoByte(DataPort)]);
{$ENDIF}
FByteCount := 0;
FFctPrv := ftpFctPort;
if saddr.sin6_family = AF_INET6 then
ExecAsync(ftpPortAsync, Msg, [200, 229], nil)
else
ExecAsync(ftpPortAsync, Msg, [200, 227], nil);
end;
procedure TCustomMtpCli.ControlSocketDnsLookupDone(Sender : TObject; ErrCode : Word);
begin
if ErrCode <> 0 then begin
FLastResponse := '500 DNS lookup error - ' + GetWinsockErr(ErrCode) ;
FStatusCode := 500;
FRequestResult := FStatusCode;
SetErrorMessage;
TriggerRequestDone(ErrCode);
end
else begin
FDnsResult := FControlSocket.DnsResult;
FControlSocket.Addr := FDnsResult;
FControlSocket.LocalAddr := FLocalAddr;
FControlSocket.LocalAddr6 := FLocalAddr6;
FControlSocket.Proto := 'tcp';
FControlSocket.Port := FPort;
{ FControlSocket.OnDisplay := FOnDisplay; } { Debugging only }
StateChange(ftpReady);
try
FControlSocket.Connect;
except
on E:Exception do begin
FLastResponse := '500 ' + E.ClassName + ': ' + E.Message;
FStatusCode := 500;
FRequestResult := FStatusCode;
SetErrorMessage;
TriggerRequestDone(FStatusCode);
end;
end;
end;
end;
procedure TCustomMtpCli.HandleHttpTunnelError(
Sender : TObject;
ErrCode : Word;
TunnelServerAuthTypes : THttpTunnelServerAuthTypes;
const Msg : String);
begin
FLastResponse := Msg;
end;
procedure TCustomMtpCli.HandleSocksError(
Sender : TObject;
ErrCode : Integer;
Msg : String);
begin
FLastResponse := Msg;
end;
procedure TCustomMtpCli.ControlSocketSessionConnected(Sender: TObject; ErrCode: Word);
begin
if ErrCode <> 0 then begin
{$IFDEF POSIX}
if (ErrCode <= WSAELAST) then
{$ELSE}
if (ErrCode >= WSABASEERR) and (ErrCode < ICS_SOCKS_BASEERR) then
{$ENDIF}
FLastResponse := '500 Connect error - ' + GetWinsockErr(ErrCode)
else if WSocketIsProxyErrorCode(ErrCode) then
FLastResponse := '500 Connect error - ' + FLastResponse + ' (#' + IntToStr(ErrCode) + ')'
else
FLastResponse := '500 Connect Unknown Error (#' + IntToStr(ErrCode) + ')';
FStatusCode := 500;
FRequestResult := FStatusCode;
SetErrorMessage;
FNextRequest := nil;
TriggerRequestDone(ErrCode);
FControlSocket.Close;
StateChange(ftpReady);
end
else begin
FConnected := TRUE;
StateChange(ftpConnected);
if Assigned(FOnSessionConnected) then
FOnSessionConnected(Self, ErrCode);
if Assigned(FWhenConnected) then
FWhenConnected
else begin
TriggerRequestDone(0);
end;
end;
end;
procedure TCustomMtpCli.ControlSocketDataAvailable(Sender: TObject; ErrCode: Word);
var
Len : Integer;
I, J : Integer;
p : PChar;
Feat : String;
ACodePage : LongWord;
RawResponse: AnsiString;
x : integer;
const
NewLine = #13#10 ;
begin
Len := FControlSocket.Receive(@FReceiveBuffer[FReceiveLen],
SizeOf(FReceiveBuffer) - FReceiveLen - 1);
if FRequestType = ftpRqAbort then
Exit;
if Len = 0 then begin
Exit;
end;
if Len < 0 then
Exit;
FReceiveBuffer[FReceiveLen + Len] := #0;
FReceiveLen := FReceiveLen + Len;
while FReceiveLen > 0 do begin
if ftpAcceptLF in FOptions then begin
I := Pos(AnsiChar(10), FReceiveBuffer);
J := I;
end
else begin
I := Pos(AnsiString(#13#10), FReceiveBuffer);
J := I + 1;
end;
if I <= 0 then
break;
if I > FReceiveLen then
break;
RawResponse := Copy(FReceiveBuffer, 1, I);
while (Length(RawResponse) > 0) and
IsCRLF(RawResponse[Length(RawResponse)]) do
SetLength(RawResponse, Length(RawResponse) - 1);
FLastResponse := RawResponse ;
if LongInt(Length(FLastMultiResponse)) < 65536 then
FLastMultiResponse := FLastMultiResponse + FLastResponse + #13#10;
TriggerResponse;
FReceiveLen := FReceiveLen - J;
if FReceiveLen > 0 then
Move(FReceiveBuffer[J], FReceiveBuffer[0], FReceiveLen + 1)
else if FReceiveLen < 0 then
FReceiveLen := 0;
if FState = ftpWaitingResponse then begin
if (FLastResponse = '') or
(not IsDigit(FLastResponse[1])) then begin
DisplayLastResponse;
Continue;
end;
p := GetInteger(@FLastResponse[1], FStatusCode);
x:= pos ('150 Opening retrieve data connection for ',FLastResponse,1);
if x <> 0 then begin
LocalStream.SetSize( StrToInt(RightStr(FLastResponse, length(FLastResponse) - 41 ) ));
LocalStream.Position :=0;
end;
if p^ = '-' then begin
DisplayLastResponse;
Continue;
end;
if Assigned(FNext) then
FNext
else begin
HandleError('Program error: FNext is nil');
Exit;
end;
end
else
DisplayLastResponse;
end;
end;
procedure TCustomMtpCli.ControlSocketSessionClosed(
Sender : TObject;
ErrCode : Word);
var
LClosedState : TFtpState;
begin
if (ErrCode <> 0) and (FState = ftpInternalReady) and
((FRequestType = ftpQuitAsync) or (FFctPrv = ftpFctQuit)) then
ErrCode := 0;
LClosedState := FState;
if FConnected then begin
FConnected := FALSE;
if FState <> ftpAbort then
StateChange(ftpNotConnected);
if Assigned(FOnSessionClosed) then
FOnSessionClosed(Self, ErrCode);
end;
if FState <> ftpAbort then
StateChange(ftpInternalReady);
if FRequestType <> ftpRqAbort then begin
if (ErrCode <> 0) or ((FRequestType <> ftpQuitAsync) and
(LClosedState in [ ftpWaitingResponse])) then begin
FLastResponse := '500 Control connection closed - ' +
WSocketGetErrorMsgFromErrorCode(ErrCode);
FStatusCode := 500;
FRequestResult := FStatusCode;
SetErrorMessage;
end;
TriggerRequestDone(FRequestResult);
end;
end;
procedure TCustomMtpCli.TriggerStateChange;
begin
if Assigned(FOnStateChange) then
FOnStateChange(Self);
end;
procedure TCustomMtpCli.TriggerRequestDone(ErrCode: Word);
begin
if not FRequestDoneFlag then begin
FRequestDoneFlag := TRUE;
if (ErrCode = 0) and Assigned(FNextRequest) then begin
if (FState <> ftpAbort) then StateChange(ftpInternalReady);
FNextRequest;
end
else begin
StateChange(ftpReady);
if FDataSocket.State <> wsClosed then
FDataSocket.Close;
if FHighLevelFlag and (FStatusCodeSave >= 0) then begin
FLastResponse := FLastResponseSave;
FStatusCode := FStatusCodeSave;
end;
FHighLevelFlag := FALSE;
FNextRequest := nil;
PostMessage(Handle, FMsg_WM_FTP_REQUEST_DONE, 0, ErrCode);
{ if Assigned(FOnRequestDone) then
FOnRequestDone(Self, FRequestType, ErrCode); }
end;
end;
end;
procedure TCustomMtpCli.TriggerResponse;
begin
if Assigned(FOnResponse) then
FOnResponse(Self);
end;
procedure TCustomMtpCli.TriggerReadyToTransmit(var bCancel : Boolean);
begin
if Assigned(FOnReadyToTransmit) then
FOnReadyToTransmit(Self, bCancel);
end;
function TCustomMtpCli.GetConnected : Boolean;
begin
Result := FControlSocket.State <> wsClosed;
end;
{* * * *}
{* * TFtpClient * *}
{* * * *}
constructor TMtpClient.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTimeout := 15;
end;
function TMtpClient.Open : Boolean;
begin
Result := Synchronize(OpenAsync);
end;
function TMtpClient.Connect : Boolean;
begin
Result := Synchronize(ConnectASync);
end;
function TMtpClient.Get : Boolean;
begin
Result := Synchronize(GetASync);
end;
function TMtpClient.MtpPort : Boolean;
begin
Result := Synchronize(PortASync);
end;
function TMtpClient.Put : Boolean;
begin
Result := Synchronize(PutASync);
end;
function TMtpClient.Quit : Boolean;
begin
Result := Synchronize(QuitASync);
end;
function TMtpClient.Abort : Boolean;
begin
Result := Synchronize(AbortASync);
end;
function TMtpClient.Receive : Boolean;
begin
Result := Synchronize(ReceiveASync);
end;
function TMtpClient.Transmit : Boolean;
begin
Result := Synchronize(TransmitASync);
end;
function TMtpClient.Progress : Boolean;
begin
Result := inherited Progress;
if FTimeout > 0 then
FTimeStop := LongInt(IcsGetTickCount) + LongInt(FTimeout) * 1000;
end;
function TMtpClient.WaitUntilReady : Boolean;
{$IFDEF MSWINDOWS}
var
DummyHandle : THandle;
{$ENDIF}
begin
FTimeStop := LongInt(IcsGetTickCount) + LongInt(FTimeout) * 1000;
{$IFDEF MSWINDOWS}
DummyHandle := INVALID_HANDLE_VALUE;
{$ENDIF}
while TRUE do begin
if FState in [ftpReady {, ftpInternalReady}] then begin
Result := (FRequestResult = 0);
break;
end;
if Terminated or
((FTimeout > 0) and (LongInt(IcsGetTickCount) > FTimeStop)) then begin
AbortAsync;
FErrorMessage := '426 Timeout';
FStatusCode := 426;
Result := FALSE;
break;
end;
{$IFDEF MSWINDOWS}
if ftpWaitUsingSleep in FOptions then
Sleep(0)
else
MsgWaitForMultipleObjects(0, DummyHandle, FALSE, 1000, QS_ALLINPUT);
{$ENDIF}
MessagePump;
end;
end;
function TMtpClient.Synchronize(Proc : TFtpNextProc) : Boolean;
begin
try
Proc;
Result := WaitUntilReady;
except
Result := FALSE;
end;
end;
end.
███╗ ███╗████████╗██████╗ ██████╗ ███████╗███╗ ███╗ ██████╗
████╗ ████║╚══██╔══╝██╔══██╗ ██╔══██╗██╔════╝████╗ ████║██╔═══██╗
██╔████╔██║ ██║ ██████╔╝ ██║ ██║█████╗ ██╔████╔██║██║ ██║
██║╚██╔╝██║ ██║ ██╔═══╝ ██║ ██║██╔══╝ ██║╚██╔╝██║██║ ██║
██║ ╚═╝ ██║ ██║ ██║ ██████╔╝███████╗██║ ╚═╝ ██║╚██████╔╝
╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚═════╝ ╚══════╝╚═╝ ╚═╝ ╚═════╝
unit Unit1;interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, OverbyteIcsWndControl, OverbyteIcsWSocket, iramtpCli,
Vcl.StdCtrls, iraMtpSrv, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
MtpClient: TMtpClient;
Button1: TButton;
MtpServer: TMtpServer;
Memo1: TMemo;
Memo2: TMemo;
Image1: TImage;
lbl5: TLabel;
Image2: TImage;
Button2: TButton;
procedure MtpClientBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
procedure MtpClientDisplay(Sender: TObject; var Msg: string);
procedure MtpClientError(Sender: TObject; var Msg: string);
procedure MtpClientResponse(Sender: TObject);
procedure MtpClientSessionClosed(Sender: TObject; ErrCode: Word);
procedure MtpClientSessionConnected(Sender: TObject; ErrCode: Word);
procedure MtpClientStateChange(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure MtpServerBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
procedure MtpServerClientCommand(Sender: TObject; Client: TMtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
procedure MtpServerClientConnect(Sender: TObject; Client: TMtpCtrlSocket; AError: Word);
procedure MtpServerStorSessionClosed(Sender: TObject; Client: TMtpCtrlSocket; Data: TWSocket; AError: Word);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure MtpServerDisplay(Sender: TObject; Client: TMtpCtrlSocket;
Msg: TFtpString);
private
{ Private declarations }
procedure DisplayC ( s: string);
procedure DisplayS ( s: string);
public
{ Public declarations }
end;
var
Form1: TForm1;
DIR_APP: string;
implementation
{$R *.dfm}
function LookupFtpState (const FtpState: TFtpState): String;
begin
case FtpState of
ftpNotConnected: result := 'Not Connected';
ftpReady: result := 'Ready';
ftpInternalReady: result := 'Internal Ready';
ftpDnsLookup: result := 'DNS Lookup';
ftpConnected: result := 'Connected';
ftpAbort: result := 'Abort';
ftpInternalAbort: result := 'Internal Abort';
ftpWaitingResponse: result := 'Waiting Response';
else
result:='unknown';
end;
end ;
procedure TForm1.Button1Click(Sender: TObject);
begin
MtpClient.StreamSize := image1.Picture.Bitmap.Width * image1.Picture.Bitmap.height * 3 ;
MtpClient.MemoryName := 'image1';
MtpClient.MemoryPtr := image1.Picture.Bitmap.ScanLine [image1.Picture.Bitmap.Height -1] ;
MtpClient.Put ;
end;
procedure TForm1.MtpClientBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
begin
displayC ('exc ' + e.Message );
end;
procedure TForm1.MtpClientDisplay(Sender: TObject; var Msg: string);
var
Ptr: pointer;
BMP: TBitmap;
begin
displayC(msg);
if Msg = '< 226 File sent ok' then begin
Ptr:= Image1.Picture.Bitmap.scanline [Image1.Picture.Bitmap.Height -1] ;
MtpClient.LocalStream.Read ( Ptr^ , MtpClient.LocalStream.Size );
image1.Invalidate ;
end;
end;
procedure TForm1.MtpClientError(Sender: TObject; var Msg: string);
begin
DisplayC('error ' + Msg);
end;
procedure TForm1.MtpClientResponse(Sender: TObject);
begin
DisplayC(MtpClient.LastResponse);
end;
procedure TForm1.MtpClientSessionClosed(Sender: TObject; ErrCode: Word);
begin
lbl5.Font.Color:= clRed;
lbl5.Caption := 'Mtp Closed';
end;
procedure TForm1.MtpClientSessionConnected(Sender: TObject; ErrCode: Word);
begin
If ErrCode = 0 then begin
DisplayC ( 'Connessione a Mtp :OK') ;
lbl5.Font.Color:= clgreen;
lbl5.Caption := 'Mtp Connected';
end
else
DisplayC ( 'Connessione a Mtp Error:' + IntToStr(Errcode));
end;
procedure TForm1.MtpClientStateChange(Sender: TObject);
begin
DisplayC(LookupFtpState (MtpClient.State ) );
end;
procedure TForm1.MtpServerBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
begin
ShowMessage('except:' + e.Message );
end;
procedure TForm1.MtpServerClientCommand(Sender: TObject; Client: TMtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
begin
DisplayS(Keyword + ' ' + params);
if Keyword = 'RETR' then begin
Client.DataStream.Position := 0;
client.DataStream.Size := image2.Picture.Bitmap.Width * image2.Picture.Bitmap.height * 3;
end;
end;
procedure TForm1.MtpServerClientConnect(Sender: TObject; Client: TMtpCtrlSocket; AError: Word);
begin
if MtpServer.ClientCount >= MtpServer.MaxClients then begin
Client.CloseDelayed ;
Exit;
end;
DisplayS( 'Mtp: client connesso: ' + Client.peerAddr );
end;
procedure TForm1.MtpServerDisplay(Sender: TObject; Client: TMtpCtrlSocket; Msg: TFtpString);
begin
displayS(Msg);
end;
procedure TForm1.MtpServerStorSessionClosed(Sender: TObject; Client: TMtpCtrlSocket; Data: TWSocket; AError: Word);
var
Ptr: pointer;
BMP: TBitmap;
begin
BMP:= Tbitmap.Create ;
BMP.PixelFormat := pf24bit;
BMP.Width := image1.picture.Bitmap.Width ;
BMP.Height := image1.picture.Bitmap.Height ;
BMP.Canvas.Brush.Color:= clyellow;
BMP.Canvas.FillRect(rect(0,0,BMP.Width,BMP.Height ) );
image2.Picture.Assign(BMP);
Client.DataStream.Position :=0;
Ptr:= Image2.Picture.Bitmap.scanline [Image2.Picture.Bitmap.Height -1] ;
Client.DataStream.Read ( Ptr^ , Client.DataStream.size );
// il server modifica image2 e riscriva il client.datastream
image2.Picture.Bitmap.Canvas.Font.Size := 24;
image2.Picture.Bitmap.Canvas.TextOut(150,300 ,'MODIFIED');
image2.Invalidate ;
Client.DataStream.Position :=0;
Client.DataStream.Write ( Ptr^ , Client.DataStream.size ); // il size del Bitmap è sempre quello
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
mtpclient.LocalStream.Position :=0;
mtpClient.Get ;
end;
procedure Tform1.DisplayC ( s: string);
begin
memo1.lines.add(S);
end;
procedure Tform1.DisplayS ( s: string);
begin
memo2.lines.add(S);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DIR_APP:= extractfilepath (application.ExeName);
MtpServer.Start ;
MtpClient.HostName := '127.0.0.1';
MtpClient.Port := 'ftp'; // o qualsiasi numero
MtpClient.Open;
memo1.Lines.Clear;
memo2.Lines.Clear;
end;
end.
Commenti
Posta un commento