--- Merging r18089 into '.':

U    packages/fcl-web/src/base/fphttp.pp
--- Merging r18101 into '.':
U    packages/fcl-web/examples/helloworld/README.txt
--- Merging r18181 into '.':
A    packages/fcl-web/src/base/fphttpstatus.pas
--- Merging r18182 into '.':
U    packages/fcl-web/src/base/httpdefs.pp
U    packages/fcl-web/src/base/fphttpserver.pp
--- Merging r18184 into '.':
U    packages/fcl-web/src/base/custfcgi.pp
--- Merging r18187 into '.':
U    packages/fcl-web/src/base/FCGI-README.txt

# revisions: 18089,18101,18181,18182,18184,18187
------------------------------------------------------------------------
r18089 | michael | 2011-08-04 09:18:13 +0200 (Thu, 04 Aug 2011) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/fphttp.pp

* Make HandleRequest public
------------------------------------------------------------------------
------------------------------------------------------------------------
r18101 | marco | 2011-08-05 15:42:49 +0200 (Fri, 05 Aug 2011) | 2 lines
Changed paths:
   M /trunk/packages/fcl-web/examples/helloworld/README.txt

 * Fixed filename in readme, patch from Attila Borka, Mantis #19826

------------------------------------------------------------------------
------------------------------------------------------------------------
r18181 | michael | 2011-08-12 21:26:38 +0200 (Fri, 12 Aug 2011) | 1 line
Changed paths:
   A /trunk/packages/fcl-web/src/base/fphttpstatus.pas

* Some fixes and additional unit from Darius Blaszijk
------------------------------------------------------------------------
------------------------------------------------------------------------
r18182 | michael | 2011-08-12 21:26:51 +0200 (Fri, 12 Aug 2011) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/fphttpserver.pp
   M /trunk/packages/fcl-web/src/base/httpdefs.pp

* Some fixes and additional unit from Darius Blaszijk
------------------------------------------------------------------------
------------------------------------------------------------------------
r18184 | michael | 2011-08-12 23:20:02 +0200 (Fri, 12 Aug 2011) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/custfcgi.pp

* Exit process when a shutdown event is received from mod_fastcgi
------------------------------------------------------------------------
------------------------------------------------------------------------
r18187 | michael | 2011-08-13 09:28:29 +0200 (Sat, 13 Aug 2011) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/FCGI-README.txt

* Removed comment about bug ID #19440
------------------------------------------------------------------------

git-svn-id: branches/fixes_2_6@18828 -

.gitattributes

@@ -2631,6 +2631,7 @@ packages/fcl-web/src/base/fphttp.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpapp.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpclient.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
+packages/fcl-web/src/base/fphttpstatus.pas svneol=native#text/plain
 packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain
 packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain

packages/fcl-web/examples/helloworld/README.txt

@@ -104,7 +104,7 @@ Note: You need to change the module name if needed. For example on Linux,
 the module is not mod_fastcgi-2.4.6-AP22.dll but mod_fastcgi.so (need to be 
 compiled from sources found at http://www.fastcgi.com/dist/ ).
 The port (2015 in this example) must match the one set in the project main 
-file (echo.lpr).
+file (helloworld.lpr).
 The FCGI application must be running in order for this demo to work (external 
 FCGI server setup). Do not forget to restart it after changes and 
 recompilation.

packages/fcl-web/src/base/FCGI-README.txt

@@ -256,9 +256,6 @@ LoadModule fastcgi_module "modules/mod_fastcgi-2.4.6-AP22.dll"
   ScriptAlias /myfcgi "C:/My Programs/LazarusFCGITest/helloworld.exe"
 </IfModule>
 
-Known issues on Windows:
-http://bugs.freepascal.org/view.php?id=19440
-
 2.1.4 Start/Restart your Apache server.
 If you will use the FastCgiExternalServer, then start your application 
 manually, so it can start accepting incoming requests from the web server.

packages/fcl-web/src/base/custfcgi.pp

@@ -105,9 +105,15 @@ Type
     FAddress: string;
     FTimeOut,
     FPort: integer;
+
 {$ifdef windowspipe}
     FIsWinPipe: Boolean;
 {$endif}
+{$IFDEF WINDOWS}
+    FShutdownThread : TThread;
+    Procedure CheckShutDownEvent;
+    Procedure HandleShutDownEvent(Sender : TObject);
+{$ENDIF}
     function AcceptConnection: Integer;
     procedure CloseConnection;
     function Read_FCGIRecord : PFCGI_Header;
@@ -169,18 +175,53 @@ Implementation
 uses
   dbugintf;
 {$endif}
- 
-
-
 {$undef nosignal}
 
 {$if defined(FreeBSD) or defined(Linux)}
   {$define nosignal}
 {$ifend}
 
+{$IFDEF WINDOWS}
+Type
+
+  { TShutdownThread }
+  TShutdownEvent = Procedure (Sender : TObject) Of Object;
+  TShutdownThread = Class(TThread)
+  Private
+    FEvent : THandle;
+    FOnShutDown : TShutdownEvent;
+  Public
+    Constructor CreateWithEvent(AEvent : THandle; AOnShutDown : TShutdownEvent);
+    Procedure Execute; override;
+  end;
+{$ENDIF}
+
 Const 
    NoSignalAttr =  {$ifdef nosignal} MSG_NOSIGNAL{$else}0{$endif};
 
+{$IFDEF WINDOWS}
+{ TShutdownThread }
+
+constructor TShutdownThread.CreateWithEvent(AEvent: THandle; AOnShutDown : TShutdownEvent);
+begin
+  Inherited Create(False);
+  FEvent:=AEvent;
+  FOnShutDown:=AOnShutDown;
+  OnTerminate:=AOnShutDown;
+end;
+
+procedure TShutdownThread.Execute;
+begin
+  WaitForSingleObject(FEvent,INFINITE);
+  If Assigned(FOnShutDown) then
+    FOnShutDown(Self);
+  // This is very ugly, but there is no other way to stop the named pipe
+  // from accepting new connections.
+  // Using Halt(0) is not enough.
+  ExitProcess(0);
+end;
+{$ENDIF WINDOWS}
+
 { TFCGIHTTPRequest }
 
 procedure TFCGIRequest.ReadContent;
@@ -473,16 +514,27 @@ end;
 { TFCgiHandler }
 
 constructor TFCgiHandler.Create(AOwner: TComponent);
+
 begin
   Inherited Create(AOwner);
   FRequestsAvail:=5;
   SetLength(FRequestsArray,FRequestsAvail);
   FHandle := THandle(-1);
   FTimeOut:=50;
+{$IFDEF WINDOWS}
+  CheckShutdownEvent;
+{$ENDIF}
 end;
 
 destructor TFCgiHandler.Destroy;
 begin
+{$IFDEF WINDOWS}
+  IF (FShutDownThread<>Nil) then
+    begin
+    TShutDownThread(FShutDownThread).FOnShutDown:=Nil;
+    TShutDownThread(FShutDownThread).OnTerminate:=Nil;
+    end;
+{$ENDIF}
   SetLength(FRequestsArray,0);
   if (Socket<>0) then
     begin
@@ -492,6 +544,30 @@ begin
   inherited Destroy;
 end;
 
+{$IFDEF WINDOWS}
+Procedure TFCgiHandler.CheckShutdownEvent;
+
+Var
+  H : THandle;
+
+begin
+  // This is normally only used in mod_fastcgi.
+  // mod_fcgid just kills off the process...
+  H:=THandle(StrToIntDef(sysutils.GetEnvironmentVariable('_FCGI_SHUTDOWN_EVENT_'),0));
+  If (H<>0) then
+    FShutDownThread:=TShutdownThread.CreateWithEvent(H,@HandleShutDownEvent);
+end;
+
+procedure TFCgiHandler.HandleShutDownEvent(Sender : TOBject);
+begin
+  TShutDownThread(Sender).FOnShutDown:=Nil;
+  TShutDownThread(Sender).OnTerminate:=Nil;
+  FShutDownThread:=Nil;
+  Terminate;
+end;
+
+{$ENDIF}
+
 procedure TFCgiHandler.CloseConnection;
 Var
   i : Integer;

packages/fcl-web/src/base/fphttp.pp

@@ -38,13 +38,13 @@ Type
   Protected
     Procedure DoHandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean); virtual;
     Procedure DoGetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean); virtual;
-    Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean);
     Function ProduceContent : String; virtual;
     Procedure SetRequest(ARequest: TRequest);
   Protected
     Property BeforeRequest : TRequestEvent Read FBeforeRequest Write FBeforeRequest;
     Property AfterResponse : TResponseEvent Read FAfterResponse Write FAfterResponse;
   Public
+    Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean);
     Procedure GetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean);
     Function  HaveContent : Boolean; virtual;
     function ContentToStream(Stream : TStream) : boolean; virtual;

packages/fcl-web/src/base/fphttpserver.pp

@@ -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;

packages/fcl-web/src/base/fphttpstatus.pas

@@ -0,0 +1,201 @@
+unit FPHTTPStatus;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  SysUtils, fphttpserver, HTTPDefs;
+
+(* construct and return the default error message for a given
+ * HTTP defined error code
+ *)
+function http_error_response(status: integer; ARequest: TFPHTTPConnectionRequest): string;
+
+implementation
+
+function error_string(status: integer; ARequest: TFPHTTPConnectionRequest): string;
+begin
+  case status of
+    301: ;
+    302: ;
+    307: Result := '<p>The document has moved <a href=\' +
+        HTTPEncode(ARequest.Location) +
+        '\>here</a>.</p>';
+    303: Result := '<p>The answer to your request is located ' +
+        '<a href=\' +
+        HTTPEncode(ARequest.Location) +
+        '\>here</a>.</p>';
+    305: Result := '<p>This resource is only accessible ' +
+        'through the proxy' +
+        HTTPEncode(ARequest.Location) +
+        '<br />You will need to configure ' +
+        'your client to use that proxy.</p>';
+    407: ;
+    401: Result := '<p>This server could not verify that you' +
+        'are authorized to access the document' +
+        'requested.  Either you supplied the wrong' +
+        'credentials (e.g., bad password), or your' +
+        'browser doesn''t understand how to supply' +
+        'the credentials required.</p>';
+    400: Result := '<p>Your browser sent a request that ' +
+        'this server could not understand.<br />' +
+        '</p>';
+    403: Result := '<p>You don''t have permission to access ' +
+        HTTPEncode(ARequest.URI) +
+        'on this server.</p>';
+    404: Result := '<p>The requested URL ' +
+        HTTPEncode(ARequest.URI) +
+        ' was not found on this server.</p>';
+    405: Result := '<p>The requested method ' +
+        HTTPEncode(ARequest.Method) +
+        ' is not allowed for the URL ' +
+        HTTPEncode(ARequest.URI) +
+        '.</p>';
+    406: Result := '<p>An appropriate representation of the ' +
+        'requested resource ' +
+        HTTPEncode(ARequest.URI) +
+        ' could not be found on this server.</p>';
+    300: ;
+    411: Result := '<p>A request of the requested method ' +
+        HTTPEncode(ARequest.Method) +
+        ' requires a valid Content-length.<br />';
+    412: Result := '<p>The precondition on the request ' +
+        'for the URL ' +
+        HTTPEncode(ARequest.URI) +
+        ' evaluated to false.</p>';
+    501: Result := '<p>' +
+        HTTPEncode(ARequest.Method) + ' to ' +
+        HTTPEncode(ARequest.URI) +
+        ' not supported.<br />' +
+        '</p>';
+    502: Result := '<p>The proxy server received an invalid ' +
+        'response from an upstream server.<br />' +
+        '</p>';
+    506: Result := '<p>A variant for the requested ' +
+        'resource<pre>' +
+        HTTPEncode(ARequest.URI) +
+        '</pre>is itself a negotiable resource. ' +
+        'This indicates a configuration error.</p>';
+    408: Result := '<p>Server timeout waiting for the HTTP request from the client.</p>';
+    410: Result := '<p>The requested resource<br />' +
+        HTTPEncode(ARequest.URI) +
+        '<br />is no longer available on this server ' +
+        'and there is no forwarding address.' +
+        'Please remove all references to this ' +
+        'resource.</p>';
+    413: Result := 'The requested resource<br />' +
+        HTTPEncode(ARequest.URI) + '<br />' +
+        'does not allow request data with ' +
+        HTTPEncode(ARequest.Method) +
+        ' requests, or the amount of data provided in' +
+        'the request exceeds the capacity limit.';
+    414: Result := '<p>The requested URL''s length exceeds the capacity' +
+        'limit for this server.<br />' +
+        '</p>';
+    415: Result := '<p>The supplied request data is not in a format ' +
+        'acceptable for processing by this resource.</p>';
+    416: Result := '<p>None of the range-specifier values in the Range ' +
+        'request-header field overlap the current extent ' +
+        'of the selected resource.</p>';
+    417:
+    begin
+      if pos('Expect', ARequest.HeaderLine) <> 0 then
+        Result := '<p>The expectation given in the Expect request-header' +
+          'field could not be met by this server.' +
+          'The client sent<pre>   ' +
+          HTTPEncode(ARequest.HeaderLine) + '</pre>'
+      else
+        Result := '<p>No expectation was seen, the Expect request-header ' +
+          'field was not presented by the client.';
+    end;
+    422: Result := '<p>The server understands the media type of the' +
+        'request entity, but was unable to process the' +
+        'contained instructions.</p>';
+    423: Result := '<p>The requested resource is currently locked.' +
+        'The lock must be released or proper identification' +
+        'given before the method can be applied.</p>';
+    424: Result := '<p>The method could not be performed on the resource' +
+        'because the requested action depended on another' +
+        'action and that other action failed.</p>';
+    426: Result := '<p>The requested resource can only be retrieved' +
+        'using SSL.  The server is willing to upgrade the current' +
+        'connection to SSL, but your client doesn''t support it.' +
+        'Either upgrade your client, or try requesting the page' +
+        'using https://';
+    507: Result := '<p>The method could not be performed on the resource' +
+        'because the server is unable to store the' +
+        'representation needed to successfully complete the' +
+        'request.  There is insufficient free space left in' +
+        'your storage allocation.</p>';
+    503: Result := '<p>The server is temporarily unable to service your' +
+        'request due to maintenance downtime or capacity' +
+        'problems. Please try again later.</p>';
+    504: Result := '<p>The gateway did not receive a timely response' +
+        'from the upstream server or application.</p>';
+    510: Result := '<p>A mandatory extension policy in the request is not' +
+        'accepted by the server for this resource.</p>';
+    else
+      //HTTP internal server error
+      Result := '<p>The server encountered an internal ' +
+        'error or' +
+        'misconfiguration and was unable to complete ' +
+        'your request.</p>' +
+        '<p>Please contact the server ' +
+        'administrator at ' +
+        HTTPEncode(ARequest.Connection.Server.AdminMail) +
+        ' to inform them of the time this ' +
+        'error occurred,' +
+        ' and the actions you performed just before ' +
+        'this error.</p>' +
+        '<p>More information about this error ' +
+        'may be available' +
+        'in the server error log.</p>';
+  end;
+end;
+
+function signature(const prefix: string; ARequest: TFPHTTPConnectionRequest): string;
+var
+  name: string;
+begin
+  if ARequest.Connection.Server.AdminName <> '' then
+    name := ARequest.Connection.Server.AdminName
+  else
+    name := ARequest.Connection.Server.AdminMail;
+
+  if ARequest.Connection.Server.AdminMail <> '' then
+    Result := prefix + '<address>' +
+      ARequest.Connection.Server.ServerBanner +
+      ' Server at <a href="' +
+      'mailto:' +
+      HTTPEncode(ARequest.Connection.Server.AdminMail) +
+      '">' +
+      HTTPEncode(name) +
+      '</a> Port ' + ARequest.ServerPort +
+      '</address>'
+  else
+    Result := prefix + '<address>' + ARequest.Connection.Server.ServerBanner +
+      ' Server at ' +
+      ARequest.Connection.Server.AdminMail +
+      ' Port ' + ARequest.ServerPort +
+      '</address>';
+end;
+
+function http_error_response(status: integer; ARequest: TFPHTTPConnectionRequest): string;
+var
+  title: string;
+  h1: string;
+begin
+  title := Format('%d %s', [status, GetStatusCode(status)]);
+  h1 := GetStatusCode(status);
+
+  Result := '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">' +
+    '<html><head><title>' + title +
+    '</title></head><body><h1>' + h1 + '</h1>' +
+    error_string(status, ARequest) +
+    signature('<hr>', ARequest) +
+    '</body></html>';
+end;
+
+end.
+

packages/fcl-web/src/base/httpdefs.pp

@@ -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