если каму тикава вот 100% рабочи, но со сваими недостатками, код
недостатки:
--зависимость от доступной на машине памяти
--файлы заливаюццо со служебной инфой.
но при жалании ис тем и с другим справиицо можна (автар был кой-та немец) 
| Код |
unit Push_main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdBaseComponent, IdComponent, IdTCPServer, IdCustomHTTPServer,
IdHTTPServer, StdCtrls, ToolBox;
type
TForm1 = class(TForm)
Server: TIdHTTPServer;
Active: TCheckBox;
Port: TEdit;
procedure ServerCommandGet(AThread: TIdPeerThread;
ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure ServerCreatePostStream(ASender: TIdPeerThread;
var VPostStream: TStream);
procedure FormCreate(Sender: TObject);
procedure ActiveClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses IdHTTPHeaderInfo;
{$R *.dfm}
//function fib(n:Integer):Integer; begin if (n <= 2) then result:=1 else result:=fib(n-1) + fib(n-2); end;
function HtmlForm:string;
begin
Result:=
'<html><head><title>Upload</title></head><body>'+
'<center><h1>File Upload</h1><hr>'+
'<form action="/upload/" method=post enctype="multipart/form-data">'+
'<input type=file name=file><input type=submit value=Upload></form>'+
'</center></body></html>';
end;
function HTMLMessage(msg:String):string;
begin
Result:=
'<html><head><title>Upload</title></head><body>'+
'<center><h1>File Upload</h1><hr>'+msg+'<hr>'+
'<a href=/>Click here to continue</a></center></body></html>';
end;
procedure TForm1.ServerCommandGet(AThread: TIdPeerThread;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
Var TheFile:TMemoryStream;
FN:String;
begin
If ARequestInfo.Document='/' Then begin
With AResponseInfo do begin
ContentText:=HtmlForm;
WriteContent;
end;
end else if ARequestInfo.Document='/upload/' then begin
TheFile:=TMemoryStream.Create;
try
try
TheFile.LoadFromStream(ARequestInfo.PostStream);
TheFile.SaveToFile('.\'+DateToStr(now)+' '+TimeToStr(now)+' '+ARequestInfo.RemoteIP+' '+FN);
With AResponseInfo do begin
ContentText:=HtmlMessage('Upload Successful!');
WriteContent;
end;
except
With AResponseInfo do begin
ContentText:=HTMLMessage('Upload Error!');
WriteContent;
end;
end;
finally
TheFile.Free;
end;
end;
end;
procedure TForm1.ServerCreatePostStream(ASender: TIdPeerThread;
var VPostStream: TStream);
begin
VPostStream:=TMemoryStream.Create;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
LongTimeFormat:='hhmmss';
ShortDateFormat:='yyMMdd';
end;
procedure TForm1.ActiveClick(Sender: TObject);
begin
Try
If Active.Checked then begin
Server.DefaultPort:=StrTointDef(Port.Text,80);
end;
Server.Active:=Active.Checked;
Finally
Active.Checked:=Server.Active;
end;
end;
end.
|
|
