--- Merging r25563 into '.':

U    packages/fcl-web/src/base/fpweb.pp
--- Merging r25571 into '.':
U    packages/fcl-web/src/base/custweb.pp
U    packages/fcl-web/src/base/custhttpapp.pp
U    packages/fcl-web/src/base/fphttpserver.pp
--- Merging r25616 into '.':
U    packages/fcl-json/src/fpjson.pp
--- Merging r25617 into '.':
U    packages/fcl-json/src/jsonparser.pp
--- Merging r25619 into '.':
U    packages/fcl-web/src/base/fphttp.pp
--- Merging r25691 into '.':
G    packages/fcl-json/src/fpjson.pp
U    packages/fcl-json/tests/testjsondata.pp
U    packages/fcl-json/tests/testjson.pp
U    packages/fcl-json/tests/testjson.lpi
--- Merging r25692 into '.':
G    packages/fcl-json/src/jsonparser.pp
G    packages/fcl-json/src/fpjson.pp
U    packages/fcl-json/tests/testjsonparser.pp
G    packages/fcl-json/tests/testjson.lpi
G    packages/fcl-json/tests/testjsondata.pp
--- Merging r25693 into '.':
G    packages/fcl-json/src/jsonparser.pp
G    packages/fcl-json/src/fpjson.pp
G    packages/fcl-json/tests/testjsonparser.pp
--- Merging r25694 into '.':
G    packages/fcl-json/tests/testjsondata.pp
U    packages/fcl-json/src/README.txt
G    packages/fcl-json/src/fpjson.pp

# revisions: 25563,25571,25616,25617,25619,25691,25692,25693,25694
r25563 | michael | 2013-09-25 09:17:51 +0200 (Wed, 25 Sep 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/fpweb.pp

* Some refactoring, so fpweb is easier to customize
r25571 | michael | 2013-09-25 21:06:16 +0200 (Wed, 25 Sep 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/custhttpapp.pp
   M /trunk/packages/fcl-web/src/base/custweb.pp
   M /trunk/packages/fcl-web/src/base/fphttpserver.pp

* Changes as suggested in bug ID #24810, so a threaded web application can be stopped correctly, even from a request
r25616 | michael | 2013-10-02 09:48:31 +0200 (Wed, 02 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-json/src/fpjson.pp

* Added Extract to TJSONArray
r25617 | michael | 2013-10-02 09:49:33 +0200 (Wed, 02 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-json/src/jsonparser.pp

Raise exception if no scanner specified
r25619 | michael | 2013-10-02 09:52:30 +0200 (Wed, 02 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/fphttp.pp

* DisplayName should not set name
r25691 | michael | 2013-10-06 16:51:10 +0200 (Sun, 06 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-json/src/fpjson.pp
   M /trunk/packages/fcl-json/tests/testjson.lpi
   M /trunk/packages/fcl-json/tests/testjson.pp
   M /trunk/packages/fcl-json/tests/testjsondata.pp

* FindPath/GetPath implementation
r25692 | michael | 2013-10-06 16:51:34 +0200 (Sun, 06 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-json/src/fpjson.pp
   M /trunk/packages/fcl-json/src/jsonparser.pp
   M /trunk/packages/fcl-json/tests/testjson.lpi
   M /trunk/packages/fcl-json/tests/testjsondata.pp
   M /trunk/packages/fcl-json/tests/testjsonparser.pp

* Factory methods
r25693 | michael | 2013-10-06 16:52:01 +0200 (Sun, 06 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-json/src/fpjson.pp
   M /trunk/packages/fcl-json/src/jsonparser.pp
   M /trunk/packages/fcl-json/tests/testjsonparser.pp

* JSON parser handler
r25694 | michael | 2013-10-06 16:52:27 +0200 (Sun, 06 Oct 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-json/src/README.txt
   M /trunk/packages/fcl-json/src/fpjson.pp
   M /trunk/packages/fcl-json/tests/testjsondata.pp

* JSON Enumerator support

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

packages/fcl-json/src/README.txt

@@ -112,13 +112,48 @@ forms:
 Where the type of AVAlue is one of the supported types: 
 integer, int64, double, string, TJSONArray or TJSONObject.
 
-The Delete() call deletes an element from an array or object.
+The Delete() call deletes an element from an array or object. The element is
+freed.
 
 Important remark:
 The array and object classes own their members: the members are destroyed as
 they are deleted. For this, the Extract() call exists: it removes an
 element/member from the array/object, without destroying it.
 
+Converting from string/stream to JSONData
+=========================================
+
+The fpjson unit contains a GetJSON() function which accepts a string or a
+stream as a parameter. The function will parse the JSON in the stream and 
+the return value is a TJSONData value corresponding to the JSON.
+The function works with a callback, which is set by the JSONParser unit.
+The JSONParser unit simply needs to be included in the project.
+
+The parsing happens with default settings for the parser class.
+You can override this behaviour by creating your own callback, 
+and creating the parser with different settings.
+
+Enumerator support
+==================
+
+the TJSONData class offers support for an enumerator, hence the 
+For e in JSON do
+construct can be used. The enumerator is a TJSONEnum value, which has 3
+members:
+Key : The key of the element 
+     (name in TJSONObject, Index in TJSONArray, empty otherwise)
+KeyNum: The index of the element.
+     (Index in TJSONArray/TJSONObject, 0 otherwise)
+Value : The value of the element
+     (These are the member values for TJSONArray/TJSONObject, and is the
+     element itself otherwise)
+
+While the enumerator is looping, it is not allowed to change the content of
+the array or object, and the value may not be freed.
+
+Scanner/Parser
+==============
+
 The JSONSCanner unit contains a scanner for JSON data: TJSONScanner. 
 Currently it does not support full unicode, only UTF-8 is supported.
 
@@ -165,3 +200,30 @@ A second effect of the Strict property is the requirement of " as a string
 delimiter. A single quote is also often found in Javascript and JSON:
 { title: 'A nice title' }
 By default, this is accepted. Setting 'Strict' to true will reject this.
+
+Customizing the classes : Factory support
+=========================================
+
+The various classes created by the methods can be customized. 
+This can be useful to create customized descendents, for example to attach
+extra data to the various values. All instances of TJSONData are created
+through the CreateJSON() functions, which use a set of customizable classes
+to create the JSONData structures.
+
+All functions which somehow create a new instance (clone, add, insert, parsing)
+use the CreateJSON functions.
+
+Which classes need to be created for a specific value is enumerated in
+
+TJSONInstanceType = (jitUnknown, jitNumberInteger,jitNumberInt64,jitNumberFloat,
+                       jitString, jitBoolean, jitNull, jitArray, jitObject);
+
+when a Int64 value must be instantiated, the class identified with 
+jitNumberInt64 is instantiated.
+
+To customize the classes, the new class can be set using SetJSONInstanceType:
+
+Procedure SetJSONInstanceType(AType : TJSONInstanceType; AClass : TJSONDataClass);
+Function GetJSONInstanceType(AType : TJSONInstanceType) : TJSONDataClass;
+
+The function checks whether sane classes are specified.;

packages/fcl-json/src/jsonparser.pp

@@ -67,12 +67,31 @@ Resourcestring
   SErrExpectedElementName    = 'Expected element name, got token "%s"';
   SExpectedCommaorBraceClose = 'Expected , or ], got token "%s".';
   SErrInvalidNumber          = 'Number is not an integer or real number: %s';
+  SErrNoScanner = 'No scanner. No source specified ?';
   
 { TJSONParser }
 
+procedure DefJSONParserHandler(AStream: TStream; const AUseUTF8: Boolean; out
+  Data: TJSONData);
+
+Var
+  P : TJSONParser;
+
+begin
+  Data:=Nil;
+  P:=TJSONParser.Create(AStream,AUseUTF8);
+  try
+    Data:=P.Parse;
+  finally
+    P.Free;
+  end;
+end;
+
 Function TJSONParser.Parse : TJSONData;
 
 begin
+  if (FScanner=Nil) then
+    DoError(SErrNoScanner);
   Result:=DoParse(False,True);
 end;
 
@@ -113,10 +132,10 @@ begin
     Case T of
       tkEof : If Not AllowEof then
                 DoError(SErrUnexpectedEOF);
-      tkNull  : Result:=TJSONNull.Create;
+      tkNull  : Result:=CreateJSON;
       tkTrue,
-      tkFalse : Result:=TJSONBoolean.Create(t=tkTrue);
-      tkString : Result:=TJSONString.Create(CurrentTokenString);
+      tkFalse : Result:=CreateJSON(t=tkTrue);
+      tkString : Result:=CreateJSON(CurrentTokenString);
       tkCurlyBraceOpen : Result:=ParseObject;
       tkCurlyBraceClose : DoError(SErrUnexpectedToken);
       tkSQuaredBraceOpen : Result:=ParseArray;
@@ -144,16 +163,20 @@ begin
   S:=CurrentTokenString;
   I:=0;
   If TryStrToInt64(S,I64) then
-    Result:=TJSONInt64Number.Create(I64)
-  Else If TryStrToInt(S,I) then
-    Result:=TJSONIntegerNumber.Create(I)
+    if (I64>Maxint) or (I64<-MaxInt) then
+      Result:=CreateJSON(I64)
+    Else
+      begin
+      I:=I64;
+      Result:=CreateJSON(I);
+      end
   else
     begin
     I:=0;
     Val(S,F,I);
     If (I<>0) then
       DoError(SErrInvalidNumber);
-    Result:=TJSONFloatNumber.Create(F);
+    Result:=CreateJSON(F);
     end;
 end;
 
@@ -192,7 +215,7 @@ Var
   N : String;
   
 begin
-  Result:=TJSONObject.Create;
+  Result:=CreateJSONObject([]);
   Try
     T:=GetNextToken;
     While T<>tkCurlyBraceClose do
@@ -226,7 +249,7 @@ Var
   LastComma : Boolean;
   
 begin
-  Result:=TJSONArray.Create;
+  Result:=CreateJSONArray([]);
   LastComma:=False;
   Try
     Repeat
@@ -292,5 +315,23 @@ begin
   inherited Destroy();
 end;
 
+Procedure InitJSONHandler;
+
+begin
+  if GetJSONParserHandler=Nil then
+    SetJSONParserHandler(@DefJSONParserHandler);
+end;
+
+Procedure DoneJSONHandler;
+
+begin
+  if GetJSONParserHandler=@DefJSONParserHandler then
+    SetJSONParserHandler(Nil);
+end;
+
+initialization
+  InitJSONHandler;
+finalization
+  DoneJSONHandler;
 end.
 

packages/fcl-json/tests/testjson.lpi

@@ -24,7 +24,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--format=plain --suite=TCJSONStreamer"/>
+        <CommandLineParams Value="--suite=TTestParser.TestClasses"/>
         <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
@@ -71,7 +71,7 @@
     </Units>
   </ProjectOptions>
   <CompilerOptions>
-    <Version Value="10"/>
+    <Version Value="11"/>
     <SearchPaths>
       <OtherUnitFiles Value="../src"/>
     </SearchPaths>
@@ -82,7 +82,7 @@
     </Parsing>
     <Linking>
       <Debugging>
-        <GenerateDebugInfo Value="True"/>
+        <DebugInfoType Value="dsStabs"/>
         <UseHeaptrc Value="True"/>
       </Debugging>
     </Linking>

packages/fcl-json/tests/testjson.pp

@@ -17,8 +17,7 @@
 program testjson;
 
 uses
-  Classes, consoletestrunner, testjsondata, testjsonparser,
-  fpcunitconsolerunner; //, testjsonrtti, fpjsonrtti;
+  Classes, testjsondata, testjsonparser, consoletestrunner; //, testjsonrtti, fpjsonrtti;
 type
   { TLazTestRunner }
    TMyTestRunner = class(TTestRunner)
@@ -29,6 +28,9 @@ type
 var
   Application: TMyTestRunner;
 begin
+  DefaultFormat := fPlain;
+  DefaultRunAllTests := True;
+
   Application := TMyTestRunner.Create(nil); 
   Application.Initialize;
   Application.Run;  

packages/fcl-json/tests/testjsonparser.pp

@@ -26,14 +26,17 @@ type
 
   { TTestParser }
 
-  TTestParser= class(TTestJSON)
+  TTestParser = class(TTestJSON)
   private
+    procedure CallNoHandlerStream;
     procedure DoTestError(S: String);
     procedure DoTestFloat(F: TJSONFloat); overload;
     procedure DoTestFloat(F: TJSONFloat; S: String); overload;
     procedure DoTestObject(S: String; const ElNames: array of String; DoJSONTest : Boolean = True);
     procedure DoTestString(S : String);
     procedure DoTestArray(S: String; ACount: Integer);
+    Procedure DoTestClass(S : String; AClass : TJSONDataClass);
+    procedure CallNoHandler;
   published
     procedure TestEmpty;
     procedure TestNull;
@@ -47,6 +50,11 @@ type
     procedure TestObject;
     procedure TestMixed;
     procedure TestErrors;
+    Procedure TestClasses;
+    Procedure TestHandler;
+    Procedure TestNoHandlerError;
+    Procedure TestHandlerResult;
+    Procedure TestHandlerResultStream;
   end;
 
 implementation
@@ -210,8 +218,11 @@ begin
   DoTestArray('[1234567890123456, 2234567890123456]',2);
   DoTestArray('[1234567890123456, 2234567890123456, 3234567890123456]',3);
   Str(Double(1.2),S1);
+  Delete(S1,1,1);
   Str(Double(2.3),S2);
+  Delete(S2,1,1);
   Str(Double(3.4),S3);
+  Delete(S3,1,1);
   DoTestArray('['+S1+']',1);
   DoTestArray('['+S1+', '+S2+']',2);
   DoTestArray('['+S1+', '+S2+', '+S3+']',3);
@@ -262,7 +273,8 @@ begin
 end;
 
 
-procedure TTestParser.DoTestObject(S : String; Const ElNames : Array of String; DoJSONTest : Boolean = True);
+procedure TTestParser.DoTestObject(S: String; const ElNames: array of String;
+  DoJSONTest: Boolean);
 
 Var
   P : TJSONParser;
@@ -312,6 +324,26 @@ begin
   end;
 end;
 
+procedure TTestParser.DoTestClass(S: String; AClass: TJSONDataClass);
+
+Var
+  P : TJSONParser;
+  D : TJSONData;
+
+begin
+  P:=TJSONParser.Create(S);
+  try
+    D:=P.Parse;
+    try
+      AssertEquals('Correct class for '+S+' : ',AClass,D.ClassType);
+    finally
+      D.Free
+    end;
+  finally
+    P.Free;
+  end;
+end;
+
 procedure TTestParser.TestErrors;
 
 begin
@@ -328,6 +360,93 @@ begin
   DoTestError('[1,,]');
 end;
 
+procedure TTestParser.TestClasses;
+begin
+  SetMyInstanceTypes;
+  DoTestClass('null',TMyNull);
+  DoTestClass('true',TMyBoolean);
+  DoTestClass('1',TMyInteger);
+  DoTestClass('1.2',TMyFloat);
+  DoTestClass('123456789012345',TMyInt64);
+  DoTestClass('"tata"',TMyString);
+  DoTestClass('{}',TMyObject);
+  DoTestClass('[]',TMyArray);
+end;
+
+procedure TTestParser.CallNoHandler;
+
+begin
+  GetJSON('1',True).Free;
+end;
+
+procedure TTestParser.CallNoHandlerStream;
+
+Var
+  S : TStringStream;
+
+begin
+  S:=TstringStream.Create('1');
+  try
+    GetJSON(S,True).Free;
+  finally
+    S.Free;
+  end;
+end;
+
+procedure TTestParser.TestHandler;
+begin
+  AssertNotNull('Handler installed',GetJSONParserHandler);
+end;
+
+procedure TTestParser.TestNoHandlerError;
+
+Var
+  H : TJSONParserHandler;
+
+begin
+  H:=GetJSONParserHandler;
+  try
+    SetJSONParserHandler(Nil);
+    AssertException('No handler raises exception',EJSON,@CallNoHandler);
+    AssertException('No handler raises exception',EJSON,@CallNoHandlerStream);
+  finally
+    SetJSONParserHandler(H);
+  end;
+end;
+
+procedure TTestParser.TestHandlerResult;
+
+Var
+  D : TJSONData;
+
+begin
+  D:=GetJSON('"123"');
+  try
+    AssertEquals('Have correct string','123',D.AsString);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TTestParser.TestHandlerResultStream;
+Var
+  D : TJSONData;
+  S : TStream;
+
+begin
+  S:=TStringStream.Create('"123"');
+  try
+    D:=GetJSON(S);
+    try
+      AssertEquals('Have correct string','123',D.AsString);
+    finally
+      D.Free;
+    end;
+  finally
+    S.Free;
+  end;
+end;
+
 procedure TTestParser.DoTestError(S : String);
 
 Var

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

@@ -33,8 +33,8 @@ Type
   Private
     FWebHandler: TFPHTTPServerHandler;
   protected
-    Procedure InitRequest(ARequest : TFPHTTPConnectionRequest); virtual;
-    Procedure InitResponse(AResponse : TFPHTTPConnectionResponse); virtual;
+    Procedure InitRequest(ARequest : TFPHTTPConnectionRequest); override;
+    Procedure InitResponse(AResponse : TFPHTTPConnectionResponse); override;
     Property WebHandler : TFPHTTPServerHandler Read FWebHandler;
     Property Active;
   end;
@@ -44,9 +44,6 @@ Type
   { TFPHTTPServerHandler }
 
   TFPHTTPServerHandler = class(TWebHandler)
-    procedure HTTPHandleRequest(Sender: TObject;
-      var ARequest: TFPHTTPConnectionRequest;
-      var AResponse: TFPHTTPConnectionResponse);
   Private
     FOnRequestError: TRequestErrorHandler;
     FServer: TEmbeddedHTTPServer;
@@ -61,6 +58,7 @@ Type
     function GetLookupHostNames : Boolean;
     Procedure SetLookupHostnames(Avalue : Boolean);
   protected
+    procedure HTTPHandleRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse); virtual;
     procedure HandleRequestError(Sender: TObject; E: Exception); virtual;
     Procedure InitRequest(ARequest : TRequest); override;
     Procedure InitResponse(AResponse : TResponse); override;
@@ -69,6 +67,7 @@ Type
     Property HTTPServer : TEmbeddedHttpServer Read FServer;
   Public
     Procedure Run; override;
+    Procedure Terminate; override;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     // Port to listen on.
@@ -225,8 +224,6 @@ begin
     ARequest:=Nil;
     AResponse:=Nil;
   end;    
-  If Terminated And Assigned(FServer) then
-    FServer.Active:=False;
   if Assigned(OnIdle) then
     OnIdle(Self);
 end;
@@ -311,6 +308,13 @@ begin
   Fserver.Active:=True;
 end;
 
+procedure TFPHTTPServerHandler.Terminate;
+begin
+  Inherited;
+  if Assigned(FServer) then
+    Fserver.Active:=False;
+end;
+
 constructor TFPHTTPServerHandler.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
@@ -322,8 +326,11 @@ end;
 
 destructor TFPHTTPServerHandler.Destroy;
 begin
-  FServer.Active:=False;
-  FreeAndNil(FServer);
+  if Assigned(FServer) then
+    begin
+    FServer.Active:=False;
+    FreeAndNil(FServer);
+    end;
   inherited Destroy;
 
 end;

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

@@ -106,7 +106,7 @@ Type
     FOnLog : TLogEvent;
     FPreferModuleName : Boolean;
   protected
-    procedure Terminate;
+    procedure Terminate; virtual;
     Function GetModuleName(Arequest : TRequest) : string;
     function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; virtual; abstract;
     procedure EndRequest(ARequest : TRequest;AResponse : TResponse); virtual;

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

@@ -435,16 +435,20 @@ end;
 
 function TCustomWebAction.GetDisplayName: String;
 begin
-  If (FName='') then
-    FName:=ClassName+IntToStr(self.Index);
   Result:=FName;
+  If (Result='') then
+    begin
+    Result:=ClassName+IntToStr(self.Index);
+    if Result[1]='T' then
+      Delete(Result,1,1)
+    end;
 end;
 
 Function TCustomWebAction.GetNamePath : String;
 begin
- If (FName='') then
-    FName:=ClassName+IntToStr(self.Index);
   Result:=FName;
+  If (Result='') then
+    FName:=ClassName+IntToStr(self.Index);
 end;
 
 procedure TCustomWebAction.SetDisplayName(const AValue: String);

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

@@ -119,6 +119,7 @@ Type
     FServerBanner: string;
     FLookupHostNames,
     FThreaded: Boolean;
+    FConnectionCount : Integer;
     function GetActive: Boolean;
     procedure SetActive(const AValue: Boolean);
     procedure SetOnAllowConnect(const AValue: TConnectQuery);
@@ -126,13 +127,15 @@ Type
     procedure SetQueueSize(const AValue: Word);
     procedure SetThreaded(const AValue: Boolean);
     procedure SetupSocket;
-    procedure StartServerSocket;
+    procedure WaitForRequests;
   Protected
     // Override these to create descendents of the request/response instead.
     Function CreateRequest : TFPHTTPConnectionRequest; virtual;
     Function CreateResponse(ARequest : TFPHTTPConnectionRequest) : TFPHTTPConnectionResponse; virtual;
     Procedure InitRequest(ARequest : TFPHTTPConnectionRequest); virtual;
     Procedure InitResponse(AResponse : TFPHTTPConnectionResponse); virtual;
+    // Called on accept errors
+    procedure DoAcceptError(Sender: TObject; ASocket: Longint; E: Exception;  var ErrorAction: TAcceptErrorAction);
     // Create a connection handling object.
     function CreateConnection(Data : TSocketStream) : TFPHTTPConnection; virtual;
     // Create a connection handling thread.
@@ -143,13 +146,19 @@ Type
     Procedure DoConnect(Sender : TObject; Data : TSocketStream); virtual;
     // Create and configure TInetServer
     Procedure CreateServerSocket; virtual;
-    // Stop and free TInetServer
+    // Start server socket
+    procedure StartServerSocket; virtual;
+    // Stop server stocket
+    procedure StopServerSocket; virtual;
+    // free server socket instance
     Procedure FreeServerSocket; virtual;
     // Handle request. This calls OnRequest. It can be overridden by descendants to provide standard handling.
     procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
                             Var AResponse : TFPHTTPConnectionResponse); virtual;
     // Called when a connection encounters an unexpected error. Will call OnRequestError when set.
     procedure HandleRequestError(Sender: TObject; E: Exception); virtual;
+    // Connection count
+    Property ConnectionCount : Integer Read FConnectionCount;
   public
     Constructor Create(AOwner : TComponent); override;
     Destructor Destroy; override;
@@ -542,10 +551,14 @@ constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSoc
 begin
   FSocket:=ASocket;
   FServer:=AServer;
+  If Assigned(FServer) then
+    InterLockedIncrement(FServer.FConnectionCount)
 end;
 
 destructor TFPHTTPConnection.Destroy;
 begin
+  If Assigned(FServer) then
+    InterLockedDecrement(FServer.FConnectionCount);
   FreeAndNil(FSocket);
   Inherited;
 end;
@@ -634,6 +647,15 @@ begin
     end
 end;
 
+procedure TFPCustomHttpServer.DoAcceptError(Sender: TObject; ASocket: Longint;
+  E: Exception; var ErrorAction: TAcceptErrorAction);
+begin
+  If Not Active then
+    ErrorAction:=AEAStop
+  else
+    ErrorAction:=AEARaise
+end;
+
 function TFPCustomHttpServer.GetActive: Boolean;
 begin
   if (csDesigning in ComponentState) then
@@ -642,6 +664,11 @@ begin
     Result:=Assigned(FServer);
 end;
 
+procedure TFPCustomHttpServer.StopServerSocket;
+begin
+  FServer.StopAccepting(True);
+end;
+
 procedure TFPCustomHttpServer.SetActive(const AValue: Boolean);
 begin
   If AValue=GetActive then exit;
@@ -652,9 +679,10 @@ begin
       CreateServerSocket;
       SetupSocket;
       StartServerSocket;
+      FreeServerSocket;
       end
     else
-      FreeServerSocket;
+      StopServerSocket;
 end;
 
 procedure TFPCustomHttpServer.SetOnAllowConnect(const AValue: TConnectQuery);
@@ -758,6 +786,7 @@ begin
   FServer.MaxConnections:=-1;
   FServer.OnConnectQuery:=OnAllowConnect;
   FServer.OnConnect:=@DOConnect;
+  FServer.OnAcceptError:=@DoAcceptError;
 end;
 
 procedure TFPCustomHttpServer.StartServerSocket;
@@ -769,7 +798,6 @@ end;
 
 procedure TFPCustomHttpServer.FreeServerSocket;
 begin
-  FServer.StopAccepting;
   FreeAndNil(FServer);
 end;
 
@@ -788,9 +816,29 @@ begin
   FServerBanner := 'Freepascal';
 end;
 
+Procedure TFPCustomHttpServer.WaitForRequests;
+
+Var
+  FLastCount,ACount : Integer;
+
+begin
+  ACount:=0;
+  FLastCount:=FConnectionCount;
+  While (FConnectionCount>0) and (ACount<10) do
+    begin
+    Sleep(100);
+    if (FConnectionCount=FLastCount) then
+      Dec(ACount)
+    else
+      FLastCount:=FConnectionCount;
+    end;
+end;
+
 destructor TFPCustomHttpServer.Destroy;
 begin
   Active:=False;
+  if Threaded and (FConnectionCount>0) then
+    WaitForRequests;
   inherited Destroy;
 end;
 

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

@@ -111,6 +111,8 @@ Type
     procedure SetOnGetAction(const AValue: TGetActionEvent);
     procedure SetTemplate(const AValue: TFPTemplate);
   Protected
+    Function HandleActions(ARequest : TRequest): Boolean; virtual;
+    procedure DoOnRequest(ARequest: TRequest; AResponse: TResponse; var AHandled: Boolean); virtual;
     Procedure DoBeforeRequest(ARequest : TRequest); virtual;
     Procedure DoAfterResponse(AResponse : TResponse); virtual;
     Procedure GetParam(Const ParamName : String; Out Value : String); virtual; // Called by template
@@ -360,6 +362,11 @@ begin
     FTemplate.Assign(AValue);
 end;
 
+function TCustomFPWebModule.HandleActions(ARequest: TRequest): Boolean;
+begin
+  Result:=True;
+end;
+
 procedure TCustomFPWebModule.DoBeforeRequest(ARequest : TRequest);
 begin
   If Assigned(FBeforeRequest) then
@@ -435,6 +442,13 @@ begin
 end;
 
 
+procedure TCustomFPWebModule.DoOnRequest(ARequest: TRequest; AResponse: TResponse; Var AHandled : Boolean);
+
+begin
+  If Assigned(FOnRequest) then
+    FOnRequest(Self,ARequest,AResponse,AHandled);
+end;
+
 procedure TCustomFPWebModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
 
 Var
@@ -450,8 +464,7 @@ begin
   DoBeforeRequest(ARequest);
   B:=False;
   InitSession(AResponse);
-  If Assigned(FOnRequest) then
-    FOnRequest(Self,ARequest,AResponse,B);
+  DoOnRequest(ARequest,AResponse,B);
   If B then
     begin
     if not AResponse.ContentSent then
@@ -460,7 +473,7 @@ begin
   else
     if FTemplate.HasContent then
       GetTemplateContent(ARequest,AResponse)
-    else
+    else if HandleActions(ARequest) then
       begin
       Actions.HandleRequest(ARequest,AResponse,B);
       FTemplate.Template := '';//if apache mod, then need to clear for next call because it is a webmodule global property,
@@ -468,7 +481,6 @@ begin
       If Not B then
         Raise EFPWebError.Create(SErrRequestNotHandled);
       end;
-      
   DoAfterResponse(AResponse);
   UpdateSession(AResponse);
   FRequest := Nil;