unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdContext, IdIntercept, IdServerInterceptLogBase,
IdServerInterceptLogFile, IdBaseComponent, IdComponent, IdCustomTCPServer,
IdTCPServer, IdCmdTCPServer, IdExplicitTLSClientServerBase, IdFTPServer,
IdFTPList, IdFTPListOutput, ExtCtrls;
type
TForm1 =
class(TForm)
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Edit3: TEdit;
Label3: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
GroupBox1: TGroupBox;
Memo1: TMemo;
Server: TIdFTPServer;
logfile1: TIdServerInterceptLogFile;
procedure Button4Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure ServerDeleteFile(ASender: TIdFTPServerContext;
const APathName:
string);
procedure ServerFileExistCheck(ASender: TIdFTPServerContext;
const APathName:
string;
var VExist: Boolean);
procedure ServerGetFileDate(ASender: TIdFTPServerContext;
const AFilename:
string;
var VFileDate: TDateTime);
procedure ServerGetFileSize(ASender: TIdFTPServerContext;
const AFilename:
string;
var VFileSize: Int64);
procedure ServerListDirectory(ASender: TIdFTPServerContext;
const APath:
string; ADirectoryListing: TIdFTPListOutput;
const ACmd,
ASwitches:
string);
procedure ServerMakeDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
procedure ServerRetrieveFile(ASender: TIdFTPServerContext;
const AFileName:
string;
var VStream: TStream);
procedure ServerRenameFile(ASender: TIdFTPServerContext;
const ARenameFromFile, ARenameToFile:
string);
procedure ServerRemoveDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
procedure ServerUserLogin(ASender: TIdFTPServerContext;
const AUsername,
APassword:
string;
var AAuthenticated: Boolean);
procedure ServerStoreFile(ASender: TIdFTPServerContext;
const AFileName:
string; AAppend: Boolean;
var VStream: TStream);
procedure ServerStat(ASender: TIdFTPServerContext; AStatusInfo: TStrings);
procedure FormCreate(Sender: TObject);
procedure ServerExecute(AContext: TIdContext);
procedure ServerStatus(ASender: TObject;
const AStatus: TIdStatus;
const AStatusText:
string);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
user: Integer;
homedir:
String;
implementation
{$R *.dfm}
function setSlashes(APath:
String):
String;
var
slash:
String;
begin
slash:= StringReplace(APath, '
/', '
', [rfReplaceAll]);
slash:= StringReplace(slash, '
', '
', [rfReplaceAll]);
Result:=slash;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Server.DefaultPort:=strtoint(edit3.Text);
Server.Active:=True;
Memo1.Lines.Add(datetostr(Date)+ '
| ' + timetostr(time)+ '
: Server gestartet.');
Button1.Enabled:=False;
Button2.Enabled:=True;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Server.Active:=False;
Button1.Enabled:=True;
Button2.Enabled:=False;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Memo1.Lines.Clear;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Button2.Click;
Application.Terminate;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//Ordner:
homedir:='
f:';
end;
procedure TForm1.ServerDeleteFile(ASender: TIdFTPServerContext;
const APathName:
string);
begin
if FileExists(APathName)
then
begin
DeleteFile(APathName);
end;
end;
procedure TForm1.ServerExecute(AContext: TIdContext);
begin
logfile1.DoLogWriteString(AContext.Connection.IOHandler.AllData);
end;
procedure TForm1.ServerFileExistCheck(ASender: TIdFTPServerContext;
const APathName:
string;
var VExist: Boolean);
begin
if FileExists(APathName)
then
begin
VExist:=True;
end
else
begin
VExist:=False;
end;
end;
procedure TForm1.ServerGetFileDate(ASender: TIdFTPServerContext;
const AFilename:
string;
var VFileDate: TDateTime);
var
fdate: TDateTime;
begin
fdate:=FileAge(AFilename);
//Dateialter in eine Variabel schreiben
if not (fdate=-1)
then
begin
VFileDate:=fdate;
end;
end;
procedure TForm1.ServerGetFileSize(ASender: TIdFTPServerContext;
const AFilename:
string;
var VFileSize: Int64);
var lfile:
String;
rec: TSearchRec;
ASize: Int64;
begin
LFile:=setSlashes(homedir + AFilename);
try
if FindFirst(lfile, faAnyFile, rec) = 0
then repeat
ASize:=rec.Size;
until FindNext(rec) <> 0;
finally
FindClose(rec);
end;
if ASize >1
then
VFileSize:=Asize
else
VFileSize:=0;
end;
procedure TForm1.ServerListDirectory(ASender: TIdFTPServerContext;
const APath:
string; ADirectoryListing: TIdFTPListOutput;
const ACmd,
ASwitches:
string);
var LFTPItem :TIdFTPListItem;
SR: TSearchRec;
SRI: Integer;
begin
ADirectoryListing.DirFormat:=doUnix;
SRI:=FindFirst(homedir + APath+'
*.*',
faAnyFile - faHidden - faSysFile, SR);
while SRI= 0
do
begin
LFTPItem:=ADirectoryListing.Add;
LFTPItem.FileName:=SR.
Name;
LFTPItem.Size:=SR.Size;
LFTPItem.ModifiedDate:=FileDateToDateTime(SR.Time);
if SR.Attr=faDirectory
then
LFTPItem.ItemType:=ditDirectory
else
LFTPItem.ItemType:=ditFile;
SRI:=FindNext(SR);
end;
FindClose(SR);
SetCurrentDir(homedir + APath + '
...');
end;
procedure TForm1.ServerMakeDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
var ldir:
String;
begin
ldir:= setSlashes(homedir + VDirectory);
if not DirectoryExists(ldir)
then
if not CreateDir(ldir)
then
raise Exception.Create('
Verzeichniss '+ldir +'
kann nicht erstellt werden.');
end;
procedure TForm1.ServerRemoveDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
var LFile:
String;
begin
LFile:=setSlashes(homedir + VDirectory);
if DirectoryExists(LFile)
then
begin
RemoveDir(LFile);
end
else
begin
raise Exception.Create('
Verzeichniss konnte nicht gelöscht werden.');
end;
end;
procedure TForm1.ServerRenameFile(ASender: TIdFTPServerContext;
const ARenameFromFile, ARenameToFile:
string);
begin
if not RenameFile(ARenameFromFile, ARenameToFile)
then
begin
raise Exception.Create('
Datei konnte nicht umgenannt werden.');
end;
end;
procedure TForm1.ServerRetrieveFile(ASender: TIdFTPServerContext;
const AFileName:
string;
var VStream: TStream);
begin
VStream:=TFileStream.Create(setSlashes(homedir + AFileName), fmOpenRead);
end;
procedure TForm1.ServerStat(ASender: TIdFTPServerContext;
AStatusInfo: TStrings);
var i:Integer;
begin
for I := 0
to AStatusInfo.Count - 1
do
Memo1.Lines.Add(AStatusInfo.Strings[i]);
end;
procedure TForm1.ServerStatus(ASender: TObject;
const AStatus: TIdStatus;
const AStatusText:
string);
begin
Memo1.Lines.Add(AStatusText);
end;
procedure TForm1.ServerStoreFile(ASender: TIdFTPServerContext;
const AFileName:
string; AAppend: Boolean;
var VStream: TStream);
begin
if not AAppend
then
VStream:=TFileStream.Create(AFileName, fmCreate)
else
VStream:=TFileStream.Create(AFileName, fmOpenRead);
end;
procedure TForm1.ServerUserLogin(ASender: TIdFTPServerContext;
const AUsername,
APassword:
string;
var AAuthenticated: Boolean);
begin
if (AUsername=Edit1.Text)
and (APassword=Edit2.Text)
then
begin
AAuthenticated:=True;
end
else
begin
AAuthenticated:=False;
end;
end;
end.