paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-30 19:40:21 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Some fixes and additional unit from Darius Blaszijk

Browse Source 
git-svn-id: trunk@18182 -
This commit is contained in:
michael 2011-08-12 19:26:51 +00:00
parent 7dc58d81d9
commit 5d59d00fdc
2 changed files with 27 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
packages/fcl-web/src/base/fphttpserver.pp
View File

@ -37,6 +37,7 @@ Type
FConnection: TFPHTTPConnection;
protected
procedure SetContent(AValue : String);
published
Property Connection : TFPHTTPConnection Read FConnection;
end;
@ -93,12 +94,15 @@ Type
TFPCustomHttpServer = Class(TComponent)
Private
FAdminMail: string;
FAdminName: string;
FOnAllowConnect: TConnectQuery;
FOnRequest: THTTPServerRequestHandler;
FPort: Word;
FQueueSize: Word;
FServer : TInetServer;
FLoadActivate : Boolean;
FServerBanner: string;
FThreaded: Boolean;
function GetActive: Boolean;
procedure SetActive(const AValue: Boolean);
@ -138,6 +142,12 @@ Type
property Threaded : Boolean read FThreaded Write SetThreaded;
// Called to handle the request. If Threaded=True, it is called in a the connection thread.
Property OnRequest : THTTPServerRequestHandler Read FOnRequest Write FOnRequest;
published
//aditional server information
property AdminMail: string read FAdminMail write FAdminMail;
property AdminName: string read FAdminName write FAdminName;
property ServerBanner: string read FServerBanner write FServerBanner;
end;
TFPHttpServer = Class(TFPCustomHttpServer)
@ -152,6 +162,8 @@ Type
EHTTPServer = Class(Exception);
Function GetStatusCode (ACode: Integer) : String;
implementation
resourcestring
@ -426,8 +438,7 @@ begin
Until (S='');
end;
constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSocketStream
);
constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSocketStream);
begin
FSocket:=ASocket;
FServer:=AServer;
@ -448,6 +459,8 @@ Var
begin
// Read headers.
Req:=ReadRequestHeaders;
//set port
Req.ServerPort := Server.Port;
try
// Read content, if any
If Req.ContentLength>0 then
@ -611,6 +624,7 @@ begin
inherited Create(AOwner);
FPort:=80;
FQueueSize:=5;
FServerBanner := 'Freepascal';
end;
destructor TFPCustomHttpServer.Destroy;

13
packages/fcl-web/src/base/httpdefs.pp
View File

@ -187,6 +187,7 @@ type
Procedure SetContentLength(Value : Integer);
Function GetFieldIndex(AIndex : Integer) : Integer;
Function GetServerPort : Word;
Procedure SetServerPort(AValue : Word);
Function GetSetFieldValue(Index : Integer) : String; virtual;
Protected
Function GetFieldValue(Index : Integer) : String; virtual;
@ -241,7 +242,7 @@ type
Property RemoteAddr : String Index 27 read GetFieldValue Write SetFieldValue; // Alias, Delphi-compat
Property RemoteHost : String Index 28 read GetFieldValue Write SetFieldValue;
Property ScriptName : String Index 29 read GetFieldValue Write SetFieldValue;
Property ServerPort : Word Read GetServerPort; // Index 30
Property ServerPort : Word Read GetServerPort Write SetServerPort; // Index 30
Property HTTPAccept : String Index 1 read GetFieldValue Write SetFieldValue;
Property HTTPAcceptCharset : String Index 2 read GetFieldValue Write SetFieldValue;
Property HTTPAcceptEncoding : String Index 3 read GetFieldValue Write SetFieldValue;
@ -273,6 +274,7 @@ type
FFiles : TUploadedFiles;
FReturnedPathInfo : String;
FLocalPathPrefix : string;
FServerPort : String;
function GetLocalPathPrefix: string;
function GetFirstHeaderLine: String;
Protected
@ -594,6 +596,12 @@ begin
Result:=StrToIntDef(GetFieldValue(30),0);
end;
Procedure THTTPHeader.SetServerPort(AValue : Word);
begin
SetFieldValue(30,IntToStr(AValue));
end;
function THTTPHeader.GetSetFieldValue(Index: Integer): String;
Var
@ -674,7 +682,7 @@ begin
27 : ; // Property RemoteAddress : String Index 27 read GetFieldValue Write SetFieldValue;
28 : ; // Property RemoteHost : String Index 28 read GetFieldValue Write SetFieldValue;
29 : ; // Property ScriptName : String Index 29 read GetFieldValue Write SetFieldValue;
30 : ; // Property ServerPort : Word Read GetServerPort; // Index 30
30 : ; // Property ServerPort : Word Read GetServerPort; // Index 30 in TRequest
36 : FHTTPXRequestedWith:=Value;
end;
end;
@ -1042,6 +1050,7 @@ procedure TRequest.SetFieldValue(Index: Integer; Value: String);
begin
Case Index of
25 : FPathInfo:=Value;
30 : FServerPort:=Value;
31 : FCommand:=Value;
32 : FURI:=Value;
else