--- Merging r31291 into '.':

U    packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31291 into '.':
 U   .
--- Merging r31292 into '.':
U    packages/fcl-json/src/jsonscanner.pp
U    packages/fcl-json/src/jsonparser.pp
U    packages/fcl-json/tests/testjson.lpi
U    packages/fcl-json/tests/testjsonconf.lpi
U    packages/fcl-json/tests/testjsonparser.pp
--- Recording mergeinfo for merge of r31292 into '.':
 G   .
--- Merging r31293 into '.':
G    packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31293 into '.':
 G   .
--- Merging r31435 into '.':
U    packages/fcl-json/tests/jsonconftest.pp
U    packages/fcl-json/tests/testjsonconf.pp
U    packages/fcl-json/src/fpjson.pp
G    packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31435 into '.':
 G   .
--- Merging r31436 into '.':
G    packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31436 into '.':
 G   .
--- Merging r32001 into '.':
G    packages/fcl-json/src/jsonscanner.pp
--- Recording mergeinfo for merge of r32001 into '.':
 G   .
--- Merging r32349 into '.':
U    packages/fcl-web/src/base/fphttpserver.pp
--- Recording mergeinfo for merge of r32349 into '.':
 G   .
--- Merging r32350 into '.':
U    packages/fcl-web/src/base/custcgi.pp
--- Recording mergeinfo for merge of r32350 into '.':
 G   .
--- Merging r32724 into '.':
U    packages/fcl-web/src/base/custfcgi.pp
--- Recording mergeinfo for merge of r32724 into '.':
 G   .
--- Merging r32731 into '.':
G    packages/fcl-web/src/base/custfcgi.pp
--- Recording mergeinfo for merge of r32731 into '.':
 G   .
--- Merging r32762 into '.':
U    packages/fcl-json/src/fpjsonrtti.pp
--- Recording mergeinfo for merge of r32762 into '.':
 G   .
--- Merging r32774 into '.':
G    packages/fcl-json/src/fpjson.pp
G    packages/fcl-json/src/jsonconf.pp
G    packages/fcl-json/src/fpjsonrtti.pp
G    packages/fcl-json/src/jsonscanner.pp
G    packages/fcl-json/src/jsonparser.pp
G    packages/fcl-json/tests/testjsonparser.pp
G    packages/fcl-json/tests/testjson.lpi
G    packages/fcl-json/tests/jsonconftest.pp
--- Recording mergeinfo for merge of r32774 into '.':
 G   .
--- Merging r32875 into '.':
G    packages/fcl-json/src/jsonscanner.pp
G    packages/fcl-json/src/jsonparser.pp
G    packages/fcl-json/tests/testjsonparser.pp
--- Recording mergeinfo for merge of r32875 into '.':
 G   .
--- Merging r32876 into '.':
U    packages/fcl-json/tests/testjsonrtti.pp
G    packages/fcl-json/tests/testjson.lpi
A    packages/fcl-json/tests/testcomps.pp
U    packages/fcl-json/tests/testjson.pp
G    packages/fcl-json/src/fpjsonrtti.pp
--- Recording mergeinfo for merge of r32876 into '.':
 G   .
--- Merging r32943 into '.':
A    packages/fcl-web/src/base/custapache24.pp
U    packages/fcl-web/src/base/fpapache.pp
A    packages/fcl-web/src/base/custapache.pp
U    packages/fcl-web/src/base/fpapache24.pp
U    packages/fcl-web/fpmake.pp
--- Recording mergeinfo for merge of r32943 into '.':
 G   .
--- Merging r32944 into '.':
G    packages/fcl-web/fpmake.pp
--- Recording mergeinfo for merge of r32944 into '.':
 G   .
--- Merging r33032 into '.':
U    packages/fcl-web/src/base/httpdefs.pp
--- Recording mergeinfo for merge of r33032 into '.':
 G   .
--- Merging r33124 into '.':
G    packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r33124 into '.':
 G   .
--- Merging r33168 into '.':
U    packages/fcl-web/src/base/fphttpclient.pp
--- Recording mergeinfo for merge of r33168 into '.':
 G   .
--- Merging r33293 into '.':
U    packages/fcl-web/src/base/restbase.pp
--- Recording mergeinfo for merge of r33293 into '.':
 G   .
--- Merging r33310 into '.':
U    packages/fcl-json/tests/testjsondata.pp
G    packages/fcl-json/src/fpjson.pp
--- Recording mergeinfo for merge of r33310 into '.':
 G   .
--- Merging r33364 into '.':
G    packages/fcl-web/src/base/fphttpserver.pp
--- Recording mergeinfo for merge of r33364 into '.':
 G   .

# revisions: 31291,31292,31293,31435,31436,32001,32349,32350,32724,32731,32762,32774,32875,32876,32943,32944,33032,33124,33168,33293,33310,33364

git-svn-id: branches/fixes_3_0@33396 -

.gitattributes

@@ -2467,6 +2467,7 @@ packages/fcl-json/src/jsonconf.pp svneol=native#text/plain
 packages/fcl-json/src/jsonparser.pp svneol=native#text/plain
 packages/fcl-json/src/jsonscanner.pp svneol=native#text/plain
 packages/fcl-json/tests/jsonconftest.pp svneol=native#text/plain
+packages/fcl-json/tests/testcomps.pp svneol=native#text/plain
 packages/fcl-json/tests/testjson.lpi svneol=native#text/plain
 packages/fcl-json/tests/testjson.pp svneol=native#text/plain
 packages/fcl-json/tests/testjsonconf.lpi svneol=native#text/plain
@@ -3115,6 +3116,8 @@ packages/fcl-web/src/base/Makefile.fpc svneol=native#text/plain
 packages/fcl-web/src/base/README.txt svneol=native#text/plain
 packages/fcl-web/src/base/cgiapp.pp svneol=native#text/plain
 packages/fcl-web/src/base/cgiprotocol.pp svneol=native#text/plain
+packages/fcl-web/src/base/custapache.pp svneol=native#text/plain
+packages/fcl-web/src/base/custapache24.pp svneol=native#text/plain
 packages/fcl-web/src/base/custcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/custfcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/custhttpapp.pp svneol=native#text/plain

packages/fcl-json/src/fpjson.pp

@@ -30,7 +30,8 @@ type
   TJSONInstanceType = (jitUnknown, jitNumberInteger,jitNumberInt64,jitNumberQWord,jitNumberFloat,
                        jitString, jitBoolean, jitNull, jitArray, jitObject);
   TJSONFloat = Double;
-  TJSONStringType = AnsiString;
+  TJSONStringType = UTF8String;
+  TJSONUnicodeStringType = Unicodestring;
   TJSONCharType = AnsiChar;
   PJSONCharType = ^TJSONCharType;
   TFormatOption = (foSingleLineArray,   // Array without CR/LF : all on one line
@@ -46,6 +47,9 @@ Const
   AsJSONFormat      = [foSingleLineArray,foSingleLineObject]; // These options make FormatJSON behave as AsJSON
   AsCompressedJSON  = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True
   AsCompactJSON     = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace,foDoNotQuoteMembers]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True and TJSONObject.UnquotedMemberNames=True
+  ValueJSONTypes    = [jtNumber, jtString, jtBoolean, jtNull];
+  ActualValueJSONTypes = ValueJSONTypes - [jtNull];
+  StructuredJSONTypes  = [jtArray,jtObject];
 
 Type
   TJSONData = Class;
@@ -96,6 +100,8 @@ Type
     function GetAsJSON: TJSONStringType; virtual; abstract;
     function GetAsString: TJSONStringType; virtual; abstract;
     procedure SetAsString(const AValue: TJSONStringType); virtual; abstract;
+    function GetAsUnicodeString: TJSONUnicodeStringType; virtual; 
+    procedure SetAsUnicodeString(const AValue: TJSONUnicodeStringType); virtual;
     function GetValue: variant; virtual; abstract;
     procedure SetValue(const AValue: variant); virtual; abstract;
     function GetItem(Index : Integer): TJSONData; virtual;
@@ -119,6 +125,7 @@ Type
     property Items[Index: Integer]: TJSONData read GetItem write SetItem;
     property Value: variant read GetValue write SetValue;
     Property AsString : TJSONStringType Read GetAsString Write SetAsString;
+    Property AsUnicodeString : TJSONUnicodeStringType Read GetAsUnicodeString Write SetAsUnicodeString;
     Property AsFloat : TJSONFloat Read GetAsFloat Write SetAsFloat;
     Property AsInteger : Integer Read GetAsInteger Write SetAsInteger;
     Property AsInt64 : Int64 Read GetAsInt64 Write SetAsInt64;
@@ -278,6 +285,7 @@ Type
     procedure SetAsString(const AValue: TJSONStringType); override;
   public
     Constructor Create(const AValue : TJSONStringType); reintroduce;
+    Constructor Create(const AValue : TJSONUnicodeStringType); reintroduce;
     class function JSONType: TJSONType; override;
     Procedure Clear;  override;
     Function Clone : TJSONData; override;
@@ -358,6 +366,7 @@ Type
     function GetObjects(Index : Integer): TJSONObject;
     function GetQWords(Index : Integer): QWord;
     function GetStrings(Index : Integer): TJSONStringType;
+    function GetUnicodeStrings(Index : Integer): TJSONUnicodeStringType;
     function GetTypes(Index : Integer): TJSONType;
     procedure SetArrays(Index : Integer; const AValue: TJSONArray);
     procedure SetBooleans(Index : Integer; const AValue: Boolean);
@@ -367,6 +376,7 @@ Type
     procedure SetObjects(Index : Integer; const AValue: TJSONObject);
     procedure SetQWords(Index : Integer; AValue: QWord);
     procedure SetStrings(Index : Integer; const AValue: TJSONStringType);
+    procedure SetUnicodeStrings(Index : Integer; const AValue: TJSONUnicodeStringType);
   protected
     Function DoFindPath(Const APath : TJSONStringType; Out NotFound : TJSONStringType) : TJSONdata; override;
     Procedure Converterror(From : Boolean);
@@ -406,6 +416,7 @@ Type
     function Add(I : Int64): Int64;
     function Add(I : QWord): QWord;
     function Add(const S : String): Integer;
+    function Add(const S : UnicodeString): Integer;
     function Add: Integer;
     function Add(F : TJSONFloat): Integer;
     function Add(B : Boolean): Integer;
@@ -421,6 +432,7 @@ Type
     procedure Insert(Index: Integer; I : Int64);
     procedure Insert(Index: Integer; I : QWord);
     procedure Insert(Index: Integer; const S : String);
+    procedure Insert(Index: Integer; const S : UnicodeString);
     procedure Insert(Index: Integer; F : TJSONFloat);
     procedure Insert(Index: Integer; B : Boolean);
     procedure Insert(Index: Integer; AnArray : TJSONArray);
@@ -436,6 +448,7 @@ Type
     Property Int64s[Index : Integer] : Int64 Read GetInt64s Write SetInt64s;
     Property QWords[Index : Integer] : QWord Read GetQWords Write SetQWords;
     Property Strings[Index : Integer] : TJSONStringType Read GetStrings Write SetStrings;
+    Property UnicodeStrings[Index : Integer] : TJSONUnicodeStringType Read GetUnicodeStrings Write SetUnicodeStrings;
     Property Floats[Index : Integer] : TJSONFloat Read GetFloats Write SetFloats;
     Property Booleans[Index : Integer] : Boolean Read GetBooleans Write SetBooleans;
     Property Arrays[Index : Integer] : TJSONArray Read GetArrays Write SetArrays;
@@ -471,6 +484,7 @@ Type
     function GetObjects(const AName : String): TJSONObject;
     function GetQWords(AName : String): QWord;
     function GetStrings(const AName : String): TJSONStringType;
+    function GetUnicodeStrings(const AName : String): TJSONUnicodeStringType;
     function GetTypes(const AName : String): TJSONType;
     procedure SetArrays(const AName : String; const AValue: TJSONArray);
     procedure SetBooleans(const AName : String; const AValue: Boolean);
@@ -482,6 +496,7 @@ Type
     procedure SetObjects(const AName : String; const AValue: TJSONObject);
     procedure SetQWords(AName : String; AValue: QWord);
     procedure SetStrings(const AName : String; const AValue: TJSONStringType);
+    procedure SetUnicodeStrings(const AName : String; const AValue: TJSONUnicodeStringType);
     class function GetUnquotedMemberNames: Boolean; static;
     class procedure SetUnquotedMemberNames(AValue: Boolean); static;
   protected
@@ -526,7 +541,8 @@ Type
     Function Get(Const AName : String; ADefault : Int64) : Int64;
     Function Get(Const AName : String; ADefault : QWord) : QWord;
     Function Get(Const AName : String; ADefault : Boolean) : Boolean;
-    Function Get(Const AName : String; ADefault : TJSONStringType) : TJSONStringTYpe;
+    Function Get(Const AName : String; ADefault : TJSONStringType) : TJSONStringType;
+    Function Get(Const AName : String; ADefault : TJSONUnicodeStringType) : TJSONUnicodeStringType;
     Function Get(Const AName : String; ADefault : TJSONArray) : TJSONArray;
     Function Get(Const AName : String; ADefault : TJSONObject) : TJSONObject;
     // Manipulate
@@ -535,6 +551,7 @@ Type
     function Add(const AName: TJSONStringType; AValue: Boolean): Integer; overload;
     function Add(const AName: TJSONStringType; AValue: TJSONFloat): Integer; overload;
     function Add(const AName, AValue: TJSONStringType): Integer; overload;
+    function Add(const AName : String; AValue: TJSONUnicodeStringType): Integer; overload;
     function Add(const AName: TJSONStringType; Avalue: Integer): Integer; overload;
     function Add(const AName: TJSONStringType; Avalue: Int64): Integer; overload;
     function Add(const AName: TJSONStringType; Avalue: QWord): Integer; overload;
@@ -557,6 +574,7 @@ Type
     Property Int64s[AName : String] : Int64 Read GetInt64s Write SetInt64s;
     Property QWords[AName : String] : QWord Read GetQWords Write SetQWords;
     Property Strings[AName : String] : TJSONStringType Read GetStrings Write SetStrings;
+    Property UnicodeStrings[AName : String] : TJSONUnicodeStringType Read GetUnicodeStrings Write SetUnicodeStrings;
     Property Booleans[AName : String] : Boolean Read GetBooleans Write SetBooleans;
     Property Arrays[AName : String] : TJSONArray Read GetArrays Write SetArrays;
     Property Objects[AName : String] : TJSONObject Read GetObjects Write SetObjects;
@@ -582,6 +600,7 @@ Function CreateJSON(Data : Int64) : TJSONInt64Number;
 Function CreateJSON(Data : QWord) : TJSONQWordNumber;
 Function CreateJSON(Data : TJSONFloat) : TJSONFloatNumber;
 Function CreateJSON(Data : TJSONStringType) : TJSONString;
+Function CreateJSON(Data : TJSONUnicodeStringType) : TJSONString;
 Function CreateJSONArray(Data : Array of const) : TJSONArray;
 Function CreateJSONObject(Data : Array of const) : TJSONObject;
 
@@ -644,11 +663,12 @@ begin
   Result:=DefaultJSONInstanceTypes[AType]
 end;
 
-Function StringToJSONString(const S : TJSONStringType) : TJSONStringType;
+function StringToJSONString(const S: TJSONStringType): TJSONStringType;
 
 Var
   I,J,L : Integer;
   P : PJSONCharType;
+  C : AnsiChar;
 
 begin
   I:=1;
@@ -658,10 +678,11 @@ begin
   P:=PJSONCharType(S);
   While I<=L do
     begin
-    if (AnsiChar(P^) in ['"','/','\',#8,#9,#10,#12,#13]) then
+    C:=AnsiChar(P^);
+    if (C in ['"','/','\',#0..#31]) then
       begin
       Result:=Result+Copy(S,J,I-J);
-      Case P^ of
+      Case C of
         '\' : Result:=Result+'\\';
         '/' : Result:=Result+'\/';
         '"' : Result:=Result+'\"';
@@ -670,6 +691,8 @@ begin
         #10 : Result:=Result+'\n';
         #12 : Result:=Result+'\f';
         #13 : Result:=Result+'\r';
+      else
+        Result:=Result+'\u'+HexStr(Ord(C),4);
       end;
       J:=I+1;
       end;
@@ -679,7 +702,7 @@ begin
   Result:=Result+Copy(S,J,I-1);
 end;
 
-Function JSONStringToString(const S : TJSONStringType) : TJSONStringType;
+function JSONStringToString(const S: TJSONStringType): TJSONStringType;
 
 Var
   I,J,L : Integer;
@@ -765,6 +788,11 @@ begin
   Result:=TJSONStringCLass(DefaultJSONInstanceTypes[jitString]).Create(Data);
 end;
 
+function CreateJSON(Data: TJSONUnicodeStringType): TJSONString;
+begin
+  Result:=TJSONStringCLass(DefaultJSONInstanceTypes[jitString]).Create(Data);
+end;
+
 function CreateJSONArray(Data: array of const): TJSONArray;
 begin
   Result:=TJSONArrayCLass(DefaultJSONInstanceTypes[jitArray]).Create(Data);
@@ -778,7 +806,8 @@ end;
 Var
   JPH : TJSONParserHandler;
 
-function GetJSON(const JSON: TJSONStringType; Const UseUTF8: Boolean): TJSONData;
+function GetJSON(const JSON: TJSONStringType; const UseUTF8: Boolean
+  ): TJSONData;
 
 Var
   SS : TStringStream;
@@ -791,7 +820,7 @@ begin
   end;
 end;
 
-function GetJSON(Const JSON: TStream; Const UseUTF8: Boolean): TJSONData;
+function GetJSON(const JSON: TStream; const UseUTF8: Boolean): TJSONData;
 
 begin
   Result:=Nil;
@@ -1008,6 +1037,17 @@ end;
 
 { TJSONData }
 
+function TJSONData.GetAsUnicodeString: TJSONUnicodeStringType; 
+
+begin
+  Result:=UTF8Decode(AsString);
+end;
+
+procedure TJSONData.SetAsUnicodeString(const AValue: TJSONUnicodeStringType); 
+
+begin
+  AsString:=UTF8Encode(AValue);
+end;
 
 function TJSONData.GetItem(Index : Integer): TJSONData;
 begin
@@ -1133,7 +1173,7 @@ end;
 function TJSONData.FindPath(const APath: TJSONStringType): TJSONdata;
 
 Var
-  M : String;
+  M : TJSONStringType;
 
 begin
   Result:=DoFindPath(APath,M);
@@ -1142,7 +1182,7 @@ end;
 function TJSONData.GetPath(const APath: TJSONStringType): TJSONdata;
 
 Var
-  M : String;
+  M : TJSONStringType;
 begin
   Result:=DoFindPath(APath,M);
   If Result=Nil then
@@ -1283,6 +1323,11 @@ begin
   FValue:=AValue;
 end;
 
+constructor TJSONString.Create(const AValue: TJSONUnicodeStringType);
+begin
+  FValue:=UTF8Encode(AValue);
+end;
+
 { TJSONboolean }
 
 
@@ -1380,6 +1425,7 @@ begin
   FValue:=StrToBool(AValue);
 end;
 
+
 constructor TJSONBoolean.Create(AValue: Boolean);
 begin
   FValue:=AValue;
@@ -1466,6 +1512,7 @@ begin
   ConvertError(True);
 end;
 
+
 function TJSONNull.GetValue: variant;
 begin
   Result:=variants.Null;
@@ -1561,16 +1608,15 @@ begin
 end;
 
 procedure TJSONFloatNumber.SetAsString(const AValue: TJSONStringType);
-
 Var
   C : Integer;
-
 begin
   Val(AValue,FValue,C);
   If (C<>0) then
     Raise EConvertError.CreateFmt(SErrInvalidFloat,[AValue]);
 end;
 
+
 function TJSONFloatNumber.GetValue: variant;
 begin
   Result:=FValue;
@@ -1669,6 +1715,7 @@ begin
   FValue:=StrToInt(AValue);
 end;
 
+
 function TJSONIntegerNumber.GetValue: variant;
 begin
   Result:=FValue;
@@ -1845,6 +1892,11 @@ begin
   Result:=Items[Index].AsString;
 end;
 
+function TJSONArray.GetUnicodeStrings(Index : Integer): TJSONUnicodeStringType;
+begin
+  Result:=Items[Index].AsUnicodeString;
+end;
+
 function TJSONArray.GetTypes(Index : Integer): TJSONType;
 begin
   Result:=Items[Index].JSONType;
@@ -1891,6 +1943,12 @@ begin
   Items[Index]:=CreateJSON(AValue);
 end;
 
+procedure TJSONArray.SetUnicodeStrings(Index: Integer;
+  const AValue: TJSONUnicodeStringType);
+begin
+  Items[Index]:=CreateJSON(AValue);
+end;
+
 function TJSONArray.DoFindPath(const APath: TJSONStringType; out
   NotFound: TJSONStringType): TJSONdata;
 
@@ -2223,6 +2281,11 @@ begin
   Result:=Add(CreateJSON(S));
 end;
 
+function TJSONArray.Add(const S: UnicodeString): Integer;
+begin
+  Result:=Add(CreateJSON(S));
+end;
+
 function TJSONArray.Add: Integer;
 begin
   Result:=Add(CreateJSON);
@@ -2302,6 +2365,11 @@ begin
   FList.Insert(Index, CreateJSON(S));
 end;
 
+procedure TJSONArray.Insert(Index: Integer; const S: UnicodeString);
+begin
+  FList.Insert(Index, CreateJSON(S));
+end;
+
 procedure TJSONArray.Insert(Index: Integer; F: TJSONFloat);
 begin
   FList.Insert(Index, CreateJSON(F));
@@ -2400,6 +2468,12 @@ begin
   Result:=GetElements(AName).AsString;
 end;
 
+function TJSONObject.GetUnicodeStrings(const AName: String
+  ): TJSONUnicodeStringType;
+begin
+  Result:=GetElements(AName).AsUnicodeString;
+end;
+
 function TJSONObject.GetTypes(const AName : String): TJSONType;
 begin
   Result:=Getelements(Aname).JSONType;
@@ -2467,7 +2541,13 @@ end;
 
 procedure TJSONObject.SetStrings(const AName : String; const AValue: TJSONStringType);
 begin
-  SetElements(AName,CreateJSON(AVAlue));
+  SetElements(AName,CreateJSON(AValue));
+end;
+
+procedure TJSONObject.SetUnicodeStrings(const AName: String;
+  const AValue: TJSONUnicodeStringType);
+begin
+  SetElements(AName,CreateJSON(AValue));
 end;
 
 class procedure TJSONObject.DetermineElementQuotes;
@@ -2826,6 +2906,12 @@ begin
   Result:=Add(AName,CreateJSON(AValue));
 end;
 
+function TJSONObject.Add(const AName: String; AValue: TJSONUnicodeStringType
+  ): Integer;
+begin
+  Result:=Add(AName,CreateJSON(AValue));
+end;
+
 function TJSONObject.Add(const AName: TJSONStringType; Avalue: Integer): Integer;
 begin
   Result:=Add(AName,CreateJSON(AValue));
@@ -2970,7 +3056,7 @@ begin
 end;
 
 function TJSONObject.Get(const AName: String; ADefault: TJSONStringType
-  ): TJSONStringTYpe;
+  ): TJSONStringType;
 Var
   D : TJSONData;
 
@@ -2982,6 +3068,19 @@ begin
     Result:=ADefault;
 end;
 
+function TJSONObject.Get(const AName: String; ADefault: TJSONUnicodeStringType
+  ): TJSONUnicodeStringType;
+Var
+  D : TJSONData;
+
+begin
+  D:=Find(AName,jtString);
+  If (D<>Nil) then
+    Result:=D.AsUnicodeString
+  else
+    Result:=ADefault;
+end;
+
 function TJSONObject.Get(const AName: String; ADefault: TJSONArray
   ): TJSONArray;
 Var

packages/fcl-json/src/fpjsonrtti.pp

@@ -5,7 +5,12 @@ unit fpjsonrtti;
 interface
 
 uses
-  Classes, SysUtils, typinfo, fpjson, rttiutils, jsonparser;
+  Classes, SysUtils, contnrs, typinfo, fpjson, rttiutils, jsonparser;
+
+Const
+  RFC3339DateTimeFormat = 'yyyy"-"mm"-"dd"T"hh":"nn":"ss';
+  RFC3339DateTimeFormatMsec = RFC3339DateTimeFormat+'.zzz';
+  
 
 Type
 
@@ -22,7 +27,8 @@ Type
                        jsoTStringsAsObject,       // Stream TStrings as an object : string = { object }
                        jsoDateTimeAsString,       // Format a TDateTime value as a string
                        jsoUseFormatString,        // Use FormatString when creating JSON strings.
-                       jsoCheckEmptyDateTime);    // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string
+                       jsoCheckEmptyDateTime,     // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string
+                       jsoLegacyDateTime);         // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value.
   TJSONStreamOptions = Set of TJSONStreamOption;
 
   TJSONFiler = Class(TComponent)
@@ -62,6 +68,8 @@ Type
     Function ObjectToJSON(Const AObject : TObject) : TJSONObject;
     // Stream a collection - always returns an array
     function StreamCollection(Const ACollection: TCollection): TJSONArray;
+    // Stream an objectlist - always returns an array
+    function StreamObjectList(Const AnObjectList: TObjectList): TJSONArray;
     // Stream a TStrings instance as an array
     function StreamTStringsArray(Const AStrings: TStrings): TJSONArray;
     // Stream a TStrings instance as an object
@@ -100,16 +108,25 @@ Type
   TJSONRestorePropertyEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; AValue : TJSONData; Var Handled : Boolean) of object;
   TJSONPropertyErrorEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; AValue : TJSONData; Error : Exception; Var Continue : Boolean) of object;
   TJSONGetObjectEvent = Procedure (Sender : TOBject; AObject : TObject; Info : PPropInfo; AData : TJSONObject; DataName : TJSONStringType; Var AValue : TObject);
+  TJSONDestreamOption = (jdoCaseInsensitive,jdoIgnorePropertyErrors);
+  TJSONDestreamOptions = set of TJSONDestreamOption;
+
   TJSONDeStreamer = Class(TJSONFiler)
   private
     FAfterReadObject: TJSONStreamEvent;
     FBeforeReadObject: TJSONStreamEvent;
+    FDateTimeFormat: String;
     FOnGetObject: TJSONGetObjectEvent;
     FOnPropError: TJSONpropertyErrorEvent;
     FOnRestoreProp: TJSONRestorePropertyEvent;
     FCaseInsensitive : Boolean;
+    FOptions: TJSONDestreamOptions;
     procedure DeStreamClassProperty(AObject: TObject; PropInfo: PPropInfo; PropData: TJSONData);
+    function GetCaseInsensitive: Boolean;
+    procedure SetCaseInsensitive(AValue: Boolean);
   protected
+    // Try to parse a date.
+    Function ExtractDateTime(S : String): TDateTime;
     function GetObject(AInstance : TObject; const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo): TObject;
     procedure DoRestoreProperty(AObject: TObject; PropInfo: PPropInfo;  PropData: TJSONData); virtual;
     Function ObjectFromString(Const JSON : TJSONStringType) : TJSONData; virtual;
@@ -141,7 +158,12 @@ Type
     // Published Properties of the instance will be further restored with available data.
     Property OngetObject : TJSONGetObjectEvent Read FOnGetObject Write FOnGetObject;
     // JSON is by definition case sensitive. Should properties be looked up case-insentive ?
-    Property CaseInsensitive : Boolean Read FCaseInsensitive Write FCaseInsensitive;
+    Property CaseInsensitive : Boolean Read GetCaseInsensitive Write SetCaseInsensitive ; deprecated;
+    // DateTime format. If not set, RFC3339DateTimeFormat is assumed.
+    // If set, it will be used as an argument to ScanDateTime. If that fails, StrToDateTime is used.
+    Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat;
+    // Options overning the behaviour
+    Property Options : TJSONDestreamOptions Read FOptions Write FOptions;
   end;
 
   EJSONRTTI = Class(Exception);
@@ -149,7 +171,7 @@ Type
 
 implementation
 
-uses variants;
+uses dateutils, variants, rtlconsts;
 
 ResourceString
   SErrUnknownPropertyKind     = 'Unknown property kind for property : "%s"';
@@ -205,7 +227,8 @@ begin
   inherited Destroy;
 end;
 
-procedure TJSONDeStreamer.JSONToObject(Const JSON: TJSONStringType; AObject: TObject);
+procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONStringType;
+  AObject: TObject);
 
 Var
   D : TJSONData;
@@ -233,7 +256,7 @@ begin
   end;
 end;
 
-Function TJSONDeStreamer.JSONToVariant(Data : TJSONData) : Variant;
+function TJSONDeStreamer.JSONToVariant(Data: TJSONData): Variant;
 
 Var
   I : integer;
@@ -306,6 +329,48 @@ begin
     end;
 end;
 
+function TJSONDeStreamer.GetCaseInsensitive: Boolean;
+begin
+  Result:=jdoCaseInsensitive in Options;
+end;
+
+procedure TJSONDeStreamer.SetCaseInsensitive(AValue: Boolean);
+begin
+  if AValue then
+    Include(Foptions,jdoCaseInsensitive)
+  else
+    Exclude(Foptions,jdoCaseInsensitive);
+end;
+
+function TJSONDeStreamer.ExtractDateTime(S: String): TDateTime;
+
+Var
+  Fmt : String;
+  E,fmtSpecified : Boolean;
+
+begin
+  E:=False;
+  FMT:=DateTimeFormat;
+  fmtSpecified:=Fmt<>'';
+  if Not fmtSpecified then
+    FMT:=RFC3339DateTimeFormat;
+  Try
+    // No TryScanDateTime
+    Result:=ScanDatetime(FMT,S);
+  except
+    if fmtSpecified then
+      Raise
+    else
+      E:=True;
+  end;
+  if E then
+    if not TryStrToDateTime(S,Result) then
+      if not TryStrToDate(S,Result) then
+        if not TryStrToTime(S,Result) then
+          Raise EConvertError.CreateFmt(SInvalidDateTime,[S]);
+//  ExtractDateTime(PropData.AsString)
+end;
+
 procedure TJSONDeStreamer.RestoreProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData);
 
 Var
@@ -329,7 +394,9 @@ begin
         FOnPropError(Self,AObject,PropInfo,PropData,E,B);
         If Not B then
           Raise;
-        end;
+        end
+      else if Not (jdoIgnorePropertyErrors in Options) then
+        Raise;
   end;
 end;
 
@@ -365,7 +432,7 @@ begin
     tkFloat :
       begin
       if (TI=TypeInfo(TDateTime)) and (PropData.JSONType=jtString) then
-        SetFloatProp(AObject,PI,StrToDateTime(PropData.AsString))
+        SetFloatProp(AObject,PI,ExtractDateTime(PropData.AsString))
       else
         SetFloatProp(AObject,PI,PropData.AsFloat)
       end;
@@ -398,7 +465,7 @@ begin
     tkAString:
       SetStrProp(AObject,PI,PropData.AsString);
     tkWString :
-      SetWideStrProp(AObject,PI,PropData.AsString);
+      SetWideStrProp(AObject,PI,PropData.AsUnicodeString);
     tkVariant:
       SetVariantProp(AObject,PI,JSONToVariant(PropData));
     tkClass:
@@ -423,7 +490,7 @@ begin
     tkMethod :
       Error(SErrUnsupportedPropertyKind,[PI^.Name]);
     tkUString :
-      SetUnicodeStrProp(AObject,PI,PropData.AsString);
+      SetUnicodeStrProp(AObject,PI,PropData.AsUnicodeString);
     tkUChar:
       begin
       JS:=PropData.asString;
@@ -433,7 +500,8 @@ begin
   end;
 end;
 
-procedure TJSONDeStreamer.JSONToObject(Const JSON: TJSONObject; AObject: TObject);
+procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONObject; AObject: TObject
+  );
 Var
   I,J : Integer;
   PIL : TPropInfoList;
@@ -514,7 +582,9 @@ begin
   end;
 end;
 
-Function TJSONDeStreamer.GetObject(AInstance : TObject; Const APropName : TJSONStringType; D : TJSONObject; PropInfo : PPropInfo) : TObject;
+function TJSONDeStreamer.GetObject(AInstance: TObject;
+  const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo
+  ): TObject;
 
 Var
   C : TClass;
@@ -669,6 +739,8 @@ begin
       Result.Add('Strings',StreamTStrings(Tstrings(AObject)))
     else If AObject is TCollection then
       Result.Add('Items',StreamCollection(TCollection(AObject)))
+    else If AObject is TObjectList then
+      Result.Add('Objects',StreamObjectList(TObjectList(AObject)))
     else
       begin
       PIL:=TPropInfoList.Create(AObject,tkProperties);
@@ -889,7 +961,24 @@ begin
   end;
 end;
 
-Function TJSONStreamer.StreamClassProperty(Const AObject : TObject): TJSONData;
+function TJSONStreamer.StreamObjectList(const AnObjectList: TObjectList): TJSONArray;
+Var
+  I : Integer;
+
+begin
+  if not Assigned(AnObjectList) then
+    Result:=Nil;
+  Result:=TJSONArray.Create;
+  try
+    For I:=0 to AnObjectList.Count-1 do
+      Result.Add(ObjectToJSON(AnObjectList.Items[i]));
+  except
+    FreeAndNil(Result);
+    Raise;
+  end;
+end;
+
+function TJSONStreamer.StreamClassProperty(const AObject: TObject): TJSONData;
 
 Var
   C : TCollection;
@@ -910,6 +999,8 @@ begin
     Result:=StreamTStrings(TStrings(AObject))
   else if (AObject is TCollection) then
     Result:=StreamCollection(TCollection(Aobject))
+  else If AObject is TObjectList then
+    Result:=StreamObjectList(TObjectList(AObject))
   else // Normally, this is only TPersistent.
     Result:=ObjectToJSON(AObject);
 end;
@@ -980,7 +1071,8 @@ begin
       Result:=TJSONInt64Number.Create(GetOrdProp(AObject,PropertyInfo));
     tkQWord :
       Result:=TJSONFloatNumber.Create(GetOrdProp(AObject,PropertyInfo));
-    tkObject,
+    tkObject :
+      Result:=ObjectToJSON(GetObjectProp(AObject,PropertyInfo));
     tkArray,
     tkRecord,
     tkInterface,
@@ -1008,12 +1100,18 @@ begin
     S:=''
   else if (DateTimeFormat<>'') then
     S:=FormatDateTime(DateTimeFormat,DateTime)
-  else if Frac(DateTime)=0 then
-    S:=DateToStr(DateTime)
-  else if Trunc(DateTime)=0 then
-    S:=TimeToStr(DateTime)
+  else if (jsoLegacyDateTime in options) then  
+    begin
+    if Frac(DateTime)=0 then
+      S:=DateToStr(DateTime)
+    else if Trunc(DateTime)=0 then
+      S:=TimeToStr(DateTime)
+    else
+      S:=DateTimeToStr(DateTime);
+    end
   else
-    S:=DateTimeToStr(DateTime);
+    S:=FormatDateTime(RFC3339DateTimeFormat,DateTime);
+     
   Result:=TJSONString.Create(S);
 end;
 

packages/fcl-json/src/jsonconf.pp

@@ -28,14 +28,13 @@ unit jsonConf;
 interface
 
 uses
-  SysUtils, Classes, fpjson, jsonparser;
+  SysUtils, Classes, fpjson, jsonscanner, jsonparser;
 
-resourcestring
-  SWrongRootName = 'XML file has wrong root element name';
+Const
+  DefaultJSONOptions = [joUTF8,joComments];
 
 type
   EJSONConfigError = class(Exception);
-  TPathFlags = set of (pfHasValue, pfWriteAccess);
 
 (* ********************************************************************
    "APath" is the path and name of a value: A JSON configuration file 
@@ -60,9 +59,11 @@ type
     FFormatIndentSize: Integer;
     FFormatoptions: TFormatOptions;
     FFormatted: Boolean;
+    FJSONOptions: TJSONOptions;
     FKey: TJSONObject;
     procedure DoSetFilename(const AFilename: String; ForceReload: Boolean);
     procedure SetFilename(const AFilename: String);
+    procedure SetJSONOptions(AValue: TJSONOptions);
     Function StripSlash(Const P : UnicodeString) : UnicodeString;
   protected
     FJSON: TJSONObject;
@@ -70,9 +71,9 @@ type
     procedure Loaded; override;
     function FindPath(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject;
     function FindObject(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject;
-    function FindObject(Const APath: UnicodeString; AllowCreate : Boolean;Var ElName : UnicodeString) : TJSONObject;
-    function FindElement(Const APath: UnicodeString; CreateParent : Boolean) : TJSONData;
-    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; Var AParent : TJSONObject; Var ElName : UnicodeString) : TJSONData;
+    function FindObject(Const APath: UnicodeString; AllowCreate : Boolean;Out ElName : UnicodeString) : TJSONObject;
+    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; AllowObject : Boolean = False) : TJSONData;
+    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; out AParent : TJSONObject; Out ElName : UnicodeString; AllowObject : Boolean = False) : TJSONData;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
@@ -90,11 +91,14 @@ type
     function  GetValue(const APath: UnicodeString; ADefault: Int64): Int64; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Double): Double; overload;
+    Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: String) : Boolean; overload;
+    Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: TStrings): Boolean; overload;
     procedure SetValue(const APath: UnicodeString; const AValue: UnicodeString); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Integer); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Int64); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Boolean); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Double); overload;
+    procedure SetValue(const APath: UnicodeString; AValue: TStrings; AsObject : Boolean = False); overload;
 
     procedure SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString); overload;
     procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Integer); overload;
@@ -109,6 +113,7 @@ type
     Property Formatted : Boolean Read FFormatted Write FFormatted;
     Property FormatOptions : TFormatOptions Read FFormatoptions Write FFormatOptions Default DefaultFormat;
     Property FormatIndentsize : Integer Read FFormatIndentSize Write FFormatIndentSize Default DefaultIndentSize;
+    Property JSONOptions : TJSONOptions Read FJSONOptions Write SetJSONOptions Default DefaultJSONOptions;
   end;
 
 
@@ -116,7 +121,7 @@ type
 
 implementation
 
-Const
+Resourcestring
   SErrInvalidJSONFile = '"%s" is not a valid JSON configuration file.';
   SErrCouldNotOpenKey = 'Could not open key "%s".';
 
@@ -127,6 +132,7 @@ begin
   FKey:=FJSON;
   FFormatOptions:=DefaultFormat;
   FFormatIndentsize:=DefaultIndentSize;
+  FJSONOptions:=DefaultJSONOptions;
 end;
 
 destructor TJSONConfig.Destroy;
@@ -181,7 +187,7 @@ begin
 end;
 
 function TJSONConfig.FindObject(const APath: UnicodeString; AllowCreate: Boolean;
-  var ElName: UnicodeString): TJSONObject;
+  out ElName: UnicodeString): TJSONObject;
 
 Var
   S,El : UnicodeString;
@@ -206,7 +212,7 @@ begin
         If (Result.Count=0) then
           I:=-1
         else
-          I:=Result.IndexOfName(El);
+          I:=Result.IndexOfName(UTF8Encode(El));
         If (I=-1) then
           // No element with this name.
           begin
@@ -215,7 +221,7 @@ begin
             // Create new node.
             T:=Result;
             Result:=TJSonObject.Create;
-            T.Add(El,Result);
+            T.Add(UTF8Encode(El),Result);
             end
           else
             Result:=Nil
@@ -224,7 +230,7 @@ begin
           // Node found, check if it is an object
           begin
           if (Result.Items[i].JSONtype=jtObject) then
-            Result:=Result.Objects[el]
+            Result:=Result.Objects[UTF8Encode(el)]
           else
             begin
 //            Writeln(el,' type wrong');
@@ -234,7 +240,7 @@ begin
               Result.Delete(I);
               T:=Result;
               Result:=TJSonObject.Create;
-              T.Add(El,Result);
+              T.Add(UTF8Encode(El),Result);
               end
             else
               Result:=Nil
@@ -247,20 +253,19 @@ begin
   ElName:=S;
 end;
 
-function TJSONConfig.FindElement(const APath: UnicodeString; CreateParent: Boolean
-  ): TJSONData;
+function TJSONConfig.FindElement(const APath: UnicodeString; CreateParent: Boolean; AllowObject : Boolean = False): TJSONData;
 
 Var
   O : TJSONObject;
   ElName : UnicodeString;
   
 begin
-  Result:=FindElement(APath,CreateParent,O,ElName);
+  Result:=FindElement(APath,CreateParent,O,ElName,AllowObject);
 end;
 
 function TJSONConfig.FindElement(const APath: UnicodeString;
-  CreateParent: Boolean; var AParent: TJSONObject; var ElName: UnicodeString
-  ): TJSONData;
+  CreateParent: Boolean; out AParent: TJSONObject; out ElName: UnicodeString;
+  AllowObject : Boolean = False): TJSONData;
 
 Var
   I : Integer;
@@ -271,11 +276,12 @@ begin
   If Assigned(Aparent) then
     begin
 //    Writeln('Found parent, looking for element:',elName);
-    I:=AParent.IndexOfName(ElName);
+    I:=AParent.IndexOfName(UTF8Encode(ElName));
 //    Writeln('Element index is',I);
-    If (I<>-1) And (AParent.items[I].JSONType<>jtObject) then
+    If (I<>-1) And ((AParent.items[I].JSONType<>jtObject) or AllowObject) then
       Result:=AParent.Items[i];
     end;
+//  Writeln('Find ',aPath,' in "',FJSON.AsJSOn,'" : ',Elname,' : ',Result<>NIl);
 end;
 
 
@@ -287,7 +293,7 @@ var
 begin
   El:=FindElement(StripSlash(APath),False);
   If Assigned(El) then
-    Result:=El.AsString
+    Result:=El.AsUnicodeString
   else
     Result:=ADefault;
 end;
@@ -350,6 +356,44 @@ begin
     Result:=StrToFloatDef(El.AsString,ADefault);
 end;
 
+function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings;
+  const ADefault: String): Boolean;
+var
+  El : TJSONData;
+  D : TJSONEnum;
+
+begin
+  AValue.Clear;
+  El:=FindElement(StripSlash(APath),False,True);
+  Result:=Assigned(el);
+  If Not Result then
+    begin
+    AValue.Text:=ADefault;
+    exit;
+    end;
+  Case El.JSONType of
+    jtArray:
+      For D in El do
+        if D.Value.JSONType in ActualValueJSONTypes then
+          AValue.Add(D.Value.AsString);
+    jtObject:
+      For D in El do
+        if D.Value.JSONType in ActualValueJSONTypes then
+          AValue.Add(D.Key+'='+D.Value.AsString);
+  else
+    AValue.Text:=EL.AsString
+  end;
+
+end;
+
+function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings;
+  const ADefault: TStrings): Boolean;
+begin
+  Result:=GetValue(APath,AValue,'');
+  If Not Result then
+    AValue.Assign(ADefault);
+end;
+
 
 procedure TJSONConfig.SetValue(const APath: UnicodeString; const AValue: UnicodeString);
 
@@ -363,17 +407,17 @@ begin
   El:=FindElement(StripSlash(APath),True,O,ElName);
   if Assigned(El) and (El.JSONType<>jtString) then
     begin
-    I:=O.IndexOfName(elName);
+    I:=O.IndexOfName(UTF8Encode(elName));
     O.Delete(i);
     El:=Nil;
     end;
   If Not Assigned(el) then
     begin
     El:=TJSONString.Create(AValue);
-    O.Add(ElName,El);
+    O.Add(UTF8Encode(ElName),El);
     end
   else
-    El.AsString:=AVAlue;
+    El.AsUnicodeString:=AValue;
   FModified:=True;
 end;
 
@@ -397,7 +441,7 @@ begin
   El:=FindElement(StripSlash(APath),True,O,ElName);
   if Assigned(El) and (Not (El is TJSONIntegerNumber)) then
     begin
-    I:=O.IndexOfName(elName);
+    I:=O.IndexOfName(UTF8Encode(elName));
     If (I<>-1) then // Normally not needed...
       O.Delete(i);
     El:=Nil;
@@ -405,7 +449,7 @@ begin
   If Not Assigned(el) then
     begin
     El:=TJSONIntegerNumber.Create(AValue);
-    O.Add(ElName,El);
+    O.Add(UTF8Encode(ElName),El);
     end
   else
     El.AsInteger:=AValue;
@@ -424,7 +468,7 @@ begin
   El:=FindElement(StripSlash(APath),True,O,ElName);
   if Assigned(El) and (Not (El is TJSONInt64Number)) then
     begin
-    I:=O.IndexOfName(elName);
+    I:=O.IndexOfName(UTF8Encode(elName));
     If (I<>-1) then // Normally not needed...
       O.Delete(i);
     El:=Nil;
@@ -432,7 +476,7 @@ begin
   If Not Assigned(el) then
     begin
     El:=TJSONInt64Number.Create(AValue);
-    O.Add(ElName,El);
+    O.Add(UTF8Encode(ElName),El);
     end
   else
     El.AsInt64:=AValue;
@@ -469,14 +513,14 @@ begin
   El:=FindElement(StripSlash(APath),True,O,ElName);
   if Assigned(El) and (el.JSONType<>jtBoolean) then
     begin
-    I:=O.IndexOfName(elName);
+    I:=O.IndexOfName(UTF8Encode(elName));
     O.Delete(i);
     El:=Nil;
     end;
   If Not Assigned(el) then
     begin
     El:=TJSONBoolean.Create(AValue);
-    O.Add(ElName,El);
+    O.Add(UTF8Encode(ElName),El);
     end
   else
     El.AsBoolean:=AValue;
@@ -495,20 +539,72 @@ begin
   El:=FindElement(StripSlash(APath),True,O,ElName);
   if Assigned(El) and (Not (El is TJSONFloatNumber)) then
     begin
-    I:=O.IndexOfName(elName);
+    I:=O.IndexOfName(UTF8Encode(elName));
     O.Delete(i);
     El:=Nil;
     end;
   If Not Assigned(el) then
     begin
     El:=TJSONFloatNumber.Create(AValue);
-    O.Add(ElName,El);
+    O.Add(UTF8Encode(ElName),El);
     end
   else
     El.AsFloat:=AValue;
   FModified:=True;
 end;
 
+procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: TStrings; AsObject : Boolean = False);
+var
+  El : TJSONData;
+  ElName : UnicodeString;
+  O : TJSONObject;
+  I : integer;
+  A : TJSONArray;
+  N,V : String;
+  DoDelete: Boolean;
+
+begin
+  El:=FindElement(StripSlash(APath),True,O,ElName,True);
+  if Assigned(El) then
+    begin
+    if AsObject then
+      DoDelete:=(Not (El is TJSONObject))
+    else
+      DoDelete:=(Not (El is TJSONArray));
+    if DoDelete then
+      begin
+      I:=O.IndexOfName(UTF8Encode(elName));
+      O.Delete(i);
+      El:=Nil;
+      end;
+    end;
+  If Not Assigned(el) then
+    begin
+    if AsObject then
+      El:=TJSONObject.Create
+    else
+      El:=TJSONArray.Create;
+    O.Add(UTF8Encode(ElName),El);
+    end;
+  if Not AsObject then
+    begin
+    A:=El as TJSONArray;
+    A.Clear;
+    For N in Avalue do
+      A.Add(N);
+    end
+  else
+    begin
+    O:=El as TJSONObject;
+    For I:=0 to AValue.Count-1 do
+      begin
+      AValue.GetNameValue(I,N,V);
+      O.Add(N,V);
+      end;
+    end;
+  FModified:=True;
+end;
+
 procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue,
   DefValue: Boolean);
 begin
@@ -521,7 +617,7 @@ end;
 procedure TJSONConfig.DeletePath(const APath: UnicodeString);
 
 Var
-  P : String;
+  P : UnicodeString;
   L : integer;
   Node : TJSONObject;
   ElName : UnicodeString;
@@ -534,7 +630,7 @@ begin
     Node := FindObject(P,False,ElName);
     If Assigned(Node) then
       begin
-      L:=Node.IndexOfName(ElName);
+      L:=Node.IndexOfName(UTF8Encode(ElName));
       If (L<>-1) then
         Node.Delete(L);
       end;
@@ -553,6 +649,7 @@ begin
   if Length(Filename) > 0 then
     DoSetFilename(Filename,True);
 end;
+
 procedure TJSONConfig.Loaded;
 begin
   inherited Loaded;
@@ -596,7 +693,7 @@ begin
     begin
     F:=TFileStream.Create(AFileName,fmopenRead);
     try
-      P:=TJSONParser.Create(F);
+      P:=TJSONParser.Create(F,FJSONOptions);
       try
         J:=P.Parse;
         If (J is TJSONObject) then
@@ -621,7 +718,17 @@ begin
   DoSetFilename(AFilename, False);
 end;
 
-function TJSONConfig.StripSlash(Const P: UnicodeString): UnicodeString;
+procedure TJSONConfig.SetJSONOptions(AValue: TJSONOptions);
+begin
+  if FJSONOptions=AValue then Exit;
+  FJSONOptions:=AValue;
+  if csLoading in ComponentState then
+    exit;
+  if (FFileName<>'') then
+    Reload;
+end;
+
+function TJSONConfig.StripSlash(const P: UnicodeString): UnicodeString;
 
 Var
   L : Integer;
@@ -643,9 +750,9 @@ end;
 procedure TJSONConfig.OpenKey(const aPath: UnicodeString; AllowCreate: Boolean);
 
 Var
-  ElName : UnicodeString;
-  P : String;
+  P : UnicodeString;
   L : Integer;
+  
 begin
   P:=APath;
   L:=Length(P);

packages/fcl-json/src/jsonparser.pp

@@ -28,12 +28,11 @@ Type
   TJSONParser = Class(TObject)
   Private
     FScanner : TJSONScanner;
-    FuseUTF8,
-    FStrict: Boolean;
+    function GetO(AIndex: TJSONOption): Boolean;
+    function GetOptions: TJSONOptions;
     function ParseNumber: TJSONNumber;
-    procedure SetStrict(const AValue: Boolean);
-    function GetUTF8 : Boolean;
-    procedure SetUTF8(const AValue: Boolean);
+    procedure SetO(AIndex: TJSONOption; AValue: Boolean);
+    procedure SetOptions(AValue: TJSONOptions);
   Protected
     procedure DoError(const Msg: String);
     function DoParse(AtCurrent,AllowEOF: Boolean): TJSONData;
@@ -45,13 +44,17 @@ Type
     Property Scanner : TJSONScanner read FScanner;
   Public
     function Parse: TJSONData;
-    Constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload;
-    Constructor Create(Source : TJSONStringType; AUseUTF8 : Boolean = True); overload;
+    Constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload;deprecated 'use options form instead';
+    Constructor Create(Source : TJSONStringType; AUseUTF8 : Boolean = True); overload;deprecated 'use options form instead';
+    constructor Create(Source: TStream; AOptions: TJSONOptions); overload;
+    constructor Create(const Source: String; AOptions: TJSONOptions); overload;
     destructor Destroy();override;
     // Use strict JSON: " for strings, object members are strings, not identifiers
-    Property Strict : Boolean Read FStrict Write SetStrict;
+    Property Strict : Boolean Index joStrict Read GetO Write SetO ; deprecated 'use options instead';
     // if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings.
-    Property UseUTF8 : Boolean Read GetUTF8 Write SetUTF8;
+    Property UseUTF8 : Boolean index joUTF8 Read GetO Write SetO; deprecated 'Use options instead';
+    // Parsing options
+    Property Options : TJSONOptions Read GetOptions Write SetOptions;
   end;
   
   EJSONParser = Class(EParserError);
@@ -79,7 +82,7 @@ Var
 
 begin
   Data:=Nil;
-  P:=TJSONParser.Create(AStream,AUseUTF8);
+  P:=TJSONParser.Create(AStream,[joUTF8]);
   try
     Data:=P.Parse;
   finally
@@ -87,7 +90,7 @@ begin
   end;
 end;
 
-Function TJSONParser.Parse : TJSONData;
+function TJSONParser.Parse: TJSONData;
 
 begin
   if (FScanner=Nil) then
@@ -102,22 +105,22 @@ end;
   If AllowEOF is false, encountering a tkEOF will result in an exception.
 }
 
-Function TJSONParser.CurrentToken : TJSONToken;
+function TJSONParser.CurrentToken: TJSONToken;
 
 begin
   Result:=FScanner.CurToken;
 end;
 
-Function TJSONParser.CurrentTokenString : String;
+function TJSONParser.CurrentTokenString: String;
 
 begin
-  If CurrentToken in [tkString,tkIdentifier,tkNumber] then
+  If CurrentToken in [tkString,tkIdentifier,tkNumber,tkComment] then
     Result:=FScanner.CurTokenString
   else
     Result:=TokenInfos[CurrentToken];
 end;
 
-Function TJSONParser.DoParse(AtCurrent,AllowEOF : Boolean) : TJSONData;
+function TJSONParser.DoParse(AtCurrent, AllowEOF: Boolean): TJSONData;
 
 var
   T : TJSONToken;
@@ -135,7 +138,10 @@ begin
       tkNull  : Result:=CreateJSON;
       tkTrue,
       tkFalse : Result:=CreateJSON(t=tkTrue);
-      tkString : Result:=CreateJSON(CurrentTokenString);
+      tkString : if joUTF8 in Options then
+                   Result:=CreateJSON(UTF8Decode(CurrentTokenString))
+                     else
+                       Result:=CreateJSON(CurrentTokenString);
       tkCurlyBraceOpen : Result:=ParseObject;
       tkCurlyBraceClose : DoError(SErrUnexpectedToken);
       tkSQuaredBraceOpen : Result:=ParseArray;
@@ -151,7 +157,7 @@ end;
 
 
 // Creates the correct JSON number type, based on the current token.
-Function TJSONParser.ParseNumber : TJSONNumber;
+function TJSONParser.ParseNumber: TJSONNumber;
 
 Var
   I : Integer;
@@ -201,41 +207,41 @@ begin
 
 end;
 
-function TJSONParser.GetUTF8 : Boolean;
-
+function TJSONParser.GetO(AIndex: TJSONOption): Boolean;
 begin
-  if Assigned(FScanner) then
-    Result:=FScanner.UseUTF8
-  else
-    Result:=FUseUTF8;  
+  Result:=AIndex in Options;
 end;
 
-procedure TJSONParser.SetUTF8(const AValue: Boolean);
+function TJSONParser.GetOptions: TJSONOptions;
+begin
+  Result:=FScanner.Options
+end;
 
+procedure TJSONParser.SetO(AIndex: TJSONOption; AValue: Boolean);
 begin
-  FUseUTF8:=AValue;
-  if Assigned(FScanner) then
-    FScanner.UseUTF8:=FUseUTF8;
+  if aValue then
+    FScanner.Options:=FScanner.Options+[AINdex]
+  else
+    FScanner.Options:=FScanner.Options-[AINdex]
 end;
 
-procedure TJSONParser.SetStrict(const AValue: Boolean);
+procedure TJSONParser.SetOptions(AValue: TJSONOptions);
 begin
-  if (FStrict=AValue) then
-     exit;
-  FStrict:=AValue;
-  If Assigned(FScanner) then
-    FScanner.Strict:=Fstrict;
+  FScanner.Options:=AValue;
 end;
 
+
 // Current token is {, on exit current token is }
-Function TJSONParser.ParseObject : TJSONObject;
+function TJSONParser.ParseObject: TJSONObject;
 
 Var
   T : TJSONtoken;
   E : TJSONData;
   N : String;
-  
+  LastComma : Boolean;
+
 begin
+  LastComma:=False;
   Result:=CreateJSONObject([]);
   Try
     T:=GetNextToken;
@@ -253,8 +259,13 @@ begin
       If Not (T in [tkComma,tkCurlyBraceClose]) then
         DoError(SExpectedCommaorBraceClose);
       If T=tkComma then
+        begin
         T:=GetNextToken;
+        LastComma:=(t=tkCurlyBraceClose);
+        end;
       end;
+    If LastComma and ((joStrict in Options) or not (joIgnoreTrailingComma in Options))  then // Test for ,} case
+      DoError(SErrUnExpectedToken);
   Except
     FreeAndNil(Result);
     Raise;
@@ -262,13 +273,13 @@ begin
 end;
 
 // Current token is [, on exit current token is ]
-Function TJSONParser.ParseArray : TJSONArray;
+function TJSONParser.ParseArray: TJSONArray;
 
 Var
   T : TJSONtoken;
   E : TJSONData;
   LastComma : Boolean;
-  
+  S : TJSONOPTions;
 begin
   Result:=CreateJSONArray([]);
   LastComma:=False;
@@ -288,7 +299,8 @@ begin
         LastComma:=(t=TkComma);
         end;
     Until (T=tkSquaredBraceClose);
-    If LastComma then // Test for ,] case
+    S:=Options;
+    If LastComma and ((joStrict in S) or not (joIgnoreTrailingComma in S))  then // Test for ,] case
       DoError(SErrUnExpectedToken);
   Except
     FreeAndNil(Result);
@@ -297,15 +309,15 @@ begin
 end;
 
 // Get next token, discarding whitespace
-Function TJSONParser.GetNextToken : TJSONToken ;
+function TJSONParser.GetNextToken: TJSONToken;
 
 begin
   Repeat
     Result:=FScanner.FetchToken;
-  Until (Result<>tkWhiteSpace);
+  Until (Not (Result in [tkComment,tkWhiteSpace]));
 end;
 
-Procedure TJSONParser.DoError(const Msg : String);
+procedure TJSONParser.DoError(const Msg: String);
 
 Var
   S : String;
@@ -319,15 +331,27 @@ end;
 constructor TJSONParser.Create(Source: TStream; AUseUTF8 : Boolean = True);
 begin
   Inherited Create;
-  FScanner:=TJSONScanner.Create(Source);
-  UseUTF8:=AUseUTF8;
+  FScanner:=TJSONScanner.Create(Source,[joUTF8]);
+  if AUseUTF8 then
+   Options:=Options + [joUTF8];
 end;
 
 constructor TJSONParser.Create(Source: TJSONStringType; AUseUTF8 : Boolean = True);
 begin
   Inherited Create;
-  FScanner:=TJSONScanner.Create(Source);
-  UseUTF8:=AUseUTF8;
+  FScanner:=TJSONScanner.Create(Source,[joUTF8]);
+  if AUseUTF8 then
+   Options:=Options + [joUTF8];
+end;
+
+constructor TJSONParser.Create(Source: TStream; AOptions: TJSONOptions);
+begin
+  FScanner:=TJSONScanner.Create(Source,AOptions);
+end;
+
+constructor TJSONParser.Create(const Source: String; AOptions: TJSONOptions);
+begin
+  FScanner:=TJSONScanner.Create(Source,AOptions);
 end;
 
 destructor TJSONParser.Destroy();

packages/fcl-json/src/jsonscanner.pp

@@ -23,6 +23,7 @@ uses SysUtils, Classes;
 
 resourcestring
   SErrInvalidCharacter = 'Invalid character at line %d, pos %d: ''%s''';
+  SUnterminatedComment = 'Unterminated comment at line %d, pos %d: ''%s''';
   SErrOpenString = 'string exceeds end of line';
 
 type
@@ -43,32 +44,44 @@ type
     tkSquaredBraceOpen,       // '['
     tkSquaredBraceClose,      // ']'
     tkIdentifier,            // Any Javascript identifier
+    tkComment,
     tkUnknown
     );
 
   EScannerError       = class(EParserError);
 
+  TJSONOption = (joUTF8,joStrict,joComments,joIgnoreTrailingComma);
+  TJSONOptions = set of TJSONOption;
+
+Const
+  DefaultOptions = [joUTF8];
+
+Type
 
   { TJSONScanner }
 
   TJSONScanner = class
   private
+    FAllowComments: Boolean;
     FSource : TStringList;
     FCurRow: Integer;
     FCurToken: TJSONToken;
     FCurTokenString: string;
     FCurLine: string;
-    FStrict: Boolean;
-    FUseUTF8 : Boolean;
     TokenStr: PChar;
+    FOptions : TJSONOptions;
     function GetCurColumn: Integer;
+    function GetO(AIndex: TJSONOption): Boolean;
+    procedure SetO(AIndex: TJSONOption; AValue: Boolean);
   protected
     procedure Error(const Msg: string);overload;
     procedure Error(const Msg: string; Const Args: array of Const);overload;
     function DoFetchToken: TJSONToken;
   public
-    constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload;
-    constructor Create(const Source : String; AUseUTF8 : Boolean = True); overload;
+    constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload; deprecated 'use options form instead';
+    constructor Create(const Source : String; AUseUTF8 : Boolean = True); overload; deprecated  'use options form instead';
+    constructor Create(Source: TStream; AOptions: TJSONOptions); overload;
+    constructor Create(const Source: String; AOptions: TJSONOptions); overload;
     destructor Destroy; override;
     function FetchToken: TJSONToken;
 
@@ -80,9 +93,11 @@ type
     property CurToken: TJSONToken read FCurToken;
     property CurTokenString: string read FCurTokenString;
     // Use strict JSON: " for strings, object members are strings, not identifiers
-    Property Strict : Boolean Read FStrict Write FStrict;
+    Property Strict : Boolean Index joStrict Read GetO Write SetO ; deprecated 'use options instead';
     // if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings.
-    Property UseUTF8 : Boolean Read FUseUTF8 Write FUseUTF8;
+    Property UseUTF8 : Boolean index joUTF8 Read GetO Write SetO; deprecated 'Use options instead';
+    // Parsing options
+    Property Options : TJSONOptions Read FOptions Write FOptions;
   end;
 
 const
@@ -101,6 +116,7 @@ const
     '[',
     ']',
     'identifier',
+    'comment',
     ''
   );
 
@@ -109,17 +125,43 @@ implementation
 
 constructor TJSONScanner.Create(Source : TStream; AUseUTF8 : Boolean = True);
 
+Var
+  O : TJSONOptions;
+
+begin
+  O:=DefaultOptions;
+  if AUseUTF8 then
+    Include(O,joUTF8)
+  else
+    Exclude(O,joUTF8);
+  Create(Source,O);
+end;
+
+constructor TJSONScanner.Create(const Source : String; AUseUTF8 : Boolean = True);
+Var
+  O : TJSONOptions;
+
+begin
+  O:=DefaultOptions;
+  if AUseUTF8 then
+    Include(O,joUTF8)
+  else
+    Exclude(O,joUTF8);
+  Create(Source,O);
+end;
+
+constructor TJSONScanner.Create(Source: TStream; AOptions: TJSONOptions);
 begin
   FSource:=TStringList.Create;
   FSource.LoadFromStream(Source);
-  FUseUTF8:=AUseUTF8;
+  FOptions:=AOptions;
 end;
 
-constructor TJSONScanner.Create(const Source : String; AUseUTF8 : Boolean = True);
+constructor TJSONScanner.Create(const Source: String; AOptions: TJSONOptions);
 begin
   FSource:=TStringList.Create;
   FSource.Text:=Source;
-  FUseUTF8:=AUseUTF8;
+  FOptions:=AOptions;
 end;
 
 destructor TJSONScanner.Destroy;
@@ -140,7 +182,7 @@ begin
   raise EScannerError.Create(Msg);
 end;
 
-procedure TJSONScanner.Error(const Msg: string; const Args: array of Const);
+procedure TJSONScanner.Error(const Msg: string; const Args: array of const);
 begin
   raise EScannerError.CreateFmt(Msg, Args);
 end;
@@ -170,7 +212,8 @@ var
   OldLength, SectionLength, Index: Integer;
   C : char;
   S : String;
-  
+  IsStar,EOC: Boolean;
+
 begin
   if TokenStr = nil then
     if not FetchLine then
@@ -204,7 +247,7 @@ begin
     '"','''':
       begin
         C:=TokenStr[0];
-        If (C='''') and Strict then
+        If (C='''') and (joStrict in Options) then
           Error(SErrInvalidCharacter, [CurRow,CurColumn,TokenStr[0]]);
         Inc(TokenStr);
         TokenStart := TokenStr;
@@ -241,7 +284,7 @@ begin
                       end;
                       end;
                     // WideChar takes care of conversion...  
-                    if UseUTF8 then
+                    if (joUTF8 in Options) then
                       S:=Utf8Encode(WideString(WideChar(StrToInt('$'+S))))
                     else
                       S:=WideChar(StrToInt('$'+S));  
@@ -310,9 +353,8 @@ begin
           end;
         end;
         SectionLength := TokenStr - TokenStart;
-        SetLength(FCurTokenString, SectionLength);
-        if SectionLength > 0 then
-          Move(TokenStart^, FCurTokenString[1], SectionLength);
+        FCurTokenString:='';
+        SetString(FCurTokenString, TokenStart, SectionLength);
         If (FCurTokenString[1]='.') then
           FCurTokenString:='0'+FCurTokenString;
         Result := tkNumber;
@@ -342,6 +384,54 @@ begin
         Inc(TokenStr);
         Result := tkSquaredBraceClose;
       end;
+    '/' :
+      begin
+      if Not (joComments in Options) then
+        Error(SErrInvalidCharacter, [CurRow,CurCOlumn,TokenStr[0]]);
+      TokenStart:=TokenStr;
+      Inc(TokenStr);
+      Case Tokenstr[0] of
+        '/' : begin
+              SectionLength := Length(FCurLine)- (TokenStr - PChar(FCurLine));
+              Inc(TokenStr);
+              FCurTokenString:='';
+              SetString(FCurTokenString, TokenStr, SectionLength);
+              Fetchline;
+              end;
+        '*' :
+          begin
+          IsStar:=False;
+          Inc(TokenStr);
+          TokenStart:=TokenStr;
+          Repeat
+            if (TokenStr[0]=#0) then
+              begin
+              SectionLength := (TokenStr - TokenStart);
+              S:='';
+              SetString(S, TokenStart, SectionLength);
+              FCurtokenString:=FCurtokenString+S;
+              if not fetchLine then
+                Error(SUnterminatedComment, [CurRow,CurCOlumn,TokenStr[0]]);
+              TokenStart:=TokenStr;
+              end;
+            IsStar:=TokenStr[0]='*';
+            Inc(TokenStr);
+            EOC:=(isStar and (TokenStr[0]='/'));
+          Until EOC;
+          if EOC then
+            begin
+            SectionLength := (TokenStr - TokenStart-1);
+            S:='';
+            SetString(S, TokenStart, SectionLength);
+            FCurtokenString:=FCurtokenString+S;
+            Inc(TokenStr);
+            end;
+          end;
+      else
+        Error(SErrInvalidCharacter, [CurRow,CurCOlumn,TokenStr[0]]);
+      end;
+      Result:=tkComment;
+      end;
     'a'..'z','A'..'Z','_':
       begin
         TokenStart := TokenStr;
@@ -349,9 +439,8 @@ begin
           Inc(TokenStr);
         until not (TokenStr[0] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
         SectionLength := TokenStr - TokenStart;
-        SetLength(FCurTokenString, SectionLength);
-        if SectionLength > 0 then
-          Move(TokenStart^, FCurTokenString[1], SectionLength);
+        FCurTokenString:='';
+        SetString(FCurTokenString, TokenStart, SectionLength);
         for it := tkTrue to tkNull do
           if CompareText(CurTokenString, TokenInfos[it]) = 0 then
             begin
@@ -359,7 +448,7 @@ begin
             FCurToken := Result;
             exit;
             end;
-        if Strict then
+        if (joStrict in Options) then
           Error(SErrInvalidCharacter, [CurRow,CurColumn,TokenStr[0]])
         else
           Result:=tkIdentifier;
@@ -376,4 +465,17 @@ begin
   Result := TokenStr - PChar(CurLine);
 end;
 
+function TJSONScanner.GetO(AIndex: TJSONOption): Boolean;
+begin
+  Result:=AIndex in FOptions;
+end;
+
+procedure TJSONScanner.SetO(AIndex: TJSONOption; AValue: Boolean);
+begin
+  If AValue then
+    Include(Foptions,AIndex)
+  else
+    Exclude(Foptions,AIndex)
+end;
+
 end.

packages/fcl-json/tests/jsonconftest.pp

@@ -1,6 +1,7 @@
 unit jsonconftest;
 
 {$mode objfpc}{$H+}
+{$codepage utf8}
 
 interface
 
@@ -13,6 +14,8 @@ type
 
   TTestJSONConfig= class(TTestCase)
   Private
+    procedure AssertStrings(Msg: String; L: TStrings;
+      const Values: array of string);
     Function CreateConf(AFileName : String) : TJSONCOnfig;
     Procedure DeleteConf(C : TJSONConfig; DeleteConfFile : Boolean = true);
   published
@@ -22,6 +25,8 @@ type
     procedure TestEnumValues;
     procedure TestClear;
     procedure TestKey;
+    procedure TestStrings;
+    procedure TestUnicodeStrings;
   end;
 
 implementation
@@ -253,6 +258,96 @@ begin
   end;
 end;
 
+procedure TTestJSONConfig.AssertStrings(Msg: String; L: TStrings;
+  const Values: array of string);
+
+Var
+  I : Integer;
+begin
+  Msg:=Msg+': ';
+  AssertNotNull(Msg+'Have strings',L);
+  AssertEquals(Msg+'Correct element count',Length(Values),L.Count);
+  For I:=0 to L.Count-1 do
+    AssertEquals(Msg+'element '+IntToStr(i),Values[i],l[i]);
+end;
+
+procedure TTestJSONConfig.TestStrings;
+
+Var
+  C : TJSONCOnfig;
+  L,LD : TStrings;
+
+begin
+  L:=Nil;
+  LD:=Nil;
+  C:=CreateConf('test.json');
+  try
+    L:=TStringList.Create;
+    LD:=TStringList.Create;
+    L.Add('abc');
+    C.GetValue('list',L,'');
+    AssertStrings('Clear, no default.',L,[]);
+    C.GetValue('list',L,'text');
+    AssertStrings('Use default.',L,['text']);
+    L.Clear;
+    L.Add('abc');
+    L.Add('def');
+    C.SetValue('a',L);
+    C.GetValue('a',LD,'');
+    AssertStrings('List',LD,['abc','def']);
+    L.Clear;
+    L.Add('abc=1');
+    L.Add('def=2');
+    C.SetValue('a',L,True);
+    LD.Clear;
+    C.GetValue('a',LD,'');
+    AssertStrings('List',LD,['abc=1','def=2']);
+    C.SetValue('a','abc');
+    C.GetValue('a',L,'');
+    AssertStrings('String',L,['abc']);
+    C.SetValue('a',Integer(1));
+    C.GetValue('a',L,'');
+    AssertStrings('integer',L,['1']);
+    C.SetValue('a',True);
+    C.GetValue('a',L,'');
+    AssertStrings('integer',L,['True']);
+    C.SetValue('a',Int64(1));
+    C.GetValue('a',L,'');
+    AssertStrings('int64',L,['1']);
+  finally
+    L.Free;
+    DeleteConf(C,True);
+  end;
+end;
+
+procedure TTestJSONConfig.TestUnicodeStrings;
+
+Const
+  utf8str = 'Größe ÄÜÖ ㎰ す 가';
+  utf8path = 'Größe/す가';
+
+Var
+  Co : TJSONCOnfig;
+
+
+begin
+  Co:=CreateConf('test.json');
+  try
+    Co.SetValue('a',utf8str);
+    Co.SetValue(utf8path,'something');
+    Co.Flush;
+  finally
+    co.Free;
+  end;
+  Co:=CreateConf('test.json');
+  try
+    AssertEquals('UTF8 string read/Write',utf8str,utf8encode(Co.GetValue('a','')));
+    AssertEquals('UTF8 path read/Write','something',Co.GetValue(utf8path,'something'));
+  finally
+    DeleteConf(Co,True);
+  end;
+end;
+
 
 initialization
 

packages/fcl-json/tests/testcomps.pp

@@ -0,0 +1,1007 @@
+unit testcomps;
+
+interface
+
+uses classes, sysutils;
+
+Type
+  TEmptyComponent = Class(TComponent)
+  end;
+
+  // Simple integer, fits in 1 byte
+  TIntegerComponent = Class(TComponent)
+  private
+    FIntProp: Integer;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property IntProp : Integer Read FIntProp Write FIntProp;
+  end;
+
+  // Simple integer, fits in 2 bytes
+  TIntegerComponent2 = Class(TComponent)
+  private
+    FIntProp: Integer;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property IntProp : Integer Read FIntProp Write FIntProp;
+  end;
+
+  // Simple integer, fits in 3 bytes
+  TIntegerComponent3 = Class(TComponent)
+  private
+    FIntProp: Integer;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property IntProp : Integer Read FIntProp Write FIntProp;
+  end;
+
+  // Simple integer, Default value. (set)
+  TIntegerComponent4 = Class(TComponent)
+  private
+    FIntProp: Integer;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property IntProp : Integer Read FIntProp Write FIntProp default 6;
+  end;
+
+  // Simple integer, Default value. (not set)
+  TIntegerComponent5 = Class(TComponent)
+  private
+    FIntProp: Integer;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property IntProp : Integer Read FIntProp Write FIntProp default 6;
+  end;
+
+  // Simple Int64 property fits in a single byte.
+  TInt64Component = Class(TComponent)
+  private
+    FIntProp: Int64;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property Int64Prop : Int64 Read FIntProp Write FIntProp;
+  end;
+
+  // Simple Int64 property fits 2 bytes.
+  TInt64Component2 = Class(TComponent)
+  private
+    FIntProp: Int64;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property Int64Prop : Int64 Read FIntProp Write FIntProp;
+  end;
+
+  // Simple Int64 property fits 3 bytes.
+  TInt64Component3 = Class(TComponent)
+  private
+    FIntProp: Int64;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property Int64Prop : Int64 Read FIntProp Write FIntProp;
+  end;
+
+  // Simple Int64 property fits 4 bytes.
+  TInt64Component4 = Class(TComponent)
+  private
+    FIntProp: Int64;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property Int64Prop : Int64 Read FIntProp Write FIntProp;
+  end;
+
+  // Int64 property with default, set.
+  TInt64Component5 = Class(TComponent)
+  private
+    FIntProp: Int64;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property Int64Prop : Int64 Read FIntProp Write FIntProp default 7;
+  end;
+
+  // Int64 property with default, not set.
+  TInt64Component6 = Class(TComponent)
+  private
+    FIntProp: Int64;
+  Public
+     Constructor Create(AOwner : TComponent); override;
+  Published
+    Property Int64Prop : Int64 Read FIntProp Write FIntProp default 7;
+  end;
+
+  // String property.
+  TStringComponent = Class(TComponent)
+  private
+    F: String;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property StringProp : String Read F Write F;
+  end;
+
+  // String property, empty
+  TStringComponent2 = Class(TComponent)
+  private
+    F: String;
+  Published
+    Property StringProp : String Read F Write F;
+  end;
+
+  // WideString property
+  TWideStringComponent = Class(TComponent)
+  private
+    F: WideString;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property WideStringProp : WideString Read F Write F;
+  end;
+
+  // WideString property, empty
+  TWideStringComponent2 = Class(TComponent)
+  private
+    F: WideString;
+  Published
+    Property WideStringProp : WideString Read F Write F;
+  end;
+
+  // Single property
+  TSingleComponent = Class(TComponent)
+  private
+    F: Single;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property SingleProp : Single Read F Write F;
+  end;
+
+  // Double property
+  TDoubleComponent = Class(TComponent)
+  private
+    F: Double;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property DoubleProp : Double Read F Write F;
+  end;
+
+  // Extended property
+  TExtendedComponent = Class(TComponent)
+  private
+    F: Extended;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property ExtendedProp : Extended Read F Write F;
+  end;
+
+  // Comp property
+  TCompComponent = Class(TComponent)
+  private
+    F: Comp;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property ExtendedProp : Comp Read F Write F;
+  end;
+
+  // Currency property
+  TCurrencyComponent = Class(TComponent)
+  private
+    F: Currency;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property CurrencyProp : Currency Read F Write F;
+  end;
+
+  // DateTime property, date only
+  TDateTimeComponent = Class(TComponent)
+  private
+    F: TDateTime;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property DateTimeProp : TDateTime Read F Write F;
+  end;
+
+  // DateTime property, time only
+  TDateTimeComponent2 = Class(TComponent)
+  private
+    F: TDateTime;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property DateTimeProp : TDateTime Read F Write F;
+  end;
+
+  // DateTime property, Date and time
+  TDateTimeComponent3 = Class(TComponent)
+  private
+    F: TDateTime;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property DateTimeProp : TDateTime Read F Write F;
+  end;
+
+  TDice = (one,two,three,four,five,six);
+
+  // Enum property. No default (i.e. 0)
+  TEnumComponent = Class(TComponent)
+  private
+    F: TDice;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property Dice : TDice Read F Write F;
+  end;
+
+  // Enum  property, not set
+  TEnumComponent2 = Class(TComponent)
+  private
+    F: TDice;
+  Published
+    Property Dice : TDice Read F Write F;
+  end;
+
+  // Enum property with default, not set
+  TEnumComponent3 = Class(TComponent)
+  private
+    F: TDice;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property Dice : TDice Read F Write F default two;
+  end;
+
+  // Enum property with default, set
+  TEnumComponent4 = Class(TComponent)
+  private
+    F: TDice;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property Dice : TDice Read F Write F default two;
+  end;
+
+  // Enum property with default, no need to set
+  TEnumComponent5 = Class(TComponent)
+  private
+    F: TDice;
+  Published
+    Property Dice : TDice Read F Write F default one;
+  end;
+
+  Throws = Set of TDice;
+
+  // Set property, no default.
+  TSetComponent = Class(TComponent)
+  private
+    F: Throws;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property Throw : Throws Read F Write F;
+  end;
+
+  // Set property, no default, not set
+  TSetComponent2 = Class(TComponent)
+  private
+    F: Throws;
+  Published
+    Property Throw : Throws Read F Write F;
+  end;
+
+  // Set property, default, not set
+  TSetComponent3 = Class(TComponent)
+  private
+    F: Throws;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property Throw : Throws Read F Write F default [three,six];
+  end;
+
+  // Set property, default, set
+  TSetComponent4 = Class(TComponent)
+  private
+    F: Throws;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property Throw : Throws Read F Write F default [three,six];
+  end;
+
+  // Multiple components.
+  TMultipleComponent = Class(TComponent)
+  private
+    FCurrency: Currency;
+    FInt: Integer;
+    FString: String;
+    FDice: TDice;
+    F: Throws;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property IntProp : Integer Read FInt Write FInt;
+    Property StringProp : String Read FString Write FString;
+    Property CurrencyProp : Currency Read FCurrency Write FCurrency;
+    Property Dice : TDice Read FDice Write FDice;
+    Property Throw : Throws Read F Write F;
+  end;
+
+  TTestPersistent1 = Class(TPersistent)
+  private
+    FInt: Integer;
+    FAstring: String;
+  Public
+    Procedure Assign(ASource : TPersistent); override;
+  Published
+    Property AInteger : Integer Read FInt Write FInt;
+    Property AString : String Read FAstring Write FAsTring;
+  end;
+
+  // Persistent as a published property.
+  TPersistentComponent = Class(TComponent)
+  private
+    FPers: TTestPersistent1;
+    procedure SetPers(const Value: TTestPersistent1);
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+    Destructor Destroy; override;
+  Published
+    Property Persist : TTestPersistent1 Read FPers Write SetPers;
+  end;
+
+  // For use in collection streaming
+  TTestItem = Class(TCollectionItem)
+  Private
+    F : String;
+  Published
+    Property StrProp : String Read F Write F;
+  end;
+
+  // For use in collection streaming: items with two properties
+
+  { TTest2Item }
+
+  TTest2Item = Class(TCollectionItem)
+  Private
+    F1, F2 : String;
+  public
+  Published
+    Property StrProp1 : String Read F1 Write F1;
+    Property StrProp2 : String Read F2 Write F2;
+  end;
+
+
+  TTestCollection = Class(TCollection)
+  Public
+    Constructor Create;
+  end;
+
+  // Empty collection
+  TCollectionComponent = Class(TComponent)
+  Private
+    FColl : TCollection;
+    Procedure SetColl(AColl : TCollection);
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+  Published
+    Property Coll : TCollection Read FColl Write SetCOll;
+  end;
+
+  // collection with elements.
+  TCollectionComponent2 = Class(TCollectionComponent)
+  Public
+    Constructor Create(AOwner : TComponent); override;
+  end;
+
+  // collection with elements, one has no props
+  TCollectionComponent3 = Class(TCollectionComponent)
+  Public
+    Constructor Create(AOwner : TComponent); override;
+  end;
+
+  // collection with changed propname, one element
+  TCollectionComponent4 = Class(TComponent)
+    FColl : TTestCollection;
+    Procedure SetColl(AColl : TTestCollection);
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+  Published
+    Property Coll : TTestCollection Read FColl Write SetColl;
+  end;
+
+  // collection two elements, items with two properties
+  TCollectionComponent5 = Class(TComponent)
+    FColl : TCollection;
+    Procedure SetColl(AColl : TCollection);
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+  Published
+    Property Coll : TCollection Read FColl Write SetColl;
+  end;
+
+  // Component as published property
+  TOwnedComponent = Class(TComponent)
+    F : TComponent;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Property CompProp : TComponent Read F Write F;
+  end;
+
+  // Use this if owned components should also be streamed.
+  TChildrenComponent = Class(TComponent)
+    // Owned components are children
+    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
+  end;
+
+  // Stream sub component.
+  TStreamedOwnedComponent = Class(TChildrenComponent)
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Sub : TIntegerComponent;
+  end;
+  
+  // Stream 2 sub components
+  TStreamedOwnedComponents = Class(TChildrenComponent)
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    SubA : TIntegerComponent;
+    SubB : TStringComponent;
+  end;
+
+  // Method tests.
+
+  THandler = Procedure of Object;
+
+  // Method property that points to own method.
+  TMethodComponent = Class(TComponent)
+  Private
+    F : THandler;
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Procedure MyMethod;
+    Property MethodProp : THandler Read F Write F;
+  end;
+
+  // Method property of owned component that points to own method.
+  TMethodComponent2 = Class(TChildrenComponent)
+  Public
+    Constructor Create(AOwner : TComponent);  override;
+  Published
+    Procedure MyMethod2;
+  end;
+
+  { TVariantComponent }
+
+  TVariantComponent = Class(TComponent)
+  private
+    FVariant: Variant;
+  Published
+    Property VariantProp : Variant Read FVariant Write FVariant;
+  end;
+
+  TBooleanComponent = Class(TComponent)
+  private
+    FBoolean: Boolean;
+  Published
+    Property BooleanProp : Boolean Read FBoolean Write FBoolean;
+  end;
+
+  TemptyPersistent = Class(TPersistent);
+
+  { TStringsCOmponent }
+
+  TStringsCOmponent = Class(TComponent)
+  private
+    FStrings: TStrings;
+    procedure SetStrings(AValue: TStrings);
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+  Published
+    Property StringsProp : TStrings Read FStrings Write SetStrings;
+  end;
+Implementation
+
+{ TStringsCOmponent }
+
+procedure TStringsCOmponent.SetStrings(AValue: TStrings);
+begin
+  if FStrings=AValue then Exit;
+  FStrings.Assign(AValue);
+end;
+
+constructor TStringsCOmponent.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FStrings:=TStringList.Create;
+  FStrings.Add('One');
+  FStrings.Add('Two');
+  FStrings.Add('Three');
+end;
+
+destructor TStringsCOmponent.Destroy;
+begin
+  FreeAndNil(FStrings);
+  inherited Destroy;
+end;
+
+procedure TChildrenComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+Var
+  I : Integer;
+
+begin
+  For I:=0 to ComponentCount-1 do
+    Proc(Components[i]);
+end;
+
+
+{ TIntegerComponent }
+
+constructor TIntegerComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  FIntProp:=3;
+end;
+
+
+{ TInt64Component }
+
+constructor TInt64Component.Create(AOwner: TComponent);
+begin
+  inherited;
+  FIntProp:=4;
+end;
+
+{ TInt64Component2 }
+
+constructor TInt64Component2.Create(AOwner: TComponent);
+begin
+  inherited;
+  FIntProp:=2 shl 9;
+end;
+
+{ TIntegerComponent2 }
+
+constructor TIntegerComponent2.Create(AOwner: TComponent);
+begin
+  inherited;
+  FintProp:=2 shl 9;
+end;
+
+{ TIntegerComponent3 }
+
+constructor TIntegerComponent3.Create(AOwner: TComponent);
+begin
+  inherited;
+  FintProp:=2 shl 17;
+end;
+
+{ TInt64Component3 }
+
+constructor TInt64Component3.Create(AOwner: TComponent);
+begin
+  inherited;
+  FintProp:=2 shl 17;
+end;
+
+{ TInt64Component4 }
+
+constructor TInt64Component4.Create(AOwner: TComponent);
+begin
+  inherited;
+  FintProp:=Int64(MaxInt)+Int64(2 shl 17);
+end;
+
+{ TStringComponent }
+
+constructor TStringComponent.Create(AOwner: TComponent);
+begin
+  Inherited;
+  F:='A string';
+end;
+
+{ TWideStringComponent }
+
+constructor TWideStringComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:='Some WideString';
+end;
+
+{ TSingleComponent }
+
+constructor TSingleComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=1.23;
+end;
+
+{ TDoubleComponent }
+
+constructor TDoubleComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=2.34;
+end;
+
+{ TExtendedComponent }
+
+constructor TExtendedComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=3.45;
+end;
+
+{ TCompComponent }
+
+constructor TCompComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=4.56;
+end;
+
+{ TCurrencyComponent }
+
+constructor TCurrencyComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=5.67;
+end;
+
+{ TDateTimeComponent }
+
+constructor TDateTimeComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=EncodeDate(1996,8,1);
+end;
+
+{ TDateTimeComponent2 }
+
+constructor TDateTimeComponent2.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=EncodeTime(23,20,0,0);
+end;
+
+{ TDateTimeComponent3 }
+
+constructor TDateTimeComponent3.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=EncodeDate(1996,8,1)+EncodeTime(23,20,0,0);
+end;
+
+{ TEnumComponent }
+
+constructor TEnumComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=Four;
+end;
+
+{ TSetComponent }
+
+constructor TSetComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=[two,five];
+end;
+
+{ TIntegerComponent4 }
+
+constructor TIntegerComponent4.Create(AOwner: TComponent);
+begin
+  inherited;
+  FIntProp:=6;
+end;
+
+{ TIntegerComponent5 }
+
+constructor TIntegerComponent5.Create(AOwner: TComponent);
+begin
+  inherited;
+  FintProp:=5;
+end;
+
+{ TInt64Component5 }
+
+constructor TInt64Component5.Create(AOwner: TComponent);
+begin
+  inherited;
+  FIntProp:=7;
+end;
+
+{ TInt64Component6 }
+
+constructor TInt64Component6.Create(AOwner: TComponent);
+begin
+  inherited;
+  FintProp:=8;
+end;
+
+{ TEnumComponent3 }
+
+constructor TEnumComponent3.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=Three;
+end;
+
+{ TEnumComponent4 }
+
+constructor TEnumComponent4.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=Two;
+end;
+
+{ TSetComponent4 }
+
+constructor TSetComponent4.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=[Three,Six];
+end;
+
+{ TSetComponent3 }
+
+constructor TSetComponent3.Create(AOwner: TComponent);
+begin
+  inherited;
+  F:=[One,Four];
+end;
+
+{ TMultipleComponent }
+
+constructor TMultipleComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  FInt:=1;
+  FCurrency:=2.3;
+  FString:='A String';
+  FDice:=two;
+  F:=[three,four];
+end;
+
+{ TTestPersistent1 }
+
+procedure TTestPersistent1.Assign(ASource: TPersistent);
+
+Var
+  T :TTestPersistent1;
+
+begin
+  If ASource is TTestPersistent1 then
+    begin
+    T:=ASource as TTestPersistent1;
+    FInt:=T.FInt;
+    FAString:=T.FAString;
+    end
+  else
+    inherited;
+end;
+
+{ TPersistentComponent }
+
+constructor TPersistentComponent.Create(AOwner: TComponent);
+begin
+  inherited;
+  FPers:=TTestPersistent1.Create;
+  FPers.AInteger:=3;
+  FPers.AString:='A persistent string';
+end;
+
+Destructor TPersistentComponent.Destroy;
+
+begin
+  FreeAndNil(FPers);
+  Inherited;
+end;
+
+procedure TPersistentComponent.SetPers(const Value: TTestPersistent1);
+begin
+  FPers.Assign(Value);
+end;
+
+{ TCollectionComponent }
+
+Procedure TCollectionComponent.SetColl(AColl : TCollection);
+
+begin
+  FColl.Assign(AColl);
+end;
+
+Constructor TCollectionComponent.Create(AOwner : TComponent);
+
+begin
+  Inherited;
+  FColl:=TCollection.Create(TTestItem);
+end;
+
+Destructor TCollectionComponent.Destroy;
+
+begin
+  FreeAndNil(FColl);
+  Inherited;
+end;
+
+{ TCollectionComponent2 }
+
+Constructor TCollectionComponent2.Create(AOwner : TComponent);
+
+begin
+  Inherited;
+  (FColl.Add as TTestItem).StrProp:='First';
+  (FColl.Add as TTestItem).StrProp:='Second';
+  (FColl.Add as TTestItem).StrProp:='Third';
+end;
+
+{ TCollectionComponen3 }
+
+Constructor TCollectionComponent3.Create(AOwner : TComponent);
+
+begin
+  Inherited;
+  (FColl.Add as TTestItem).StrProp:='First';
+  (FColl.Add as TTestItem).StrProp:='';
+  (FColl.Add as TTestItem).StrProp:='Third';
+end;
+
+{ TCollectionComponent4 }
+
+constructor TCollectionComponent4.Create(AOwner: TComponent);
+begin
+  inherited;
+  FColl:=TTestCollection.Create;
+  (FColl.Add as TTestItem).StrProp:='Something'
+end;
+
+destructor TCollectionComponent4.Destroy;
+begin
+  FreeAndNil(FColl);
+  inherited;
+end;
+
+procedure TCollectionComponent4.SetColl(AColl: TTestCollection);
+begin
+  FColl.Assign(AColl);
+end;
+
+{ TCollectionComponent5 }
+
+procedure TCollectionComponent5.SetColl(AColl: TCollection);
+begin
+  FColl.Assign(AColl);
+end;
+
+constructor TCollectionComponent5.Create(AOwner: TComponent);
+var
+  Item : TTest2Item;
+begin
+  inherited Create(AOwner);
+  FColl:=TCollection.Create(TTest2Item);
+  Item := FColl.Add as TTest2Item;
+  Item.StrProp1 := 'Something';
+  Item.StrProp2 := 'Otherthing';
+  Item := FColl.Add as TTest2Item;
+  Item.StrProp1 := 'Something 2';
+  Item.StrProp2 := 'Otherthing 2';
+end;
+
+destructor TCollectionComponent5.Destroy;
+begin
+  FreeAndNil(FColl);
+  inherited Destroy;
+end;
+
+{ TTestCollection }
+
+Constructor TTestCollection.Create;
+begin
+  Inherited Create(TTestitem);
+  PropName:='MyCollProp';
+end;
+
+{ TStreamedOwnedComponent }
+
+Constructor TStreamedOwnedComponent.Create(AOwner : TComponent);
+
+begin
+  Inherited;
+  Sub:=TIntegerComponent.Create(Self);
+  Sub.Name:='Sub';
+end;
+
+{ TStreamedOwnedComponents }
+
+constructor TStreamedOwnedComponents.Create(AOwner: TComponent);
+begin
+  inherited;
+  SubA:=TIntegerComponent.Create(Self);
+  SubA.Name:='SubA';
+  SubB:=TStringComponent.Create(Self);
+  SubB.Name:='SubB';
+end;
+
+
+Constructor TOwnedComponent.Create(AOwner : TComponent);
+
+Var
+  C: TComponent;
+
+begin
+  Inherited;
+  C:=TIntegerComponent.Create(Self);
+  C.Name:='SubComponent';
+  CompProp:=C;
+end;
+
+
+{ TMethodComponent }
+
+Constructor TMethodComponent.Create(AOwner : TComponent);
+
+begin
+  Inherited;
+{$ifdef fpc}
+  MethodProp:=@MyMethod;
+{$else}
+  MethodProp:=MyMethod;
+{$endif}
+end;
+
+Procedure TMethodComponent.MyMethod;
+
+begin
+  // Do nothing.
+end;
+
+{ TMethodComponent2 }
+
+constructor TMethodComponent2.Create(AOwner: TComponent);
+
+Var
+  C : TMethodComponent;
+
+begin
+  inherited;
+  C:=TMethodComponent.Create(Self);
+  C.Name:='AComponent';
+{$ifdef fpc}
+  C.MethodProp:=@MyMethod2;
+{$else}
+  C.MethodProp:=MyMethod2;
+{$endif}
+end;
+
+Procedure TMethodComponent2.MyMethod2;
+
+begin
+ // Do nothng
+end;
+
+
+end.

packages/fcl-json/tests/testjson.lpi

@@ -4,6 +4,7 @@
     <Version Value="9"/>
     <General>
       <Flags>
+        <SaveOnlyProjectUnits Value="True"/>
         <LRSInOutputDirectory Value="False"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
@@ -24,48 +25,35 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
+        <CommandLineParams Value="--suite=TTestJSONDeStreamer.TestDateTimeFormat"/>
         <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
-    <RequiredPackages Count="4">
+    <RequiredPackages Count="1">
       <Item1>
-        <PackageName Value="fpcunitconsolerunner"/>
-      </Item1>
-      <Item2>
-        <PackageName Value="LCL"/>
-      </Item2>
-      <Item3>
-        <PackageName Value="FPCUnitTestRunner"/>
-      </Item3>
-      <Item4>
         <PackageName Value="FCL"/>
-      </Item4>
+      </Item1>
     </RequiredPackages>
     <Units Count="5">
       <Unit0>
         <Filename Value="testjson.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="testjson"/>
       </Unit0>
       <Unit1>
         <Filename Value="testjsonparser.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="testjsonparser"/>
       </Unit1>
       <Unit2>
         <Filename Value="testjsondata.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="testjsondata"/>
       </Unit2>
       <Unit3>
         <Filename Value="testjsonrtti.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="testjsonrtti"/>
       </Unit3>
       <Unit4>
         <Filename Value="../src/fpjsonrtti.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="fpjsonrtti"/>
       </Unit4>
     </Units>
   </ProjectOptions>
@@ -79,12 +67,12 @@
         <UseAnsiStrings Value="False"/>
       </SyntaxOptions>
     </Parsing>
-    <Other>
-      <CompilerMessages>
-        <UseMsgFile Value="True"/>
-      </CompilerMessages>
-      <CompilerPath Value="$(CompPath)"/>
-    </Other>
+    <Linking>
+      <Debugging>
+        <UseHeaptrc Value="True"/>
+        <TrashVariables Value="True"/>
+      </Debugging>
+    </Linking>
   </CompilerOptions>
   <Debugging>
     <Exceptions Count="2">

packages/fcl-json/tests/testjson.pp

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

packages/fcl-json/tests/testjsonconf.lpi

@@ -1,16 +1,20 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <PathDelim Value="/"/>
-    <Version Value="5"/>
+    <Version Value="9"/>
     <General>
+      <Flags>
+        <LRSInOutputDirectory Value="False"/>
+      </Flags>
       <SessionStorage Value="InProjectDir"/>
       <MainUnit Value="0"/>
-      <TargetFileExt Value=""/>
     </General>
     <VersionInfo>
-      <ProjectVersion Value=""/>
+      <StringTable ProductVersion=""/>
     </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="default" Default="True"/>
+    </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
       <IgnoreBinaries Value="False"/>
@@ -23,24 +27,19 @@
         <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
-    <RequiredPackages Count="2">
+    <RequiredPackages Count="1">
       <Item1>
-        <PackageName Value="FPCUnitConsoleRunner"/>
-      </Item1>
-      <Item2>
         <PackageName Value="FCL"/>
-      </Item2>
+      </Item1>
     </RequiredPackages>
     <Units Count="3">
       <Unit0>
         <Filename Value="testjsonconf.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="testjsonconf"/>
       </Unit0>
       <Unit1>
         <Filename Value="jsonconftest.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="jsonconftest"/>
       </Unit1>
       <Unit2>
         <Filename Value="../src/jsonconf.pp"/>
@@ -50,15 +49,14 @@
     </Units>
   </ProjectOptions>
   <CompilerOptions>
-    <Version Value="5"/>
+    <Version Value="11"/>
     <SearchPaths>
-      <OtherUnitFiles Value="../src/"/>
+      <OtherUnitFiles Value="../src"/>
     </SearchPaths>
-    <CodeGeneration>
-      <Generate Value="Faster"/>
-    </CodeGeneration>
-    <Other>
-      <CompilerPath Value="$(CompPath)"/>
-    </Other>
+    <Parsing>
+      <SyntaxOptions>
+        <UseAnsiStrings Value="False"/>
+      </SyntaxOptions>
+    </Parsing>
   </CompilerOptions>
 </CONFIG>

packages/fcl-json/tests/testjsonconf.pp

@@ -18,6 +18,8 @@ var
   Application: TMyTestRunner;
 
 begin
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
   Application := TMyTestRunner.Create(nil);
   Application.Initialize;
   Application.Run;

packages/fcl-json/tests/testjsondata.pp

@@ -146,6 +146,7 @@ type
     procedure DoTestFloat(F: TJSOnFloat; S: String; OK: Boolean);
   published
     procedure TestString;
+    procedure TestControlString;
     procedure TestInteger;
     procedure TestNegativeInteger;
     procedure TestFloat;
@@ -1492,6 +1493,35 @@ begin
   end;
 end;
 
+procedure TTestString.TestControlString;
+Var
+  J : TJSONString;
+  I : Integer;
+  T : String;
+
+begin
+
+  J:=TJSONString.Create('');
+  try
+    For I:=0 to 31 do
+      begin
+      J.AsString:='-->'+Char(I)+'<--';
+      Case I of
+       8  : T:='\b';
+       9  : T:='\t';
+       10 : T:='\n';
+       12 : T:='\f';
+       13 : T:='\r';
+      else
+        T:='\u'+HexStr(I,4);
+      end;
+      AssertEquals('Control char','"-->'+T+'<--"',J.AsJSON);
+      end;
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestString.TestInteger;
 
 Const

packages/fcl-json/tests/testjsonparser.pp

@@ -20,7 +20,7 @@ interface
 
 uses
   Classes, SysUtils, fpcunit, testutils, testregistry,fpjson,
-  jsonParser,testjsondata;
+  jsonscanner,jsonParser,testjsondata;
 
 type
 
@@ -28,15 +28,20 @@ type
 
   TTestParser = class(TTestJSON)
   private
+    FOptions : TJSONOptions;
     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 DoTestArray(S: String; ACount: Integer; IgnoreJSON: Boolean=False);
     Procedure DoTestClass(S : String; AClass : TJSONDataClass);
     procedure CallNoHandler;
+    procedure DoTrailingCommaErrorArray;
+    procedure DoTrailingCommaErrorObject;
+  Protected
+    Procedure Setup; override;
   published
     procedure TestEmpty;
     procedure TestNull;
@@ -48,7 +53,11 @@ type
     procedure TestString;
     procedure TestArray;
     procedure TestObject;
+    procedure TestTrailingComma;
+    procedure TestTrailingCommaErrorArray;
+    procedure TestTrailingCommaErrorObject;
     procedure TestMixed;
+    Procedure TestComment;
     procedure TestErrors;
     Procedure TestClasses;
     Procedure TestHandler;
@@ -205,7 +214,6 @@ procedure TTestParser.TestArray;
 Var
   S1,S2,S3 : String;
 
-
 begin
   DoTestArray('[]',0);
   DoTestArray('[null]',1);
@@ -217,15 +225,15 @@ begin
   DoTestArray('[1234567890123456]',1);
   DoTestArray('[1234567890123456, 2234567890123456]',2);
   DoTestArray('[1234567890123456, 2234567890123456, 3234567890123456]',3);
-  Str(Double(1.2),S1);
+  Str(12/10,S1);
   Delete(S1,1,1);
-  Str(Double(2.3),S2);
+  Str(34/10,S2);
   Delete(S2,1,1);
-  Str(Double(3.4),S3);
+  Str(34/10,S3);
   Delete(S3,1,1);
-  DoTestArray('['+S1+']',1);
-  DoTestArray('['+S1+', '+S2+']',2);
-  DoTestArray('['+S1+', '+S2+', '+S3+']',3);
+  DoTestArray('['+S1+']',1,true);
+  DoTestArray('['+S1+', '+S2+']',2,true);
+  DoTestArray('['+S1+', '+S2+', '+S3+']',3,true);
   DoTestArray('["A string"]',1);
   DoTestArray('["A string", "Another string"]',2);
   DoTestArray('["A string", "Another string", "Yet another string"]',3);
@@ -237,6 +245,33 @@ begin
   DoTestArray('[1, [1, 2]]',2);
 end;
 
+procedure TTestParser.TestTrailingComma;
+begin
+  FOptions:=[joIgnoreTrailingComma];
+  DoTestArray('[1, 2,]',2,True);
+  DoTestObject('{ "a" : 1, }',['a'],False);
+end;
+
+procedure TTestParser.TestTrailingCommaErrorArray;
+begin
+  AssertException('Need joIgnoreTrailingComma in options to allow trailing comma',EJSONParser,@DoTrailingCommaErrorArray) ;
+end;
+
+procedure TTestParser.TestTrailingCommaErrorObject;
+begin
+  AssertException('Need joIgnoreTrailingComma in options to allow trailing comma',EJSONParser,@DoTrailingCommaErrorObject);
+end;
+
+procedure TTestParser.DoTrailingCommaErrorArray;
+begin
+  DoTestArray('[1, 2,]',2,True);
+end;
+
+procedure TTestParser.DoTrailingCommaErrorObject;
+begin
+  DoTestObject('{ "a" : 1, }',['a'],False);
+end;
+
 procedure TTestParser.TestMixed;
 
 Const
@@ -245,7 +280,7 @@ Const
          '  "address": {'+
          '      "street": "5 Main Street",'+LineEnding+
          '        "city": "San Diego, CA",'+LineEnding+
-         '        "zip": 91912,'+LineEnding+
+         '        "zip": 91912'+LineEnding+
          '    },'+LineEnding+
          '    "phoneNumbers": [  '+LineEnding+
          '        "619 332-3452",'+LineEnding+
@@ -263,6 +298,25 @@ begin
   DoTestObject(SAddr,['addressbook'],False);
 end;
 
+procedure TTestParser.TestComment;
+begin
+  FOptions:=[joComments];
+  DoTestArray('/* */ [1, {}]',2,True);
+  DoTestArray('//'+sLineBreak+'[1, { "a" : 1 }]',2,True);
+  DoTestArray('/* '+sLineBreak+' */ [1, {}]',2,True);
+  DoTestArray('/*'+sLineBreak+'*/ [1, {}]',2,True);
+  DoTestArray('/*'+sLineBreak+'*/ [1, {}]',2,True);
+  DoTestArray('/*'+sLineBreak+'*'+sLineBreak+'*/ [1, {}]',2,True);
+  DoTestArray('/**'+sLineBreak+'**'+sLineBreak+'**/ [1, {}]',2,True);
+  DoTestArray('/* */ [1, {}]',2,True);
+  DoTestArray('[1, { "a" : 1 }]//'+sLineBreak,2,True);
+  DoTestArray('[1, {}]/* '+sLineBreak+' */ ',2,True);
+  DoTestArray('[1, {}]/*'+sLineBreak+'*/ ',2,True);
+  DoTestArray('[1, {}]/*'+sLineBreak+'*/ ',2,True);
+  DoTestArray('[1, {}]/*'+sLineBreak+'*'+sLineBreak+'*/ ',2,True);
+  DoTestArray(' [1, {}]/**'+sLineBreak+'**'+sLineBreak+'**/',2,True);
+end;
+
 procedure TTestParser.TestObject;
 begin
   DoTestObject('{}',[]);
@@ -283,8 +337,10 @@ Var
   I : Integer;
 
 begin
+  J:=Nil;
   P:=TJSONParser.Create(S);
   Try
+    P.Options:=FOptions;
     J:=P.Parse;
     If (J=Nil) then
       Fail('Parse of object "'+S+'" fails');
@@ -303,21 +359,24 @@ begin
 end;
 
 
-procedure TTestParser.DoTestArray(S : String; ACount : Integer);
+procedure TTestParser.DoTestArray(S : String; ACount : Integer; IgnoreJSON : Boolean = False);
 
 Var
   P : TJSONParser;
   J : TJSONData;
 
 begin
-  P:=TJSONParser.Create(S);
+  J:=Nil;
+  P:=TJSONParser.Create(S,[joComments]);
   Try
+    P.Options:=FOptions;
     J:=P.Parse;
     If (J=Nil) then
       Fail('Parse of array "'+S+'" fails');
     TestJSONType(J,jtArray);
     TestItemCount(J,ACount);
-    TestJSON(J,S);
+    if not IgnoreJSON then
+      TestJSON(J,S);
   Finally
     FreeAndNil(J);
     FreeAndNil(P);
@@ -383,6 +442,12 @@ begin
   GetJSON('1',True).Free;
 end;
 
+procedure TTestParser.Setup;
+begin
+  inherited Setup;
+  FOptions:=[];
+end;
+
 procedure TTestParser.CallNoHandlerStream;
 
 Var

packages/fcl-web/fpmake.pp

@@ -136,7 +136,7 @@ begin
         Dependencies.AddUnit('custweb');
         ResourceStrings:=true;
       end;
-    with P.Targets.AddUnit('fpapache.pp') do
+    with P.Targets.AddUnit('custapache.pp') do
       begin
         OSes:=AllOses-[amiga,aros,morphos];
         Dependencies.AddUnit('httpprotocol');
@@ -144,13 +144,23 @@ begin
         Dependencies.AddUnit('custweb');
         ResourceStrings:=true;
       end;
-    with P.Targets.AddUnit('fpapache24.pp') do
+    with P.Targets.AddUnit('fpapache.pp') do
+      begin
+        OSes:=AllOses-[amiga,aros,morphos];
+        Dependencies.AddUnit('custapache');
+      end;
+    with P.Targets.AddUnit('custapache24.pp') do
       begin
         OSes:=AllOses-[amiga,aros,morphos];
         Dependencies.AddUnit('fphttp');
         Dependencies.AddUnit('custweb');
         ResourceStrings:=true;
       end;
+    with P.Targets.AddUnit('fpapache24.pp') do
+      begin
+        OSes:=AllOses-[amiga,aros,morphos];
+        Dependencies.AddUnit('custapache24');
+      end;
     T:=P.Targets.AddUnit('fcgigate.pp');
     T.ResourceStrings:=true;
     With T.Dependencies do

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

@@ -0,0 +1,709 @@
+unit custapache;
+
+{$mode objfpc}
+{$H+}
+
+interface
+
+uses
+  SysUtils,Classes,CustWeb,httpDefs,fpHTTP,httpd,httpprotocol, apr, SyncObjs;
+
+Type
+  TApacheHandler = Class;
+
+  { TApacheRequest }
+
+  TApacheRequest = Class(TRequest)
+  Private
+    FApache : TApacheHandler;
+    FRequest : PRequest_rec;
+  Protected
+    Procedure InitFromRequest;
+    procedure ReadContent; override;
+  Public
+    Constructor CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
+    Function GetCustomHeader(const Name: String) : String; override;
+    Property ApacheRequest : Prequest_rec Read FRequest;
+    Property ApacheApp : TApacheHandler Read FApache;
+  end;
+
+  { TApacheResponse }
+
+  TApacheResponse = Class(TResponse)
+  private
+    FApache : TApacheHandler;
+    FRequest : PRequest_rec;
+    procedure SendStream(S: TStream);
+  Protected
+    Procedure DoSendHeaders(Headers : TStrings); override;
+    Procedure DoSendContent; override;
+  Public
+    Constructor CreateApache(Req : TApacheRequest);
+    Property ApacheRequest : Prequest_rec Read FRequest;
+    Property ApacheApp : TApacheHandler Read FApache;
+  end;
+
+  { TCustomApacheApplication }
+  THandlerPriority = (hpFirst,hpMiddle,hpLast);
+  TBeforeRequestEvent = Procedure(Sender : TObject; Const AHandler : String;
+                                  Var AllowRequest : Boolean) of object;
+
+  TApacheHandler = Class(TWebHandler)
+  private
+    FMaxRequests: Integer;             //Maximum number of simultaneous web module requests (default=64, if set to zero no limit)
+    FWorkingWebModules: TList;         //List of currently running web modules handling requests
+    FIdleWebModules: TList;            //List of idle web modules available
+    FCriticalSection: TCriticalSection;
+    FBaseLocation: String;
+    FBeforeRequest: TBeforeRequestEvent;
+    FHandlerName: String;
+    FModuleName: String;
+    FModules : Array[0..1] of TStrings;
+    FPriority: THandlerPriority;
+    FModuleRecord : PModule;
+    function GetModules(Index: integer): TStrings;
+    procedure SetModules(Index: integer; const AValue: TStrings);
+    function GetIdleModuleCount : Integer;
+    function GetWorkingModuleCount : Integer;
+  Protected
+    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
+    function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
+    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
+    function GetApplicationURL(ARequest : TRequest): String; override;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    Procedure Run; override;
+    Procedure SetModuleRecord(Var ModuleRecord : Module);
+    Procedure Initialize;
+    Procedure LogErrorMessage(Msg : String; LogLevel : integer = APLOG_INFO); virtual;
+    Procedure handleRequest(ARequest : TRequest; AResponse : TResponse); override;
+    Property HandlerPriority : THandlerPriority Read FPriority Write FPriority default hpMiddle;
+    Property BeforeModules : TStrings Index 0 Read GetModules Write SetModules;
+    Property AfterModules : TStrings Index 1 Read GetModules Write SetModules;
+    Property BaseLocation : String Read FBaseLocation Write FBaseLocation;
+    Property ModuleName : String Read FModuleName Write FModuleName;
+    Property HandlerName : String Read FHandlerName Write FHandlerName;
+    Property BeforeRequest : TBeforeRequestEvent Read FBeforeRequest Write FBeforeRequest;
+    Property MaxRequests: Integer read FMaxRequests write FMaxRequests;
+    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
+    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
+  end;
+
+  TCustomApacheApplication = Class(TCustomWebApplication)
+  private
+    function GetAfterModules: TStrings;
+    function GetBaseLocation: String;
+    function GetBeforeModules: TStrings;
+    function GetBeforeRequest: TBeforeRequestEvent;
+    function GetHandlerName: String;
+    function GetIdleModuleCount: Integer;
+    function GetMaxRequests: Integer;
+    function GetModuleName: String;
+    function GetPriority: THandlerPriority;
+    function GetWorkingModuleCount: Integer;
+    procedure SetAfterModules(const AValue: TStrings);
+    procedure SetBaseLocation(const AValue: String);
+    procedure SetBeforeModules(const AValue: TStrings);
+    procedure SetBeforeRequest(const AValue: TBeforeRequestEvent);
+    procedure SetHandlerName(const AValue: String);
+    procedure SetMaxRequests(const AValue: Integer);
+    procedure SetModuleName(const AValue: String);
+    procedure SetPriority(const AValue: THandlerPriority);
+  public
+    function InitializeWebHandler: TWebHandler; override;
+    Procedure Initialize;override;
+    procedure ShowException(E: Exception); override;
+    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
+    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
+    Procedure SetModuleRecord(Var ModuleRecord : Module);
+    Property HandlerPriority : THandlerPriority Read GetPriority Write SetPriority default hpMiddle;
+    Property BeforeModules : TStrings Read GetBeforeModules Write SetBeforeModules;
+    Property AfterModules : TStrings Read GetAfterModules Write SetAfterModules;
+    Property BaseLocation : String Read GetBaseLocation Write SetBaseLocation;
+    Property ModuleName : String Read GetModuleName Write SetModuleName;
+    Property HandlerName : String Read GetHandlerName Write SetHandlerName;
+    Property BeforeRequest : TBeforeRequestEvent Read GetBeforeRequest Write SetBeforeRequest;
+    Property MaxRequests: Integer read GetMaxRequests write SetMaxRequests;
+    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
+    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
+  end;
+
+  EFPApacheError = Class(EHTTP);
+
+Var
+  Application : TCustomApacheApplication;
+  ShowCleanUpErrors : Boolean = False;
+  AlternateHandler : ap_hook_handler_t = Nil;
+
+implementation
+
+uses CustApp;
+
+resourcestring
+  SErrNoModuleNameForRequest = 'Could not determine HTTP module name for request';
+  SErrNoModuleForRequest = 'Could not determine HTTP module for request "%s"';
+  SErrNoModuleRecord = 'No module record location set.';
+  SErrNoModuleName = 'No module name set';
+  SErrTooManyRequests = 'Too many simultaneous requests.';
+
+const
+  HPRIO : Array[THandlerPriority] of Integer
+        = (APR_HOOK_FIRST,APR_HOOK_MIDDLE,APR_HOOK_LAST);
+
+Function MaybeP(P : Pchar) : String;
+
+begin
+  If (P<>Nil) then
+    Result:=StrPas(P);
+end;
+
+Function DefaultApacheHandler(P : PRequest_Rec) : integer;cdecl;
+
+begin
+  If (AlternateHandler<>Nil) then
+    Result:=AlternateHandler(P)
+  else
+    If Application.AllowRequest(P) then
+      Result:=Application.ProcessRequest(P)
+    else
+      Result:=DECLINED;
+end;
+
+Procedure RegisterApacheHooks(P: PApr_pool_t);cdecl;
+
+Var
+  H : ap_hook_handler_t;
+  PP1,PP2 : PPChar;
+
+begin
+  H:=AlternateHandler;
+  If (H=Nil) then
+    H:=@DefaultApacheHandler;
+  PP1:=Nil;
+  PP2:=Nil;
+  ap_hook_handler(H,PP1,PP2,HPRIO[Application.HandlerPriority]);
+end;
+
+{ TApacheHandler }
+
+function TApacheHandler.GetModules(Index: integer): TStrings;
+begin
+  If (FModules[Index]=Nil) then
+    FModules[Index]:=TStringList.Create;
+  Result:=FModules[Index];
+end;
+
+procedure TApacheHandler.SetModules(Index: integer;
+  const AValue: TStrings);
+begin
+  If (FModules[Index]=Nil) then
+    FModules[Index]:=TStringList.Create;
+  FModules[Index].Assign(AValue);
+end;
+
+Function TApacheHandler.ProcessRequest(P: PRequest_Rec) : Integer;
+
+Var
+  Req : TApacheRequest;
+  Resp : TApacheResponse;
+
+begin
+  Req:=TApacheRequest.CreateReq(Self,P);
+  Try
+    InitRequest(Req);
+    Req.InitRequestVars;
+    Resp:=TApacheResponse.CreateApache(Req);
+    Try
+      InitResponse(Resp);
+      HandleRequest(Req,Resp);
+      If Not Resp.ContentSent then
+        Resp.SendContent;
+    Finally
+      Result:=OK;
+      Resp.Free;
+    end;
+  Finally
+    Req.Free;
+  end;
+end;
+
+procedure TApacheHandler.Run;
+begin
+  // Do nothing. This is a library
+  Initialize;
+end;
+
+function TApacheHandler.WaitForRequest(out ARequest: TRequest; out AResponse: TResponse): boolean;
+begin
+  Result:=False;
+  ARequest:=Nil;
+  AResponse:=Nil;
+end;
+
+function TApacheHandler.AllowRequest(P: PRequest_Rec): Boolean;
+
+Var
+  Hn : String;
+
+begin
+  HN:=StrPas(p^.Handler);
+  Result:=CompareText(HN,FHandlerName)=0;
+  If Assigned(FBeforeRequest) then
+    FBeforeRequest(Self,HN,Result);
+end;
+
+function TApacheHandler.GetApplicationURL(ARequest: TRequest): String;
+begin
+  Result:=inherited GetApplicationURL(ARequest);
+  If (Result='') then
+    Result:=BaseLocation;
+end;
+
+constructor TApacheHandler.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FPriority:=hpMiddle;
+  FMaxRequests:=64;
+  FWorkingWebModules:=TList.Create;
+  FIdleWebModules:=TList.Create;
+  FCriticalSection:=TCriticalSection.Create;
+end;
+
+destructor TApacheHandler.Destroy;
+var I:Integer;
+begin
+  FCriticalSection.Free;
+  for I := FIdleWebModules.Count - 1 downto 0 do
+    TComponent(FIdleWebModules[I]).Free;
+  FIdleWebModules.Free;
+  for I := FWorkingWebModules.Count - 1 downto 0 do
+    TComponent(FWorkingWebModules[I]).Free;
+  FWorkingWebModules.Free;
+  inherited Destroy;
+end;
+
+
+procedure TApacheHandler.SetModuleRecord(var ModuleRecord: Module);
+begin
+  FModuleRecord:=@ModuleRecord;
+  FillChar(ModuleRecord,SizeOf(ModuleRecord),0);
+end;
+
+procedure TApacheHandler.Initialize;
+
+begin
+  If (FModuleRecord=nil) then
+    Raise EFPApacheError.Create(SErrNoModuleRecord);
+  if (FModuleName='') and (FModuleRecord^.Name=Nil) then
+    Raise EFPApacheError.Create(SErrNoModuleName);
+  STANDARD20_MODULE_STUFF(FModuleRecord^);
+  If (StrPas(FModuleRecord^.name)<>FModuleName) then
+    FModuleRecord^.Name:=PChar(FModuleName);
+  FModuleRecord^.register_hooks:=@RegisterApacheHooks;
+end;
+
+procedure TApacheHandler.LogErrorMessage(Msg: String; LogLevel: integer);
+begin
+  ap_log_error(pchar(FModuleName),0,LogLevel,0,Nil,'module: %s',[pchar(Msg)]);
+end;
+
+function TApacheHandler.GetIdleModuleCount : Integer;
+begin
+  FCriticalSection.Enter;
+  try
+    Result := FIdleWebModules.Count;
+  finally
+    FCriticalSection.Leave;
+  end;
+end;
+
+function TApacheHandler.GetWorkingModuleCount : Integer;
+begin
+  FCriticalSection.Enter;
+  try
+    Result := FWorkingWebModules.Count;
+  finally
+    FCriticalSection.Leave;
+  end;
+end;
+
+procedure TApacheHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
+
+Var
+  MC : TCustomHTTPModuleClass;
+  M  : TCustomHTTPModule;
+  MN : String;
+  MI : TModuleItem;
+
+  Procedure GetAWebModule;
+  Var II:Integer;
+  begin
+    FCriticalSection.Enter;
+    try
+      if (FMaxRequests>0) and (FWorkingWebModules.Count>=FMaxRequests) then
+        Raise EFPApacheError.Create(SErrTooManyRequests);
+      if (FIdleWebModules.Count>0) then
+      begin
+        II := FIdleWebModules.Count - 1;
+        while (II>=0) and not (TComponent(FIdleWebModules[II]) is MC) do
+          Dec(II);
+        if (II>=0) then
+        begin
+          M:=TCustomHTTPModule(FIdleWebModules[II]);
+          FIdleWebModules.Delete(II);
+        end;
+      end;
+      if (M=nil) then
+      begin
+        M:=MC.Create(Self);
+        M.Name := '';
+      end;
+      FWorkingWebModules.Add(M);
+    finally
+      FCriticalSection.Leave;
+    end;
+  end;
+
+begin
+  try
+    MC:=Nil;
+    M := Nil;
+    If (OnGetModule<>Nil) then
+      OnGetModule(Self,ARequest,MC);
+    If (MC=Nil) then
+    begin
+      MN:=GetModuleName(ARequest);
+      If (MN='') and Not AllowDefaultModule then
+        Raise EFPApacheError.Create(SErrNoModuleNameForRequest);
+      MI:=ModuleFactory.FindModule(MN);
+      If (MI=Nil) and (ModuleFactory.Count=1) then
+        MI:=ModuleFactory[0];
+      if (MI=Nil) then
+        Raise EFPApacheError.CreateFmt(SErrNoModuleForRequest,[MN]);
+
+      MC:=MI.ModuleClass;
+    end;
+    GetAWebModule;
+    M.HandleRequest(ARequest,AResponse);
+
+    FCriticalSection.Enter;
+    try
+      FWorkingWebModules.Remove(M);
+      FIdleWebModules.Add(M);
+    finally
+      FCriticalSection.Leave;
+    end;
+  except
+    On E : Exception do
+      begin
+      LogErrorMessage(E.Message,APLOG_ERR);
+      ShowRequestException(AResponse,E);
+      end;
+  end;
+end;
+
+{ TApacheRequest }
+
+procedure TApacheRequest.ReadContent;
+
+  Function MinS(A,B : Integer) : Integer;
+
+  begin
+    If A<B then
+      Result:=A
+    else
+      Result:=B;
+  end;
+
+Var
+  Left,Len,Count,Bytes : Integer;
+  P : Pchar;
+  S : String;
+
+begin
+  ap_setup_client_block(FRequest,REQUEST_CHUNKED_DECHUNK);
+  If (ap_should_client_block(FRequest)=1) then
+    begin
+    Len:=ContentLength;
+    If (Len>0) then
+      begin
+      SetLength(S,Len);
+      P:=PChar(S);
+      Left:=Len;
+      Count:=0;
+      Repeat
+        Bytes:=ap_get_client_block(FRequest,P,MinS(10*1024,Left));
+        Dec(Left,Bytes);
+        Inc(P,Bytes);
+        Inc(Count,Bytes);
+      Until (Count>=Len) or (Bytes=0);
+      SetLength(S,Count);
+      end;
+    end;
+  InitContent(S);
+end;
+
+procedure TApacheRequest.InitFromRequest;
+
+
+Var
+  H : THeader;
+  V : String;
+  I : Integer;
+
+begin
+  ParseCookies;
+  For H in THeader do
+    begin
+    V:=MaybeP(apr_table_get(FRequest^.headers_in,PAnsiChar(HTTPHeaderNames[h])));
+    If (V<>'') then
+      SetHeader(H,V);
+    end;
+  // Some Specials;
+  SetHeader(hhContentEncoding,MaybeP(FRequest^.content_encoding));
+  SetHTTPVariable(hvHTTPVersion,MaybeP(FRequest^.protocol));
+  SetHTTPVariable(hvPathInfo,MaybeP(FRequest^.path_info));
+  SetHTTPVariable(hvPathTranslated,MaybeP(FRequest^.filename));
+  If (FRequest^.Connection<>Nil) then
+    begin
+    SetHTTPVariable(hvRemoteAddress,MaybeP(FRequest^.Connection^.remote_ip));
+    SetHTTPVariable(hvRemoteHost,MaybeP(ap_get_remote_host(FRequest^.Connection,
+                   FRequest^.per_dir_config, REMOTE_NAME,@i)));
+    end;
+  V:=MaybeP(FRequest^.unparsed_uri);
+  I:=Pos('?',V)-1;
+  If (I=-1) then
+    I:=Length(V);
+  SetHTTPVariable(hvScriptName,Copy(V,1,I-Length(PathInfo)));
+  SetHTTPVariable(hvServerPort,IntToStr(ap_get_server_port(FRequest)));
+  SetHTTPVariable(hvMethod,MaybeP(FRequest^.method));
+  SetHTTPVariable(hvURL,FRequest^.unparsed_uri);
+  SetHTTPVariable(hvQuery,MaybeP(FRequest^.args));
+  SetHeader(hhHost,MaybeP(FRequest^.HostName));
+end;
+
+constructor TApacheRequest.CreateReq(App: TApacheHandler; ARequest: PRequest_rec
+  );
+
+begin
+  FApache:=App;
+  FRequest:=Arequest;
+  ReturnedPathInfo:=App.BaseLocation;
+  Inherited Create;
+  InitFromRequest;
+end;
+
+function TApacheRequest.GetCustomHeader(const Name: String): String;
+begin
+  Result:=inherited GetCustomHeader(Name);
+  if Result='' then
+    Result:=MaybeP(apr_table_get(FRequest^.headers_in,pchar(Name)));
+end;
+
+{ TApacheResponse }
+
+procedure TApacheResponse.DoSendHeaders(Headers: TStrings);
+
+Var
+  I,P : Integer;
+  N,V : String;
+
+begin
+  For I:=0 to Headers.Count-1 do
+    begin
+    V:=Headers[i];
+    P:=Pos(':',V);
+    If (P<>0) and (P<Length(V)) then
+      begin
+      N:=Copy(V,1,P-1);
+      System.Delete(V,1,P);
+      V := Trim(V);//no need space before the value, apache puts it there
+      apr_table_set(FRequest^.headers_out,Pchar(N),Pchar(V));
+      end;
+    end;
+end;
+
+procedure TApacheResponse.DoSendContent;
+
+Var
+  S : String;
+  I : Integer;
+
+begin
+  S:=ContentType;
+  If (S<>'') then
+    FRequest^.content_type:=apr_pstrdup(FRequest^.pool,Pchar(S));
+  S:=ContentEncoding;
+  If (S<>'') then
+    FRequest^.content_encoding:=apr_pstrdup(FRequest^.pool,Pchar(S));
+  If Code <> 200 then
+    FRequest^.status := Code;
+  If assigned(ContentStream) then
+    SendStream(Contentstream)
+  else
+    for I:=0 to Contents.Count-1 do
+      begin
+      S:=Contents[i]+LineEnding;
+      // If there is a null, it's written also with ap_rwrite
+      ap_rwrite(PChar(S),Length(S),FRequest);
+      end;
+end;
+
+Procedure TApacheResponse.SendStream(S : TStream);
+
+Var
+  Buf : Array[0..(10*1024)-1] of Byte;
+  Count : Integer;
+
+begin
+  S.Seek(0,soBeginning);
+  Repeat
+    Count:=S.Read(Buf,SizeOf(Buf));
+    If Count>0 then
+      ap_rwrite(@Buf,Count,FRequest);
+  Until (Count=0);
+end;
+
+
+Constructor TApacheResponse.CreateApache(Req : TApacheRequest);
+begin
+  FApache:=Req.ApacheApp;
+  Frequest:=Req.ApacheRequest;
+  Inherited Create(Req);
+end;
+
+function __dummythread(p: pointer): ptrint;
+begin
+  sleep(1000);
+  Result:=0;
+end;
+
+{ TCustomApacheApplication }
+
+function TCustomApacheApplication.GetAfterModules: TStrings;
+begin
+  result := TApacheHandler(WebHandler).AfterModules;
+end;
+
+function TCustomApacheApplication.GetBaseLocation: String;
+begin
+  result := TApacheHandler(WebHandler).BaseLocation;
+end;
+
+function TCustomApacheApplication.GetBeforeModules: TStrings;
+begin
+  result := TApacheHandler(WebHandler).BeforeModules;
+end;
+
+function TCustomApacheApplication.GetBeforeRequest: TBeforeRequestEvent;
+begin
+  result := TApacheHandler(WebHandler).BeforeRequest;
+end;
+
+function TCustomApacheApplication.GetHandlerName: String;
+begin
+  result := TApacheHandler(WebHandler).HandlerName;
+end;
+
+function TCustomApacheApplication.GetIdleModuleCount: Integer;
+begin
+  result := TApacheHandler(WebHandler).IdleWebModuleCount;
+end;
+
+function TCustomApacheApplication.GetMaxRequests: Integer;
+begin
+  result := TApacheHandler(WebHandler).MaxRequests;
+end;
+
+function TCustomApacheApplication.GetModuleName: String;
+begin
+  result := TApacheHandler(WebHandler).ModuleName;
+end;
+
+function TCustomApacheApplication.GetPriority: THandlerPriority;
+begin
+  result := TApacheHandler(WebHandler).HandlerPriority;
+end;
+
+function TCustomApacheApplication.GetWorkingModuleCount: Integer;
+begin
+  result := TApacheHandler(WebHandler).WorkingWebModuleCount;
+end;
+
+procedure TCustomApacheApplication.SetAfterModules(const AValue: TStrings);
+begin
+  TApacheHandler(WebHandler).AfterModules := AValue;
+end;
+
+procedure TCustomApacheApplication.SetBaseLocation(const AValue: String);
+begin
+  TApacheHandler(WebHandler).BaseLocation := AValue;
+end;
+
+procedure TCustomApacheApplication.SetBeforeModules(const AValue: TStrings);
+begin
+  TApacheHandler(WebHandler).BeforeModules := AValue;
+end;
+
+procedure TCustomApacheApplication.SetBeforeRequest(const AValue: TBeforeRequestEvent);
+begin
+  TApacheHandler(WebHandler).BeforeRequest := AValue;
+end;
+
+procedure TCustomApacheApplication.SetHandlerName(const AValue: String);
+begin
+  TApacheHandler(WebHandler).HandlerName := AValue;
+end;
+
+procedure TCustomApacheApplication.SetMaxRequests(const AValue: Integer);
+begin
+  TApacheHandler(WebHandler).MaxRequests := AValue;
+end;
+
+procedure TCustomApacheApplication.SetModuleName(const AValue: String);
+begin
+  TApacheHandler(WebHandler).ModuleName := AValue;
+end;
+
+procedure TCustomApacheApplication.SetPriority(const AValue: THandlerPriority);
+begin
+  TApacheHandler(WebHandler).HandlerPriority := AValue;
+end;
+
+function TCustomApacheApplication.InitializeWebHandler: TWebHandler;
+begin
+  Result:=TApacheHandler.Create(self);
+end;
+
+procedure TCustomApacheApplication.Initialize;
+begin
+  Inherited;
+  TApacheHandler(WebHandler).Initialize;
+end;
+
+procedure TCustomApacheApplication.ShowException(E: Exception);
+begin
+  ap_log_error(pchar(TApacheHandler(WebHandler).ModuleName),0,APLOG_ERR,0,Nil,'module: %s',[Pchar(E.Message)]);
+end;
+
+function TCustomApacheApplication.ProcessRequest(P: PRequest_Rec): Integer;
+begin
+  result := TApacheHandler(WebHandler).ProcessRequest(p);
+end;
+
+function TCustomApacheApplication.AllowRequest(P: PRequest_Rec): Boolean;
+begin
+  result := TApacheHandler(WebHandler).AllowRequest(p);
+end;
+
+procedure TCustomApacheApplication.SetModuleRecord(var ModuleRecord: Module);
+begin
+  TApacheHandler(WebHandler).SetModuleRecord(ModuleRecord);
+end;
+
+
+Initialization
+  BeginThread(@__dummythread);//crash prevention for simultaneous requests
+end.
+

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

@@ -0,0 +1,730 @@
+unit custapache24;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  SysUtils, Classes, CustWeb, httpDefs, fpHTTP, httpd24, apr24, SyncObjs;
+
+Type
+
+  TApacheHandler = Class;
+
+  { TApacheRequest }
+
+  TApacheRequest = Class(TRequest)
+  Private
+    FApache : TApacheHandler;
+    FRequest : PRequest_rec;
+  Protected
+    Function GetFieldValue(Index : Integer) : String; override;
+    Procedure InitFromRequest;
+    procedure ReadContent; override;
+  Public
+    Constructor CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
+    Property ApacheRequest : Prequest_rec Read FRequest;
+    Property ApacheApp : TApacheHandler Read FApache;
+  end;
+
+  { TApacheResponse }
+
+  TApacheResponse = Class(TResponse)
+  private
+    FApache : TApacheHandler;
+    FRequest : PRequest_rec;
+    procedure SendStream(S: TStream);
+  Protected
+    Procedure DoSendHeaders(Headers : TStrings); override;
+    Procedure DoSendContent; override;
+  Public
+    Constructor CreateApache(Req : TApacheRequest);
+    Property ApacheRequest : Prequest_rec Read FRequest;
+    Property ApacheApp : TApacheHandler Read FApache;
+  end;
+
+  { TCustomApacheApplication }
+  THandlerPriority = (hpFirst,hpMiddle,hpLast);
+  TBeforeRequestEvent = Procedure(Sender : TObject; Const AHandler : String;
+                                  Var AllowRequest : Boolean) of object;
+
+  TApacheHandler = Class(TWebHandler)
+  private
+    FMaxRequests: Integer;             //Maximum number of simultaneous web module requests (default=64, if set to zero no limit)
+    FWorkingWebModules: TList;         //List of currently running web modules handling requests
+    FIdleWebModules: TList;            //List of idle web modules available
+    FCriticalSection: TCriticalSection;
+    FBaseLocation: String;
+    FBeforeRequest: TBeforeRequestEvent;
+    FHandlerName: String;
+    FModuleName: String;
+    FModules : Array[0..1] of TStrings;
+    FPriority: THandlerPriority;
+    FModuleRecord : PModule;
+    function GetModules(Index: integer): TStrings;
+    procedure SetModules(Index: integer; const AValue: TStrings);
+    function GetIdleModuleCount : Integer;
+    function GetWorkingModuleCount : Integer;
+  Protected
+    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
+    function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
+    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
+    function GetApplicationURL(ARequest : TRequest): String; override;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    Procedure Run; override;
+    Procedure SetModuleRecord(Var ModuleRecord : Module);
+    Procedure Initialize;
+    Procedure LogErrorMessage(Msg : String; LogLevel : integer = APLOG_INFO); virtual;
+    Procedure handleRequest(ARequest : TRequest; AResponse : TResponse); override;
+    Property HandlerPriority : THandlerPriority Read FPriority Write FPriority default hpMiddle;
+    Property BeforeModules : TStrings Index 0 Read GetModules Write SetModules;
+    Property AfterModules : TStrings Index 1 Read GetModules Write SetModules;
+    Property BaseLocation : String Read FBaseLocation Write FBaseLocation;
+    Property ModuleName : String Read FModuleName Write FModuleName;
+    Property HandlerName : String Read FHandlerName Write FHandlerName;
+    Property BeforeRequest : TBeforeRequestEvent Read FBeforeRequest Write FBeforeRequest;
+    Property MaxRequests: Integer read FMaxRequests write FMaxRequests;
+    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
+    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
+  end;
+
+  TCustomApacheApplication = Class(TCustomWebApplication)
+  private
+    function GetAfterModules: TStrings;
+    function GetBaseLocation: String;
+    function GetBeforeModules: TStrings;
+    function GetBeforeRequest: TBeforeRequestEvent;
+    function GetHandlerName: String;
+    function GetIdleModuleCount: Integer;
+    function GetMaxRequests: Integer;
+    function GetModuleName: String;
+    function GetPriority: THandlerPriority;
+    function GetWorkingModuleCount: Integer;
+    procedure SetAfterModules(const AValue: TStrings);
+    procedure SetBaseLocation(const AValue: String);
+    procedure SetBeforeModules(const AValue: TStrings);
+    procedure SetBeforeRequest(const AValue: TBeforeRequestEvent);
+    procedure SetHandlerName(const AValue: String);
+    procedure SetMaxRequests(const AValue: Integer);
+    procedure SetModuleName(const AValue: String);
+    procedure SetPriority(const AValue: THandlerPriority);
+  public
+    function InitializeWebHandler: TWebHandler; override;
+    Procedure Initialize;override;
+    procedure ShowException(E: Exception); override;
+    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
+    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
+    Procedure SetModuleRecord(Var ModuleRecord : Module);
+    Property HandlerPriority : THandlerPriority Read GetPriority Write SetPriority default hpMiddle;
+    Property BeforeModules : TStrings Read GetBeforeModules Write SetBeforeModules;
+    Property AfterModules : TStrings Read GetAfterModules Write SetAfterModules;
+    Property BaseLocation : String Read GetBaseLocation Write SetBaseLocation;
+    Property ModuleName : String Read GetModuleName Write SetModuleName;
+    Property HandlerName : String Read GetHandlerName Write SetHandlerName;
+    Property BeforeRequest : TBeforeRequestEvent Read GetBeforeRequest Write SetBeforeRequest;
+    Property MaxRequests: Integer read GetMaxRequests write SetMaxRequests;
+    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
+    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
+  end;
+
+  EFPApacheError = Class(EHTTP);
+
+Var
+  Application : TCustomApacheApplication = Nil;
+  ShowCleanUpErrors : Boolean = False;
+  AlternateHandler : ap_hook_handler_t = Nil;
+
+
+implementation
+uses CustApp;
+
+resourcestring
+  SErrNoModuleNameForRequest = 'Could not determine HTTP module name for request';
+  SErrNoModuleForRequest = 'Could not determine HTTP module for request "%s"';
+  SErrNoModuleRecord = 'No module record location set.';
+  SErrNoModuleName = 'No module name set';
+  SErrTooManyRequests = 'Too many simultaneous requests.';
+
+const
+  HPRIO : Array[THandlerPriority] of Integer
+        = (APR_HOOK_FIRST,APR_HOOK_MIDDLE,APR_HOOK_LAST);
+
+
+
+Function DefaultApacheHandler(P : PRequest_Rec) : integer;cdecl;
+
+begin
+  If (AlternateHandler<>Nil) then
+    Result:=AlternateHandler(P)
+  else
+    If Application.AllowRequest(P) then
+      Result:=Application.ProcessRequest(P)
+    else
+      Result:=DECLINED;
+end;
+
+Procedure RegisterApacheHooks(P: PApr_pool_t);cdecl;
+
+Var
+  H : ap_hook_handler_t;
+  PP1,PP2 : PPChar;
+
+begin
+  H:=AlternateHandler;
+  If (H=Nil) then
+    H:=@DefaultApacheHandler;
+  PP1:=Nil;
+  PP2:=Nil;
+  ap_hook_handler(H,PP1,PP2,HPRIO[Application.HandlerPriority]);
+end;
+
+{ TApacheHandler }
+
+function TApacheHandler.GetModules(Index: integer): TStrings;
+begin
+  If (FModules[Index]=Nil) then
+    FModules[Index]:=TStringList.Create;
+  Result:=FModules[Index];
+end;
+
+procedure TApacheHandler.SetModules(Index: integer;
+  const AValue: TStrings);
+begin
+  If (FModules[Index]=Nil) then
+    FModules[Index]:=TStringList.Create;
+  FModules[Index].Assign(AValue);
+end;
+
+Function TApacheHandler.ProcessRequest(P: PRequest_Rec) : Integer;
+
+Var
+  Req : TApacheRequest;
+  Resp : TApacheResponse;
+
+begin
+  Req:=TApacheRequest.CreateReq(Self,P);
+  Try
+    InitRequest(Req);
+    Req.InitRequestVars;
+    Resp:=TApacheResponse.CreateApache(Req);
+    Try
+      InitResponse(Resp);
+      HandleRequest(Req,Resp);
+      If Not Resp.ContentSent then
+        Resp.SendContent;
+    Finally
+      Result:=OK;
+      Resp.Free;
+    end;
+  Finally
+    Req.Free;
+  end;
+end;
+
+procedure TApacheHandler.Run;
+begin
+  // Do nothing. This is a library
+  Initialize;
+end;
+
+function TApacheHandler.WaitForRequest(out ARequest: TRequest; out AResponse: TResponse): boolean;
+begin
+  Result:=False;
+  ARequest:=Nil;
+  AResponse:=Nil;
+end;
+
+function TApacheHandler.AllowRequest(P: PRequest_Rec): Boolean;
+
+Var
+  Hn : String;
+
+begin
+  HN:=StrPas(p^.Handler);
+  Result:=CompareText(HN,FHandlerName)=0;
+  If Assigned(FBeforeRequest) then
+    FBeforeRequest(Self,HN,Result);
+end;
+
+function TApacheHandler.GetApplicationURL(ARequest: TRequest): String;
+begin
+  Result:=inherited GetApplicationURL(ARequest);
+  If (Result='') then
+    Result:=BaseLocation;
+end;
+
+constructor TApacheHandler.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FPriority:=hpMiddle;
+  FMaxRequests:=64;
+  FWorkingWebModules:=TList.Create;
+  FIdleWebModules:=TList.Create;
+  FCriticalSection:=TCriticalSection.Create;
+end;
+
+destructor TApacheHandler.Destroy;
+var I:Integer;
+begin
+  FCriticalSection.Free;
+  for I := FIdleWebModules.Count - 1 downto 0 do
+    TComponent(FIdleWebModules[I]).Free;
+  FIdleWebModules.Free;
+  for I := FWorkingWebModules.Count - 1 downto 0 do
+    TComponent(FWorkingWebModules[I]).Free;
+  FWorkingWebModules.Free;
+  inherited Destroy;
+end;
+
+
+procedure TApacheHandler.SetModuleRecord(var ModuleRecord: Module);
+begin
+  FModuleRecord:=@ModuleRecord;
+  FillChar(ModuleRecord,SizeOf(ModuleRecord),0);
+end;
+
+procedure TApacheHandler.Initialize;
+
+begin
+  If (FModuleRecord=nil) then
+    Raise EFPApacheError.Create(SErrNoModuleRecord);
+  if (FModuleName='') and (FModuleRecord^.Name=Nil) then
+    Raise EFPApacheError.Create(SErrNoModuleName);
+  STANDARD20_MODULE_STUFF(FModuleRecord^);
+  If (StrPas(FModuleRecord^.name)<>FModuleName) then
+    FModuleRecord^.Name:=PChar(FModuleName);
+  FModuleRecord^.register_hooks:=@RegisterApacheHooks;
+end;
+
+procedure TApacheHandler.LogErrorMessage(Msg: String; LogLevel: integer);
+var a: ap_version_t;
+begin
+  ap_log_error(pchar(FModuleName),  //The file in which this function is called
+               0,                   //The line number on which this function is called
+               0,                   //The module_index of the module generating this message
+               LogLevel,            //The level of this error message
+               0,                   //The status code from the previous command
+               Nil,                 //The server on which we are logging
+               'module: %s',        //The format string
+               [pchar(Msg)])        //The arguments to use to fill out fmt.
+end;
+
+function TApacheHandler.GetIdleModuleCount : Integer;
+begin
+  FCriticalSection.Enter;
+  try
+    Result := FIdleWebModules.Count;
+  finally
+    FCriticalSection.Leave;
+  end;
+end;
+
+function TApacheHandler.GetWorkingModuleCount : Integer;
+begin
+  FCriticalSection.Enter;
+  try
+    Result := FWorkingWebModules.Count;
+  finally
+    FCriticalSection.Leave;
+  end;
+end;
+
+procedure TApacheHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
+
+Var
+  MC : TCustomHTTPModuleClass;
+  M  : TCustomHTTPModule;
+  MN : String;
+  MI : TModuleItem;
+
+  Procedure GetAWebModule;
+  Var II:Integer;
+  begin
+    FCriticalSection.Enter;
+    try
+      if (FMaxRequests>0) and (FWorkingWebModules.Count>=FMaxRequests) then
+        Raise EFPApacheError.Create(SErrTooManyRequests);
+      if (FIdleWebModules.Count>0) then
+      begin
+        II := FIdleWebModules.Count - 1;
+        while (II>=0) and not (TComponent(FIdleWebModules[II]) is MC) do
+          Dec(II);
+        if (II>=0) then
+        begin
+          M:=TCustomHTTPModule(FIdleWebModules[II]);
+          FIdleWebModules.Delete(II);
+        end;
+      end;
+      if (M=nil) then
+      begin
+        M:=MC.Create(Self);
+        M.Name := '';
+      end;
+      FWorkingWebModules.Add(M);
+    finally
+      FCriticalSection.Leave;
+    end;
+  end;
+
+begin
+  try
+    MC:=Nil;
+    M := Nil;
+    If (OnGetModule<>Nil) then
+      OnGetModule(Self,ARequest,MC);
+    If (MC=Nil) then
+    begin
+      MN:=GetModuleName(ARequest);
+      If (MN='') and Not AllowDefaultModule then
+        Raise EFPApacheError.Create(SErrNoModuleNameForRequest);
+      MI:=ModuleFactory.FindModule(MN);
+      If (MI=Nil) and (ModuleFactory.Count=1) then
+        MI:=ModuleFactory[0];
+      if (MI=Nil) then
+        Raise EFPApacheError.CreateFmt(SErrNoModuleForRequest,[MN]);
+
+      MC:=MI.ModuleClass;
+    end;
+    GetAWebModule;
+    M.HandleRequest(ARequest,AResponse);
+
+    FCriticalSection.Enter;
+    try
+      FWorkingWebModules.Remove(M);
+      FIdleWebModules.Add(M);
+    finally
+      FCriticalSection.Leave;
+    end;
+  except
+    On E : Exception do
+      begin
+      LogErrorMessage(E.Message,APLOG_ERR);
+      ShowRequestException(AResponse,E);
+      end;
+  end;
+end;
+
+{ TApacheRequest }
+
+function TApacheRequest.GetFieldValue(Index: Integer): String;
+
+  Function MaybeP(P : Pchar) : String;
+
+  begin
+    If (P<>Nil) then
+      Result:=StrPas(P);
+  end;
+
+var
+  FN : String;
+  I : Integer;
+
+begin
+  Result:='';
+  If (Index in [1..NoHTTPFields]) then
+    begin
+    FN:=HTTPFieldNames[Index];
+    Result:=MaybeP(apr_table_get(FRequest^.headers_in,pchar(FN)));
+    end;
+  if (Result='') and Assigned(FRequest) then
+    case Index of
+      0  : Result:=MaybeP(FRequest^.protocol); // ProtocolVersion
+      7  : Result:=MaybeP(FRequest^.content_encoding); //ContentEncoding
+      25 : Result:=MaybeP(FRequest^.path_info); // PathInfo
+      26 : Result:=MaybeP(FRequest^.filename); // PathTranslated
+      27 : // RemoteAddr
+           If (FRequest^.Connection<>Nil) then
+             Result:=MaybeP(FRequest^.Connection^.remote_ip);
+      28 : // RemoteHost
+           If (FRequest^.Connection<>Nil) then
+             begin
+             Result:=MaybeP(ap_get_remote_host(FRequest^.Connection,
+                            FRequest^.per_dir_config,
+//                            nil,
+                            REMOTE_NAME,@i));
+             end;
+      29 : begin // ScriptName
+           Result:=MaybeP(FRequest^.unparsed_uri);
+           I:=Pos('?',Result)-1;
+           If (I=-1) then
+             I:=Length(Result);
+           Result:=Copy(Result,1,I-Length(PathInfo));
+           end;
+      30 : Result:=IntToStr(ap_get_server_port(FRequest)); // ServerPort
+      31 : Result:=MaybeP(FRequest^.method); // Method
+      32 : Result:=MaybeP(FRequest^.unparsed_uri); // URL
+      33 : Result:=MaybeP(FRequest^.args); // Query
+      34 : Result:=MaybeP(FRequest^.HostName); // Host
+    else
+      Result:=inherited GetFieldValue(Index);
+    end;
+end;
+
+procedure TApacheRequest.ReadContent;
+
+  Function MinS(A,B : Integer) : Integer;
+
+  begin
+    If A<B then
+      Result:=A
+    else
+      Result:=B;
+  end;
+
+Var
+  Left,Len,Count,Bytes : Integer;
+  P : Pchar;
+  S : String;
+
+begin
+  ap_setup_client_block(FRequest,REQUEST_CHUNKED_DECHUNK);
+  If (ap_should_client_block(FRequest)=1) then
+    begin
+    Len:=ContentLength;
+    If (Len>0) then
+      begin
+      SetLength(S,Len);
+      P:=PChar(S);
+      Left:=Len;
+      Count:=0;
+      Repeat
+        Bytes:=ap_get_client_block(FRequest,P,MinS(10*1024,Left));
+        Dec(Left,Bytes);
+        Inc(P,Bytes);
+        Inc(Count,Bytes);
+      Until (Count>=Len) or (Bytes=0);
+      SetLength(S,Count);
+      end;
+    end;
+  InitContent(S);
+end;
+
+procedure TApacheRequest.InitFromRequest;
+begin
+  ParseCookies;
+end;
+
+Constructor TApacheRequest.CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
+
+begin
+  FApache:=App;
+  FRequest:=Arequest;
+  ReturnedPathInfo:=App.BaseLocation;
+  Inherited Create;
+  InitFromRequest;
+end;
+
+{ TApacheResponse }
+
+procedure TApacheResponse.DoSendHeaders(Headers: TStrings);
+
+Var
+  I,P : Integer;
+  N,V : String;
+
+begin
+  For I:=0 to Headers.Count-1 do
+    begin
+    V:=Headers[i];
+    P:=Pos(':',V);
+    If (P<>0) and (P<Length(V)) then
+      begin
+      N:=Copy(V,1,P-1);
+      System.Delete(V,1,P);
+      V := Trim(V);//no need space before the value, apache puts it there
+      apr_table_set(FRequest^.headers_out,Pchar(N),Pchar(V));
+      end;
+    end;
+end;
+
+procedure TApacheResponse.DoSendContent;
+
+Var
+  S : String;
+  I : Integer;
+
+begin
+  S:=ContentType;
+  If (S<>'') then
+    FRequest^.content_type:=apr_pstrdup(FRequest^.pool,Pchar(S));
+  S:=ContentEncoding;
+  If (S<>'') then
+    FRequest^.content_encoding:=apr_pstrdup(FRequest^.pool,Pchar(S));
+  If Code <> 200 then
+    FRequest^.status := Code;
+  If assigned(ContentStream) then
+    SendStream(Contentstream)
+  else
+    for I:=0 to Contents.Count-1 do
+      begin
+      S:=Contents[i]+LineEnding;
+      // If there is a null, it's written also with ap_rwrite
+      ap_rwrite(PChar(S),Length(S),FRequest);
+      end;
+end;
+
+Procedure TApacheResponse.SendStream(S : TStream);
+
+Var
+  Buf : Array[0..(10*1024)-1] of Byte;
+  Count : Integer;
+
+begin
+  S.Seek(0,soBeginning);
+  Repeat
+    Count:=S.Read(Buf,SizeOf(Buf));
+    If Count>0 then
+      ap_rwrite(@Buf,Count,FRequest);
+  Until (Count=0);
+end;
+
+
+Constructor TApacheResponse.CreateApache(Req : TApacheRequest);
+begin
+  FApache:=Req.ApacheApp;
+  Frequest:=Req.ApacheRequest;
+  Inherited Create(Req);
+end;
+
+function __dummythread(p: pointer): ptrint;
+begin
+  sleep(1000);
+  Result:=0;
+end;
+
+{ TCustomApacheApplication }
+
+function TCustomApacheApplication.GetAfterModules: TStrings;
+begin
+  result := TApacheHandler(WebHandler).AfterModules;
+end;
+
+function TCustomApacheApplication.GetBaseLocation: String;
+begin
+  result := TApacheHandler(WebHandler).BaseLocation;
+end;
+
+function TCustomApacheApplication.GetBeforeModules: TStrings;
+begin
+  result := TApacheHandler(WebHandler).BeforeModules;
+end;
+
+function TCustomApacheApplication.GetBeforeRequest: TBeforeRequestEvent;
+begin
+  result := TApacheHandler(WebHandler).BeforeRequest;
+end;
+
+function TCustomApacheApplication.GetHandlerName: String;
+begin
+  result := TApacheHandler(WebHandler).HandlerName;
+end;
+
+function TCustomApacheApplication.GetIdleModuleCount: Integer;
+begin
+  result := TApacheHandler(WebHandler).IdleWebModuleCount;
+end;
+
+function TCustomApacheApplication.GetMaxRequests: Integer;
+begin
+  result := TApacheHandler(WebHandler).MaxRequests;
+end;
+
+function TCustomApacheApplication.GetModuleName: String;
+begin
+  result := TApacheHandler(WebHandler).ModuleName;
+end;
+
+function TCustomApacheApplication.GetPriority: THandlerPriority;
+begin
+  result := TApacheHandler(WebHandler).HandlerPriority;
+end;
+
+function TCustomApacheApplication.GetWorkingModuleCount: Integer;
+begin
+  result := TApacheHandler(WebHandler).WorkingWebModuleCount;
+end;
+
+procedure TCustomApacheApplication.SetAfterModules(const AValue: TStrings);
+begin
+  TApacheHandler(WebHandler).AfterModules := AValue;
+end;
+
+procedure TCustomApacheApplication.SetBaseLocation(const AValue: String);
+begin
+  TApacheHandler(WebHandler).BaseLocation := AValue;
+end;
+
+procedure TCustomApacheApplication.SetBeforeModules(const AValue: TStrings);
+begin
+  TApacheHandler(WebHandler).BeforeModules := AValue;
+end;
+
+procedure TCustomApacheApplication.SetBeforeRequest(const AValue: TBeforeRequestEvent);
+begin
+  TApacheHandler(WebHandler).BeforeRequest := AValue;
+end;
+
+procedure TCustomApacheApplication.SetHandlerName(const AValue: String);
+begin
+  TApacheHandler(WebHandler).HandlerName := AValue;
+end;
+
+procedure TCustomApacheApplication.SetMaxRequests(const AValue: Integer);
+begin
+  TApacheHandler(WebHandler).MaxRequests := AValue;
+end;
+
+procedure TCustomApacheApplication.SetModuleName(const AValue: String);
+begin
+  TApacheHandler(WebHandler).ModuleName := AValue;
+end;
+
+procedure TCustomApacheApplication.SetPriority(const AValue: THandlerPriority);
+begin
+  TApacheHandler(WebHandler).HandlerPriority := AValue;
+end;
+
+function TCustomApacheApplication.InitializeWebHandler: TWebHandler;
+begin
+  Result:=TApacheHandler.Create(self);
+end;
+
+procedure TCustomApacheApplication.Initialize;
+begin
+  Inherited;
+  TApacheHandler(WebHandler).Initialize;
+end;
+
+procedure TCustomApacheApplication.ShowException(E: Exception);
+begin
+  ap_log_error(PChar(TApacheHandler(WebHandler).ModuleName),  //The file in which this function is called
+               0,                                             //The line number on which this function is called
+               0,                                             //The module_index of the module generating this message
+               APLOG_ERR,                                     //The level of this error message
+               0,                                             //The status code from the previous command
+               Nil,                                           //The server on which we are logging
+               'module: %s',                                  //The format string
+               [Pchar(E.Message)]);                           //The arguments to use to fill out fmt.
+end;
+
+function TCustomApacheApplication.ProcessRequest(P: PRequest_Rec): Integer;
+begin
+  result := TApacheHandler(WebHandler).ProcessRequest(p);
+end;
+
+function TCustomApacheApplication.AllowRequest(P: PRequest_Rec): Boolean;
+begin
+  result := TApacheHandler(WebHandler).AllowRequest(p);
+end;
+
+procedure TCustomApacheApplication.SetModuleRecord(var ModuleRecord: Module);
+begin
+  TApacheHandler(WebHandler).SetModuleRecord(ModuleRecord);
+end;
+
+Initialization
+  BeginThread(@__dummythread);//crash prevention for simultaneous requests
+end.
+

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

@@ -353,7 +353,7 @@ procedure TCGIRequest.InitFromEnvironment;
 
 Var
   I : Integer;
-  V,OV : String;
+  R,V,OV : String;
   M : TMap;
   
 begin
@@ -373,7 +373,9 @@ begin
         end;
       end;
     end;
-  ReadContent;
+  R:=UpCase(Method);
+  if (R='POST') or (R='PUT') or (ContentLength>0) then
+    ReadContent;
 end;
 
 procedure TCGIRequest.ReadContent;

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

@@ -384,6 +384,13 @@ begin
       begin
       // TODO : Better checking on ErrorCode
       R.FKeepConnectionAfterRequest:=False;
+
+{$ifdef windowspipe}
+      case ErrorCode of
+        ERROR_BROKEN_PIPE, ERROR_NO_DATA : Exit; //No error here. Server cancel pipe
+      end;
+{$endif}
+
       TFCgiHandler.DoError(SErrWritingSocket,[ErrorCode]);
       end;
     Inc(P,BytesWritten);
@@ -899,7 +906,7 @@ begin
 {$else windowspipe}
   if Not fIsWinPipe then
     Result:=fpaccept(Socket,Nil,Nil);
-  If FIsWinPipe or ((Result<0) and (socketerror=10038)) then
+  If FIsWinPipe or ((Result<0) and ((socketerror=10038) or (socketerror = 10022))) then
     begin
     Result:=-1;
     B:=ConnectNamedPipe(Socket,Nil);

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

@@ -18,129 +18,16 @@ unit fpapache;
 interface
 
 uses
-  SysUtils,Classes,CustWeb,httpDefs,fpHTTP,httpd,httpprotocol, apr, SyncObjs;
+  sysutils, custapp, custapache;
 
 Type
-
-  TApacheHandler = Class;
-
-  { TApacheRequest }
-
-  TApacheRequest = Class(TRequest)
-  Private
-    FApache : TApacheHandler;
-    FRequest : PRequest_rec;
-  Protected
-    Procedure InitFromRequest;
-    procedure ReadContent; override;
-  Public
-    Constructor CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
-    Function GetCustomHeader(const Name: String) : String; override;
-    Property ApacheRequest : Prequest_rec Read FRequest;
-    Property ApacheApp : TApacheHandler Read FApache;
-  end;
-
-  { TApacheResponse }
-
-  TApacheResponse = Class(TResponse)
-  private
-    FApache : TApacheHandler;
-    FRequest : PRequest_rec;
-    procedure SendStream(S: TStream);
-  Protected
-    Procedure DoSendHeaders(Headers : TStrings); override;
-    Procedure DoSendContent; override;
-  Public
-    Constructor CreateApache(Req : TApacheRequest);
-    Property ApacheRequest : Prequest_rec Read FRequest;
-    Property ApacheApp : TApacheHandler Read FApache;
-  end;
-
-  { TCustomApacheApplication }
-  THandlerPriority = (hpFirst,hpMiddle,hpLast);
-  TBeforeRequestEvent = Procedure(Sender : TObject; Const AHandler : String;
-                                  Var AllowRequest : Boolean) of object;
-
-  TApacheHandler = Class(TWebHandler)
-  private
-    FMaxRequests: Integer;             //Maximum number of simultaneous web module requests (default=64, if set to zero no limit)
-    FWorkingWebModules: TList;         //List of currently running web modules handling requests
-    FIdleWebModules: TList;            //List of idle web modules available
-    FCriticalSection: TCriticalSection;
-    FBaseLocation: String;
-    FBeforeRequest: TBeforeRequestEvent;
-    FHandlerName: String;
-    FModuleName: String;
-    FModules : Array[0..1] of TStrings;
-    FPriority: THandlerPriority;
-    FModuleRecord : PModule;
-    function GetModules(Index: integer): TStrings;
-    procedure SetModules(Index: integer; const AValue: TStrings);
-    function GetIdleModuleCount : Integer;
-    function GetWorkingModuleCount : Integer;
-  Protected
-    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
-    function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
-    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
-    function GetApplicationURL(ARequest : TRequest): String; override;
-  Public
-    Constructor Create(AOwner : TComponent); override;
-    Destructor Destroy; override;
-    Procedure Run; override;
-    Procedure SetModuleRecord(Var ModuleRecord : Module);
-    Procedure Initialize;
-    Procedure LogErrorMessage(Msg : String; LogLevel : integer = APLOG_INFO); virtual;
-    Procedure handleRequest(ARequest : TRequest; AResponse : TResponse); override;
-    Property HandlerPriority : THandlerPriority Read FPriority Write FPriority default hpMiddle;
-    Property BeforeModules : TStrings Index 0 Read GetModules Write SetModules;
-    Property AfterModules : TStrings Index 1 Read GetModules Write SetModules;
-    Property BaseLocation : String Read FBaseLocation Write FBaseLocation;
-    Property ModuleName : String Read FModuleName Write FModuleName;
-    Property HandlerName : String Read FHandlerName Write FHandlerName;
-    Property BeforeRequest : TBeforeRequestEvent Read FBeforeRequest Write FBeforeRequest;
-    Property MaxRequests: Integer read FMaxRequests write FMaxRequests;
-    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
-    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
-  end;
-
-  TCustomApacheApplication = Class(TCustomWebApplication)
-  private
-    function GetAfterModules: TStrings;
-    function GetBaseLocation: String;
-    function GetBeforeModules: TStrings;
-    function GetBeforeRequest: TBeforeRequestEvent;
-    function GetHandlerName: String;
-    function GetIdleModuleCount: Integer;
-    function GetMaxRequests: Integer;
-    function GetModuleName: String;
-    function GetPriority: THandlerPriority;
-    function GetWorkingModuleCount: Integer;
-    procedure SetAfterModules(const AValue: TStrings);
-    procedure SetBaseLocation(const AValue: String);
-    procedure SetBeforeModules(const AValue: TStrings);
-    procedure SetBeforeRequest(const AValue: TBeforeRequestEvent);
-    procedure SetHandlerName(const AValue: String);
-    procedure SetMaxRequests(const AValue: Integer);
-    procedure SetModuleName(const AValue: String);
-    procedure SetPriority(const AValue: THandlerPriority);
-  public
-    function InitializeWebHandler: TWebHandler; override;
-    Procedure Initialize;override;
-    procedure ShowException(E: Exception); override;
-    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
-    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
-    Procedure SetModuleRecord(Var ModuleRecord : Module);
-    Property HandlerPriority : THandlerPriority Read GetPriority Write SetPriority default hpMiddle;
-    Property BeforeModules : TStrings Read GetBeforeModules Write SetBeforeModules;
-    Property AfterModules : TStrings Read GetAfterModules Write SetAfterModules;
-    Property BaseLocation : String Read GetBaseLocation Write SetBaseLocation;
-    Property ModuleName : String Read GetModuleName Write SetModuleName;
-    Property HandlerName : String Read GetHandlerName Write SetHandlerName;
-    Property BeforeRequest : TBeforeRequestEvent Read GetBeforeRequest Write SetBeforeRequest;
-    Property MaxRequests: Integer read GetMaxRequests write SetMaxRequests;
-    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
-    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
-  end;
+  // Backwards compatibility defines.
+  TApacheHandler = custapache.TApacheHandler;
+  TApacheRequest = custapache.TApacheRequest;
+  TApacheResponse = custapache.TApacheResponse;
+  THandlerPriority = custapache.THandlerPriority;
+  TBeforeRequestEvent = custapache.TBeforeRequestEvent;
+  TCustomApacheApplication = custapache.TCustomApacheApplication;
 
   TApacheApplication = Class(TCustomApacheApplication)
   Public
@@ -155,41 +42,13 @@ Type
     Property IdleWebModuleCount;
     Property WorkingWebModuleCount;
   end;
-  
-
-  EFPApacheError = Class(EHTTP);
-  
-Var
-  Application : TCustomApacheApplication = Nil;
-  ShowCleanUpErrors : Boolean = False;
-  AlternateHandler : ap_hook_handler_t = Nil;
 
 Implementation
 
-uses CustApp;
-
-resourcestring
-  SErrNoModuleNameForRequest = 'Could not determine HTTP module name for request';
-  SErrNoModuleForRequest = 'Could not determine HTTP module for request "%s"';
-  SErrNoModuleRecord = 'No module record location set.';
-  SErrNoModuleName = 'No module name set';
-  SErrTooManyRequests = 'Too many simultaneous requests.';
-
-const
-  HPRIO : Array[THandlerPriority] of Integer
-        = (APR_HOOK_FIRST,APR_HOOK_MIDDLE,APR_HOOK_LAST);
-
-Function MaybeP(P : Pchar) : String;
-
-begin
-  If (P<>Nil) then
-    Result:=StrPas(P);
-end;
-
 Procedure InitApache;
 
 begin
-  Application:=TCustomApacheApplication.Create(Nil);
+  Application:=TApacheApplication.Create(Nil);
   if not assigned(CustomApplication) then
     CustomApplication := Application;
 end;
@@ -207,552 +66,7 @@ begin
   end;
 end;
 
-Function DefaultApacheHandler(P : PRequest_Rec) : integer;cdecl;
-
-begin
-  If (AlternateHandler<>Nil) then
-    Result:=AlternateHandler(P)
-  else
-    If Application.AllowRequest(P) then
-      Result:=Application.ProcessRequest(P)
-    else
-      Result:=DECLINED;
-end;
-
-Procedure RegisterApacheHooks(P: PApr_pool_t);cdecl;
-
-Var
-  H : ap_hook_handler_t;
-  PP1,PP2 : PPChar;
-
-begin
-  H:=AlternateHandler;
-  If (H=Nil) then
-    H:=@DefaultApacheHandler;
-  PP1:=Nil;
-  PP2:=Nil;
-  ap_hook_handler(H,PP1,PP2,HPRIO[Application.HandlerPriority]);
-end;
-
-{ TApacheHandler }
-
-function TApacheHandler.GetModules(Index: integer): TStrings;
-begin
-  If (FModules[Index]=Nil) then
-    FModules[Index]:=TStringList.Create;
-  Result:=FModules[Index];
-end;
-
-procedure TApacheHandler.SetModules(Index: integer;
-  const AValue: TStrings);
-begin
-  If (FModules[Index]=Nil) then
-    FModules[Index]:=TStringList.Create;
-  FModules[Index].Assign(AValue);
-end;
-
-Function TApacheHandler.ProcessRequest(P: PRequest_Rec) : Integer;
-
-Var
-  Req : TApacheRequest;
-  Resp : TApacheResponse;
-
-begin
-  Req:=TApacheRequest.CreateReq(Self,P);
-  Try
-    InitRequest(Req);
-    Req.InitRequestVars;
-    Resp:=TApacheResponse.CreateApache(Req);
-    Try
-      InitResponse(Resp);
-      HandleRequest(Req,Resp);
-      If Not Resp.ContentSent then
-        Resp.SendContent;
-    Finally
-      Result:=OK;
-      Resp.Free;
-    end;
-  Finally
-    Req.Free;
-  end;
-end;
-
-procedure TApacheHandler.Run;
-begin
-  // Do nothing. This is a library
-  Initialize;
-end;
-
-function TApacheHandler.WaitForRequest(out ARequest: TRequest; out AResponse: TResponse): boolean;
-begin
-  Result:=False;
-  ARequest:=Nil;
-  AResponse:=Nil;
-end;
-
-function TApacheHandler.AllowRequest(P: PRequest_Rec): Boolean;
-
-Var
-  Hn : String;
-
-begin
-  HN:=StrPas(p^.Handler);
-  Result:=CompareText(HN,FHandlerName)=0;
-  If Assigned(FBeforeRequest) then
-    FBeforeRequest(Self,HN,Result);
-end;
-
-function TApacheHandler.GetApplicationURL(ARequest: TRequest): String;
-begin
-  Result:=inherited GetApplicationURL(ARequest);
-  If (Result='') then
-    Result:=BaseLocation;
-end;
-
-constructor TApacheHandler.Create(AOwner: TComponent);
-begin
-  inherited Create(AOwner);
-  FPriority:=hpMiddle;
-  FMaxRequests:=64;
-  FWorkingWebModules:=TList.Create;
-  FIdleWebModules:=TList.Create;
-  FCriticalSection:=TCriticalSection.Create;
-end;
-
-destructor TApacheHandler.Destroy;
-var I:Integer;
-begin
-  FCriticalSection.Free;
-  for I := FIdleWebModules.Count - 1 downto 0 do
-    TComponent(FIdleWebModules[I]).Free;
-  FIdleWebModules.Free;
-  for I := FWorkingWebModules.Count - 1 downto 0 do
-    TComponent(FWorkingWebModules[I]).Free;
-  FWorkingWebModules.Free;
-  inherited Destroy;
-end;
-
-
-procedure TApacheHandler.SetModuleRecord(var ModuleRecord: Module);
-begin
-  FModuleRecord:=@ModuleRecord;
-  FillChar(ModuleRecord,SizeOf(ModuleRecord),0);
-end;
-
-procedure TApacheHandler.Initialize;
-
-begin
-  If (FModuleRecord=nil) then
-    Raise EFPApacheError.Create(SErrNoModuleRecord);
-  if (FModuleName='') and (FModuleRecord^.Name=Nil) then
-    Raise EFPApacheError.Create(SErrNoModuleName);
-  STANDARD20_MODULE_STUFF(FModuleRecord^);
-  If (StrPas(FModuleRecord^.name)<>FModuleName) then
-    FModuleRecord^.Name:=PChar(FModuleName);
-  FModuleRecord^.register_hooks:=@RegisterApacheHooks;
-end;
-
-procedure TApacheHandler.LogErrorMessage(Msg: String; LogLevel: integer);
-begin
-  ap_log_error(pchar(FModuleName),0,LogLevel,0,Nil,'module: %s',[pchar(Msg)]);
-end;
-
-function TApacheHandler.GetIdleModuleCount : Integer;
-begin
-  FCriticalSection.Enter;
-  try
-    Result := FIdleWebModules.Count;
-  finally
-    FCriticalSection.Leave;
-  end;
-end;
-
-function TApacheHandler.GetWorkingModuleCount : Integer;
-begin
-  FCriticalSection.Enter;
-  try
-    Result := FWorkingWebModules.Count;
-  finally
-    FCriticalSection.Leave;
-  end;
-end;
-
-procedure TApacheHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
-
-Var
-  MC : TCustomHTTPModuleClass;
-  M  : TCustomHTTPModule;
-  MN : String;
-  MI : TModuleItem;
-
-  Procedure GetAWebModule;
-  Var II:Integer;
-  begin
-    FCriticalSection.Enter;
-    try
-      if (FMaxRequests>0) and (FWorkingWebModules.Count>=FMaxRequests) then
-        Raise EFPApacheError.Create(SErrTooManyRequests);
-      if (FIdleWebModules.Count>0) then
-      begin
-        II := FIdleWebModules.Count - 1;
-        while (II>=0) and not (TComponent(FIdleWebModules[II]) is MC) do
-          Dec(II);
-        if (II>=0) then
-        begin
-          M:=TCustomHTTPModule(FIdleWebModules[II]);
-          FIdleWebModules.Delete(II);
-        end;
-      end;
-      if (M=nil) then
-      begin
-        M:=MC.Create(Self);
-        M.Name := '';
-      end;
-      FWorkingWebModules.Add(M);
-    finally
-      FCriticalSection.Leave;
-    end;
-  end;
-
-begin
-  try
-    MC:=Nil;
-    M := Nil;
-    If (OnGetModule<>Nil) then
-      OnGetModule(Self,ARequest,MC);
-    If (MC=Nil) then
-    begin
-      MN:=GetModuleName(ARequest);
-      If (MN='') and Not AllowDefaultModule then
-        Raise EFPApacheError.Create(SErrNoModuleNameForRequest);
-      MI:=ModuleFactory.FindModule(MN);
-      If (MI=Nil) and (ModuleFactory.Count=1) then
-        MI:=ModuleFactory[0];
-      if (MI=Nil) then
-        Raise EFPApacheError.CreateFmt(SErrNoModuleForRequest,[MN]);
-
-      MC:=MI.ModuleClass;
-    end;
-    GetAWebModule;
-    M.HandleRequest(ARequest,AResponse);
-
-    FCriticalSection.Enter;
-    try
-      FWorkingWebModules.Remove(M);
-      FIdleWebModules.Add(M);
-    finally
-      FCriticalSection.Leave;
-    end;
-  except
-    On E : Exception do
-      begin
-      LogErrorMessage(E.Message,APLOG_ERR);
-      ShowRequestException(AResponse,E);
-      end;
-  end;
-end;
-
-{ TApacheRequest }
-
-procedure TApacheRequest.ReadContent;
-
-  Function MinS(A,B : Integer) : Integer;
-  
-  begin
-    If A<B then
-      Result:=A
-    else
-      Result:=B;
-  end;
-
-Var
-  Left,Len,Count,Bytes : Integer;
-  P : Pchar;
-  S : String;
-  
-begin
-  ap_setup_client_block(FRequest,REQUEST_CHUNKED_DECHUNK);
-  If (ap_should_client_block(FRequest)=1) then
-    begin
-    Len:=ContentLength;
-    If (Len>0) then
-      begin
-      SetLength(S,Len);
-      P:=PChar(S);
-      Left:=Len;
-      Count:=0;
-      Repeat
-        Bytes:=ap_get_client_block(FRequest,P,MinS(10*1024,Left));
-        Dec(Left,Bytes);
-        Inc(P,Bytes);
-        Inc(Count,Bytes);
-      Until (Count>=Len) or (Bytes=0);
-      SetLength(S,Count);
-      end;
-    end;
-  InitContent(S);
-end;
-
-procedure TApacheRequest.InitFromRequest;
-
-
-Var
-  H : THeader;
-  V : String;
-  I : Integer;
-
-begin
-  ParseCookies;
-  For H in THeader do
-    begin
-    V:=MaybeP(apr_table_get(FRequest^.headers_in,PAnsiChar(HTTPHeaderNames[h])));
-    If (V<>'') then
-      SetHeader(H,V);
-    end;
-  // Some Specials;
-  SetHeader(hhContentEncoding,MaybeP(FRequest^.content_encoding));
-  SetHTTPVariable(hvHTTPVersion,MaybeP(FRequest^.protocol));
-  SetHTTPVariable(hvPathInfo,MaybeP(FRequest^.path_info));
-  SetHTTPVariable(hvPathTranslated,MaybeP(FRequest^.filename));
-  If (FRequest^.Connection<>Nil) then
-    begin
-    SetHTTPVariable(hvRemoteAddress,MaybeP(FRequest^.Connection^.remote_ip));
-    SetHTTPVariable(hvRemoteHost,MaybeP(ap_get_remote_host(FRequest^.Connection,
-                   FRequest^.per_dir_config, REMOTE_NAME,@i)));
-    end;
-  V:=MaybeP(FRequest^.unparsed_uri);
-  I:=Pos('?',V)-1;
-  If (I=-1) then
-    I:=Length(V);
-  SetHTTPVariable(hvScriptName,Copy(V,1,I-Length(PathInfo)));
-  SetHTTPVariable(hvServerPort,IntToStr(ap_get_server_port(FRequest)));
-  SetHTTPVariable(hvMethod,MaybeP(FRequest^.method));
-  SetHTTPVariable(hvURL,FRequest^.unparsed_uri);
-  SetHTTPVariable(hvQuery,MaybeP(FRequest^.args));
-  SetHeader(hhHost,MaybeP(FRequest^.HostName));
-end;
-
-constructor TApacheRequest.CreateReq(App: TApacheHandler; ARequest: PRequest_rec
-  );
-
-begin
-  FApache:=App;
-  FRequest:=Arequest;
-  ReturnedPathInfo:=App.BaseLocation;
-  Inherited Create;
-  InitFromRequest;
-end;
-
-function TApacheRequest.GetCustomHeader(const Name: String): String;
-begin
-  Result:=inherited GetCustomHeader(Name);
-  if Result='' then
-    Result:=MaybeP(apr_table_get(FRequest^.headers_in,pchar(Name)));
-end;
-
-{ TApacheResponse }
-
-procedure TApacheResponse.DoSendHeaders(Headers: TStrings);
-
-Var
-  I,P : Integer;
-  N,V : String;
-
-begin
-  For I:=0 to Headers.Count-1 do
-    begin
-    V:=Headers[i];
-    P:=Pos(':',V);
-    If (P<>0) and (P<Length(V)) then
-      begin
-      N:=Copy(V,1,P-1);
-      System.Delete(V,1,P);
-      V := Trim(V);//no need space before the value, apache puts it there
-      apr_table_set(FRequest^.headers_out,Pchar(N),Pchar(V));
-      end;
-    end;
-end;
-
-procedure TApacheResponse.DoSendContent;
-
-Var
-  S : String;
-  I : Integer;
-
-begin
-  S:=ContentType;
-  If (S<>'') then
-    FRequest^.content_type:=apr_pstrdup(FRequest^.pool,Pchar(S));
-  S:=ContentEncoding;
-  If (S<>'') then
-    FRequest^.content_encoding:=apr_pstrdup(FRequest^.pool,Pchar(S));
-  If Code <> 200 then
-    FRequest^.status := Code;
-  If assigned(ContentStream) then
-    SendStream(Contentstream)
-  else
-    for I:=0 to Contents.Count-1 do
-      begin
-      S:=Contents[i]+LineEnding;
-      // If there is a null, it's written also with ap_rwrite
-      ap_rwrite(PChar(S),Length(S),FRequest);
-      end;
-end;
-
-Procedure TApacheResponse.SendStream(S : TStream);
-
-Var
-  Buf : Array[0..(10*1024)-1] of Byte;
-  Count : Integer;
-
-begin
-  S.Seek(0,soBeginning);
-  Repeat
-    Count:=S.Read(Buf,SizeOf(Buf));
-    If Count>0 then
-      ap_rwrite(@Buf,Count,FRequest);
-  Until (Count=0);
-end;
-
-
-Constructor TApacheResponse.CreateApache(Req : TApacheRequest);
-begin
-  FApache:=Req.ApacheApp;
-  Frequest:=Req.ApacheRequest;
-  Inherited Create(Req);
-end;
-
-function __dummythread(p: pointer): ptrint;
-begin
-  sleep(1000);
-  Result:=0;
-end;
-
-{ TCustomApacheApplication }
-
-function TCustomApacheApplication.GetAfterModules: TStrings;
-begin
-  result := TApacheHandler(WebHandler).AfterModules;
-end;
-
-function TCustomApacheApplication.GetBaseLocation: String;
-begin
-  result := TApacheHandler(WebHandler).BaseLocation;
-end;
-
-function TCustomApacheApplication.GetBeforeModules: TStrings;
-begin
-  result := TApacheHandler(WebHandler).BeforeModules;
-end;
-
-function TCustomApacheApplication.GetBeforeRequest: TBeforeRequestEvent;
-begin
-  result := TApacheHandler(WebHandler).BeforeRequest;
-end;
-
-function TCustomApacheApplication.GetHandlerName: String;
-begin
-  result := TApacheHandler(WebHandler).HandlerName;
-end;
-
-function TCustomApacheApplication.GetIdleModuleCount: Integer;
-begin
-  result := TApacheHandler(WebHandler).IdleWebModuleCount;
-end;
-
-function TCustomApacheApplication.GetMaxRequests: Integer;
-begin
-  result := TApacheHandler(WebHandler).MaxRequests;
-end;
-
-function TCustomApacheApplication.GetModuleName: String;
-begin
-  result := TApacheHandler(WebHandler).ModuleName;
-end;
-
-function TCustomApacheApplication.GetPriority: THandlerPriority;
-begin
-  result := TApacheHandler(WebHandler).HandlerPriority;
-end;
-
-function TCustomApacheApplication.GetWorkingModuleCount: Integer;
-begin
-  result := TApacheHandler(WebHandler).WorkingWebModuleCount;
-end;
-
-procedure TCustomApacheApplication.SetAfterModules(const AValue: TStrings);
-begin
-  TApacheHandler(WebHandler).AfterModules := AValue;
-end;
-
-procedure TCustomApacheApplication.SetBaseLocation(const AValue: String);
-begin
-  TApacheHandler(WebHandler).BaseLocation := AValue;
-end;
-
-procedure TCustomApacheApplication.SetBeforeModules(const AValue: TStrings);
-begin
-  TApacheHandler(WebHandler).BeforeModules := AValue;
-end;
-
-procedure TCustomApacheApplication.SetBeforeRequest(const AValue: TBeforeRequestEvent);
-begin
-  TApacheHandler(WebHandler).BeforeRequest := AValue;
-end;
-
-procedure TCustomApacheApplication.SetHandlerName(const AValue: String);
-begin
-  TApacheHandler(WebHandler).HandlerName := AValue;
-end;
-
-procedure TCustomApacheApplication.SetMaxRequests(const AValue: Integer);
-begin
-  TApacheHandler(WebHandler).MaxRequests := AValue;
-end;
-
-procedure TCustomApacheApplication.SetModuleName(const AValue: String);
-begin
-  TApacheHandler(WebHandler).ModuleName := AValue;
-end;
-
-procedure TCustomApacheApplication.SetPriority(const AValue: THandlerPriority);
-begin
-  TApacheHandler(WebHandler).HandlerPriority := AValue;
-end;
-
-function TCustomApacheApplication.InitializeWebHandler: TWebHandler;
-begin
-  Result:=TApacheHandler.Create(self);
-end;
-
-procedure TCustomApacheApplication.Initialize;
-begin
-  Inherited;
-  TApacheHandler(WebHandler).Initialize;
-end;
-
-procedure TCustomApacheApplication.ShowException(E: Exception);
-begin
-  ap_log_error(pchar(TApacheHandler(WebHandler).ModuleName),0,APLOG_ERR,0,Nil,'module: %s',[Pchar(E.Message)]);
-end;
-
-function TCustomApacheApplication.ProcessRequest(P: PRequest_Rec): Integer;
-begin
-  result := TApacheHandler(WebHandler).ProcessRequest(p);
-end;
-
-function TCustomApacheApplication.AllowRequest(P: PRequest_Rec): Boolean;
-begin
-  result := TApacheHandler(WebHandler).AllowRequest(p);
-end;
-
-procedure TCustomApacheApplication.SetModuleRecord(var ModuleRecord: Module);
-begin
-  TApacheHandler(WebHandler).SetModuleRecord(ModuleRecord);
-end;
-
 Initialization
-  BeginThread(@__dummythread);//crash prevention for simultaneous requests
   InitApache;
   
 Finalization

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

@@ -16,131 +16,18 @@
 unit fpapache24;
 
 interface
-
 uses
-  SysUtils, Classes, CustWeb, httpDefs, fpHTTP, httpd24, apr24, SyncObjs;
+  sysutils, custapp, custapache24;
 
 Type
+  // Backwards compatibility defines.
+  TApacheHandler = custapache24.TApacheHandler;
+  TApacheRequest = custapache24.TApacheRequest;
+  TApacheResponse = custapache24.TApacheResponse;
+  THandlerPriority = custapache24.THandlerPriority;
+  TBeforeRequestEvent = custapache24.TBeforeRequestEvent;
+  TCustomApacheApplication = custapache24.TCustomApacheApplication;
 
-  TApacheHandler = Class;
-
-  { TApacheRequest }
-
-  TApacheRequest = Class(TRequest)
-  Private
-    FApache : TApacheHandler;
-    FRequest : PRequest_rec;
-  Protected
-    Function GetFieldValue(Index : Integer) : String; override;
-    Procedure InitFromRequest;
-    procedure ReadContent; override;
-  Public
-    Constructor CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
-    Property ApacheRequest : Prequest_rec Read FRequest;
-    Property ApacheApp : TApacheHandler Read FApache;
-  end;
-
-  { TApacheResponse }
-
-  TApacheResponse = Class(TResponse)
-  private
-    FApache : TApacheHandler;
-    FRequest : PRequest_rec;
-    procedure SendStream(S: TStream);
-  Protected
-    Procedure DoSendHeaders(Headers : TStrings); override;
-    Procedure DoSendContent; override;
-  Public
-    Constructor CreateApache(Req : TApacheRequest);
-    Property ApacheRequest : Prequest_rec Read FRequest;
-    Property ApacheApp : TApacheHandler Read FApache;
-  end;
-
-  { TCustomApacheApplication }
-  THandlerPriority = (hpFirst,hpMiddle,hpLast);
-  TBeforeRequestEvent = Procedure(Sender : TObject; Const AHandler : String;
-                                  Var AllowRequest : Boolean) of object;
-
-  TApacheHandler = Class(TWebHandler)
-  private
-    FMaxRequests: Integer;             //Maximum number of simultaneous web module requests (default=64, if set to zero no limit)
-    FWorkingWebModules: TList;         //List of currently running web modules handling requests
-    FIdleWebModules: TList;            //List of idle web modules available
-    FCriticalSection: TCriticalSection;
-    FBaseLocation: String;
-    FBeforeRequest: TBeforeRequestEvent;
-    FHandlerName: String;
-    FModuleName: String;
-    FModules : Array[0..1] of TStrings;
-    FPriority: THandlerPriority;
-    FModuleRecord : PModule;
-    function GetModules(Index: integer): TStrings;
-    procedure SetModules(Index: integer; const AValue: TStrings);
-    function GetIdleModuleCount : Integer;
-    function GetWorkingModuleCount : Integer;
-  Protected
-    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
-    function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
-    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
-    function GetApplicationURL(ARequest : TRequest): String; override;
-  Public
-    Constructor Create(AOwner : TComponent); override;
-    Destructor Destroy; override;
-    Procedure Run; override;
-    Procedure SetModuleRecord(Var ModuleRecord : Module);
-    Procedure Initialize;
-    Procedure LogErrorMessage(Msg : String; LogLevel : integer = APLOG_INFO); virtual;
-    Procedure handleRequest(ARequest : TRequest; AResponse : TResponse); override;
-    Property HandlerPriority : THandlerPriority Read FPriority Write FPriority default hpMiddle;
-    Property BeforeModules : TStrings Index 0 Read GetModules Write SetModules;
-    Property AfterModules : TStrings Index 1 Read GetModules Write SetModules;
-    Property BaseLocation : String Read FBaseLocation Write FBaseLocation;
-    Property ModuleName : String Read FModuleName Write FModuleName;
-    Property HandlerName : String Read FHandlerName Write FHandlerName;
-    Property BeforeRequest : TBeforeRequestEvent Read FBeforeRequest Write FBeforeRequest;
-    Property MaxRequests: Integer read FMaxRequests write FMaxRequests;
-    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
-    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
-  end;
-
-  TCustomApacheApplication = Class(TCustomWebApplication)
-  private
-    function GetAfterModules: TStrings;
-    function GetBaseLocation: String;
-    function GetBeforeModules: TStrings;
-    function GetBeforeRequest: TBeforeRequestEvent;
-    function GetHandlerName: String;
-    function GetIdleModuleCount: Integer;
-    function GetMaxRequests: Integer;
-    function GetModuleName: String;
-    function GetPriority: THandlerPriority;
-    function GetWorkingModuleCount: Integer;
-    procedure SetAfterModules(const AValue: TStrings);
-    procedure SetBaseLocation(const AValue: String);
-    procedure SetBeforeModules(const AValue: TStrings);
-    procedure SetBeforeRequest(const AValue: TBeforeRequestEvent);
-    procedure SetHandlerName(const AValue: String);
-    procedure SetMaxRequests(const AValue: Integer);
-    procedure SetModuleName(const AValue: String);
-    procedure SetPriority(const AValue: THandlerPriority);
-  public
-    function InitializeWebHandler: TWebHandler; override;
-    Procedure Initialize;override;
-    procedure ShowException(E: Exception); override;
-    Function ProcessRequest(P : PRequest_Rec) : Integer; virtual;
-    Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
-    Procedure SetModuleRecord(Var ModuleRecord : Module);
-    Property HandlerPriority : THandlerPriority Read GetPriority Write SetPriority default hpMiddle;
-    Property BeforeModules : TStrings Read GetBeforeModules Write SetBeforeModules;
-    Property AfterModules : TStrings Read GetAfterModules Write SetAfterModules;
-    Property BaseLocation : String Read GetBaseLocation Write SetBaseLocation;
-    Property ModuleName : String Read GetModuleName Write SetModuleName;
-    Property HandlerName : String Read GetHandlerName Write SetHandlerName;
-    Property BeforeRequest : TBeforeRequestEvent Read GetBeforeRequest Write SetBeforeRequest;
-    Property MaxRequests: Integer read GetMaxRequests write SetMaxRequests;
-    Property IdleWebModuleCount: Integer read GetIdleModuleCount;
-    Property WorkingWebModuleCount: Integer read GetWorkingModuleCount;
-  end;
 
   TApacheApplication = Class(TCustomApacheApplication)
   Public
@@ -155,35 +42,14 @@ Type
     Property IdleWebModuleCount;
     Property WorkingWebModuleCount;
   end;
-  
 
-  EFPApacheError = Class(EHTTP);
-  
-Var
-  Application : TCustomApacheApplication = Nil;
-  ShowCleanUpErrors : Boolean = False;
-  AlternateHandler : ap_hook_handler_t = Nil;
 
 Implementation
 
-uses CustApp;
-
-resourcestring
-  SErrNoModuleNameForRequest = 'Could not determine HTTP module name for request';
-  SErrNoModuleForRequest = 'Could not determine HTTP module for request "%s"';
-  SErrNoModuleRecord = 'No module record location set.';
-  SErrNoModuleName = 'No module name set';
-  SErrTooManyRequests = 'Too many simultaneous requests.';
-
-const
-  HPRIO : Array[THandlerPriority] of Integer
-        = (APR_HOOK_FIRST,APR_HOOK_MIDDLE,APR_HOOK_LAST);
-
-
 Procedure InitApache;
 
 begin
-  Application:=TCustomApacheApplication.Create(Nil);
+  Application:=TApacheApplication.Create(Nil);
   if not assigned(CustomApplication) then
     CustomApplication := Application;
 end;
@@ -201,579 +67,9 @@ begin
   end;
 end;
 
-Function DefaultApacheHandler(P : PRequest_Rec) : integer;cdecl;
-
-begin
-  If (AlternateHandler<>Nil) then
-    Result:=AlternateHandler(P)
-  else
-    If Application.AllowRequest(P) then
-      Result:=Application.ProcessRequest(P)
-    else
-      Result:=DECLINED;
-end;
-
-Procedure RegisterApacheHooks(P: PApr_pool_t);cdecl;
-
-Var
-  H : ap_hook_handler_t;
-  PP1,PP2 : PPChar;
-
-begin
-  H:=AlternateHandler;
-  If (H=Nil) then
-    H:=@DefaultApacheHandler;
-  PP1:=Nil;
-  PP2:=Nil;
-  ap_hook_handler(H,PP1,PP2,HPRIO[Application.HandlerPriority]);
-end;
-
-{ TApacheHandler }
-
-function TApacheHandler.GetModules(Index: integer): TStrings;
-begin
-  If (FModules[Index]=Nil) then
-    FModules[Index]:=TStringList.Create;
-  Result:=FModules[Index];
-end;
-
-procedure TApacheHandler.SetModules(Index: integer;
-  const AValue: TStrings);
-begin
-  If (FModules[Index]=Nil) then
-    FModules[Index]:=TStringList.Create;
-  FModules[Index].Assign(AValue);
-end;
-
-Function TApacheHandler.ProcessRequest(P: PRequest_Rec) : Integer;
-
-Var
-  Req : TApacheRequest;
-  Resp : TApacheResponse;
-
-begin
-  Req:=TApacheRequest.CreateReq(Self,P);
-  Try
-    InitRequest(Req);
-    Req.InitRequestVars;
-    Resp:=TApacheResponse.CreateApache(Req);
-    Try
-      InitResponse(Resp);
-      HandleRequest(Req,Resp);
-      If Not Resp.ContentSent then
-        Resp.SendContent;
-    Finally
-      Result:=OK;
-      Resp.Free;
-    end;
-  Finally
-    Req.Free;
-  end;
-end;
-
-procedure TApacheHandler.Run;
-begin
-  // Do nothing. This is a library
-  Initialize;
-end;
-
-function TApacheHandler.WaitForRequest(out ARequest: TRequest; out AResponse: TResponse): boolean;
-begin
-  Result:=False;
-  ARequest:=Nil;
-  AResponse:=Nil;
-end;
-
-function TApacheHandler.AllowRequest(P: PRequest_Rec): Boolean;
-
-Var
-  Hn : String;
-
-begin
-  HN:=StrPas(p^.Handler);
-  Result:=CompareText(HN,FHandlerName)=0;
-  If Assigned(FBeforeRequest) then
-    FBeforeRequest(Self,HN,Result);
-end;
-
-function TApacheHandler.GetApplicationURL(ARequest: TRequest): String;
-begin
-  Result:=inherited GetApplicationURL(ARequest);
-  If (Result='') then
-    Result:=BaseLocation;
-end;
-
-constructor TApacheHandler.Create(AOwner: TComponent);
-begin
-  inherited Create(AOwner);
-  FPriority:=hpMiddle;
-  FMaxRequests:=64;
-  FWorkingWebModules:=TList.Create;
-  FIdleWebModules:=TList.Create;
-  FCriticalSection:=TCriticalSection.Create;
-end;
-
-destructor TApacheHandler.Destroy;
-var I:Integer;
-begin
-  FCriticalSection.Free;
-  for I := FIdleWebModules.Count - 1 downto 0 do
-    TComponent(FIdleWebModules[I]).Free;
-  FIdleWebModules.Free;
-  for I := FWorkingWebModules.Count - 1 downto 0 do
-    TComponent(FWorkingWebModules[I]).Free;
-  FWorkingWebModules.Free;
-  inherited Destroy;
-end;
-
-
-procedure TApacheHandler.SetModuleRecord(var ModuleRecord: Module);
-begin
-  FModuleRecord:=@ModuleRecord;
-  FillChar(ModuleRecord,SizeOf(ModuleRecord),0);
-end;
-
-procedure TApacheHandler.Initialize;
-
-begin
-  If (FModuleRecord=nil) then
-    Raise EFPApacheError.Create(SErrNoModuleRecord);
-  if (FModuleName='') and (FModuleRecord^.Name=Nil) then
-    Raise EFPApacheError.Create(SErrNoModuleName);
-  STANDARD20_MODULE_STUFF(FModuleRecord^);
-  If (StrPas(FModuleRecord^.name)<>FModuleName) then
-    FModuleRecord^.Name:=PChar(FModuleName);
-  FModuleRecord^.register_hooks:=@RegisterApacheHooks;
-end;
-
-procedure TApacheHandler.LogErrorMessage(Msg: String; LogLevel: integer);
-var a: ap_version_t;
-begin
-  ap_log_error(pchar(FModuleName),  //The file in which this function is called
-               0,                   //The line number on which this function is called
-               0,                   //The module_index of the module generating this message
-               LogLevel,            //The level of this error message
-               0,                   //The status code from the previous command
-               Nil,                 //The server on which we are logging
-               'module: %s',        //The format string
-               [pchar(Msg)])        //The arguments to use to fill out fmt.
-end;
-
-function TApacheHandler.GetIdleModuleCount : Integer;
-begin
-  FCriticalSection.Enter;
-  try
-    Result := FIdleWebModules.Count;
-  finally
-    FCriticalSection.Leave;
-  end;
-end;
-
-function TApacheHandler.GetWorkingModuleCount : Integer;
-begin
-  FCriticalSection.Enter;
-  try
-    Result := FWorkingWebModules.Count;
-  finally
-    FCriticalSection.Leave;
-  end;
-end;
-
-procedure TApacheHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
-
-Var
-  MC : TCustomHTTPModuleClass;
-  M  : TCustomHTTPModule;
-  MN : String;
-  MI : TModuleItem;
-
-  Procedure GetAWebModule;
-  Var II:Integer;
-  begin
-    FCriticalSection.Enter;
-    try
-      if (FMaxRequests>0) and (FWorkingWebModules.Count>=FMaxRequests) then
-        Raise EFPApacheError.Create(SErrTooManyRequests);
-      if (FIdleWebModules.Count>0) then
-      begin
-        II := FIdleWebModules.Count - 1;
-        while (II>=0) and not (TComponent(FIdleWebModules[II]) is MC) do
-          Dec(II);
-        if (II>=0) then
-        begin
-          M:=TCustomHTTPModule(FIdleWebModules[II]);
-          FIdleWebModules.Delete(II);
-        end;
-      end;
-      if (M=nil) then
-      begin
-        M:=MC.Create(Self);
-        M.Name := '';
-      end;
-      FWorkingWebModules.Add(M);
-    finally
-      FCriticalSection.Leave;
-    end;
-  end;
-
-begin
-  try
-    MC:=Nil;
-    M := Nil;
-    If (OnGetModule<>Nil) then
-      OnGetModule(Self,ARequest,MC);
-    If (MC=Nil) then
-    begin
-      MN:=GetModuleName(ARequest);
-      If (MN='') and Not AllowDefaultModule then
-        Raise EFPApacheError.Create(SErrNoModuleNameForRequest);
-      MI:=ModuleFactory.FindModule(MN);
-      If (MI=Nil) and (ModuleFactory.Count=1) then
-        MI:=ModuleFactory[0];
-      if (MI=Nil) then
-        Raise EFPApacheError.CreateFmt(SErrNoModuleForRequest,[MN]);
-
-      MC:=MI.ModuleClass;
-    end;
-    GetAWebModule;
-    M.HandleRequest(ARequest,AResponse);
-
-    FCriticalSection.Enter;
-    try
-      FWorkingWebModules.Remove(M);
-      FIdleWebModules.Add(M);
-    finally
-      FCriticalSection.Leave;
-    end;
-  except
-    On E : Exception do
-      begin
-      LogErrorMessage(E.Message,APLOG_ERR);
-      ShowRequestException(AResponse,E);
-      end;
-  end;
-end;
-
-{ TApacheRequest }
-
-function TApacheRequest.GetFieldValue(Index: Integer): String;
-
-  Function MaybeP(P : Pchar) : String;
-  
-  begin
-    If (P<>Nil) then
-      Result:=StrPas(P);
-  end;
-
-var
-  FN : String;
-  I : Integer;
-  
-begin
-  Result:='';
-  If (Index in [1..NoHTTPFields]) then
-    begin
-    FN:=HTTPFieldNames[Index];
-    Result:=MaybeP(apr_table_get(FRequest^.headers_in,pchar(FN)));
-    end;
-  if (Result='') and Assigned(FRequest) then
-    case Index of
-      0  : Result:=MaybeP(FRequest^.protocol); // ProtocolVersion
-      7  : Result:=MaybeP(FRequest^.content_encoding); //ContentEncoding
-      25 : Result:=MaybeP(FRequest^.path_info); // PathInfo
-      26 : Result:=MaybeP(FRequest^.filename); // PathTranslated
-      27 : // RemoteAddr
-           If (FRequest^.Connection<>Nil) then
-             Result:=MaybeP(FRequest^.Connection^.remote_ip);
-      28 : // RemoteHost
-           If (FRequest^.Connection<>Nil) then
-             begin
-             Result:=MaybeP(ap_get_remote_host(FRequest^.Connection,
-                            FRequest^.per_dir_config,
-//                            nil,
-                            REMOTE_NAME,@i));
-             end;                   
-      29 : begin // ScriptName
-           Result:=MaybeP(FRequest^.unparsed_uri);
-           I:=Pos('?',Result)-1;
-           If (I=-1) then
-             I:=Length(Result);
-           Result:=Copy(Result,1,I-Length(PathInfo));
-           end;
-      30 : Result:=IntToStr(ap_get_server_port(FRequest)); // ServerPort
-      31 : Result:=MaybeP(FRequest^.method); // Method
-      32 : Result:=MaybeP(FRequest^.unparsed_uri); // URL
-      33 : Result:=MaybeP(FRequest^.args); // Query
-      34 : Result:=MaybeP(FRequest^.HostName); // Host
-    else
-      Result:=inherited GetFieldValue(Index);
-    end;
-end;
-
-procedure TApacheRequest.ReadContent;
-
-  Function MinS(A,B : Integer) : Integer;
-  
-  begin
-    If A<B then
-      Result:=A
-    else
-      Result:=B;
-  end;
 
-Var
-  Left,Len,Count,Bytes : Integer;
-  P : Pchar;
-  S : String;
-    
-begin
-  ap_setup_client_block(FRequest,REQUEST_CHUNKED_DECHUNK);
-  If (ap_should_client_block(FRequest)=1) then
-    begin
-    Len:=ContentLength;
-    If (Len>0) then
-      begin
-      SetLength(S,Len);
-      P:=PChar(S);
-      Left:=Len;
-      Count:=0;
-      Repeat
-        Bytes:=ap_get_client_block(FRequest,P,MinS(10*1024,Left));
-        Dec(Left,Bytes);
-        Inc(P,Bytes);
-        Inc(Count,Bytes);
-      Until (Count>=Len) or (Bytes=0);
-      SetLength(S,Count);
-      end;
-    end;
-  InitContent(S);  
-end;
-
-procedure TApacheRequest.InitFromRequest;
-begin
-  ParseCookies;
-end;
-
-Constructor TApacheRequest.CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
-
-begin
-  FApache:=App;
-  FRequest:=Arequest;
-  ReturnedPathInfo:=App.BaseLocation;
-  Inherited Create;
-  InitFromRequest;
-end;
-
-{ TApacheResponse }
-
-procedure TApacheResponse.DoSendHeaders(Headers: TStrings);
-
-Var
-  I,P : Integer;
-  N,V : String;
-
-begin
-  For I:=0 to Headers.Count-1 do
-    begin
-    V:=Headers[i];
-    P:=Pos(':',V);
-    If (P<>0) and (P<Length(V)) then
-      begin
-      N:=Copy(V,1,P-1);
-      System.Delete(V,1,P);
-      V := Trim(V);//no need space before the value, apache puts it there
-      apr_table_set(FRequest^.headers_out,Pchar(N),Pchar(V));
-      end;
-    end;
-end;
-
-procedure TApacheResponse.DoSendContent;
-
-Var
-  S : String;
-  I : Integer;
-
-begin
-  S:=ContentType;
-  If (S<>'') then
-    FRequest^.content_type:=apr_pstrdup(FRequest^.pool,Pchar(S));
-  S:=ContentEncoding;
-  If (S<>'') then
-    FRequest^.content_encoding:=apr_pstrdup(FRequest^.pool,Pchar(S));
-  If Code <> 200 then
-    FRequest^.status := Code;
-  If assigned(ContentStream) then
-    SendStream(Contentstream)
-  else
-    for I:=0 to Contents.Count-1 do
-      begin
-      S:=Contents[i]+LineEnding;
-      // If there is a null, it's written also with ap_rwrite
-      ap_rwrite(PChar(S),Length(S),FRequest);
-      end;
-end;
-
-Procedure TApacheResponse.SendStream(S : TStream);
-
-Var
-  Buf : Array[0..(10*1024)-1] of Byte;
-  Count : Integer;
-
-begin
-  S.Seek(0,soBeginning);
-  Repeat
-    Count:=S.Read(Buf,SizeOf(Buf));
-    If Count>0 then
-      ap_rwrite(@Buf,Count,FRequest);
-  Until (Count=0);
-end;
-
-
-Constructor TApacheResponse.CreateApache(Req : TApacheRequest);
-begin
-  FApache:=Req.ApacheApp;
-  Frequest:=Req.ApacheRequest;
-  Inherited Create(Req);
-end;
-
-function __dummythread(p: pointer): ptrint;
-begin
-  sleep(1000);
-  Result:=0;
-end;
-
-{ TCustomApacheApplication }
-
-function TCustomApacheApplication.GetAfterModules: TStrings;
-begin
-  result := TApacheHandler(WebHandler).AfterModules;
-end;
-
-function TCustomApacheApplication.GetBaseLocation: String;
-begin
-  result := TApacheHandler(WebHandler).BaseLocation;
-end;
-
-function TCustomApacheApplication.GetBeforeModules: TStrings;
-begin
-  result := TApacheHandler(WebHandler).BeforeModules;
-end;
-
-function TCustomApacheApplication.GetBeforeRequest: TBeforeRequestEvent;
-begin
-  result := TApacheHandler(WebHandler).BeforeRequest;
-end;
-
-function TCustomApacheApplication.GetHandlerName: String;
-begin
-  result := TApacheHandler(WebHandler).HandlerName;
-end;
-
-function TCustomApacheApplication.GetIdleModuleCount: Integer;
-begin
-  result := TApacheHandler(WebHandler).IdleWebModuleCount;
-end;
-
-function TCustomApacheApplication.GetMaxRequests: Integer;
-begin
-  result := TApacheHandler(WebHandler).MaxRequests;
-end;
-
-function TCustomApacheApplication.GetModuleName: String;
-begin
-  result := TApacheHandler(WebHandler).ModuleName;
-end;
-
-function TCustomApacheApplication.GetPriority: THandlerPriority;
-begin
-  result := TApacheHandler(WebHandler).HandlerPriority;
-end;
-
-function TCustomApacheApplication.GetWorkingModuleCount: Integer;
-begin
-  result := TApacheHandler(WebHandler).WorkingWebModuleCount;
-end;
-
-procedure TCustomApacheApplication.SetAfterModules(const AValue: TStrings);
-begin
-  TApacheHandler(WebHandler).AfterModules := AValue;
-end;
-
-procedure TCustomApacheApplication.SetBaseLocation(const AValue: String);
-begin
-  TApacheHandler(WebHandler).BaseLocation := AValue;
-end;
-
-procedure TCustomApacheApplication.SetBeforeModules(const AValue: TStrings);
-begin
-  TApacheHandler(WebHandler).BeforeModules := AValue;
-end;
-
-procedure TCustomApacheApplication.SetBeforeRequest(const AValue: TBeforeRequestEvent);
-begin
-  TApacheHandler(WebHandler).BeforeRequest := AValue;
-end;
-
-procedure TCustomApacheApplication.SetHandlerName(const AValue: String);
-begin
-  TApacheHandler(WebHandler).HandlerName := AValue;
-end;
-
-procedure TCustomApacheApplication.SetMaxRequests(const AValue: Integer);
-begin
-  TApacheHandler(WebHandler).MaxRequests := AValue;
-end;
-
-procedure TCustomApacheApplication.SetModuleName(const AValue: String);
-begin
-  TApacheHandler(WebHandler).ModuleName := AValue;
-end;
-
-procedure TCustomApacheApplication.SetPriority(const AValue: THandlerPriority);
-begin
-  TApacheHandler(WebHandler).HandlerPriority := AValue;
-end;
-
-function TCustomApacheApplication.InitializeWebHandler: TWebHandler;
-begin
-  Result:=TApacheHandler.Create(self);
-end;
-
-procedure TCustomApacheApplication.Initialize;
-begin
-  Inherited;
-  TApacheHandler(WebHandler).Initialize;
-end;
-
-procedure TCustomApacheApplication.ShowException(E: Exception);
-begin
-  ap_log_error(PChar(TApacheHandler(WebHandler).ModuleName),  //The file in which this function is called
-               0,                                             //The line number on which this function is called
-               0,                                             //The module_index of the module generating this message
-               APLOG_ERR,                                     //The level of this error message
-               0,                                             //The status code from the previous command
-               Nil,                                           //The server on which we are logging
-               'module: %s',                                  //The format string
-               [Pchar(E.Message)]);                           //The arguments to use to fill out fmt.
-end;
-
-function TCustomApacheApplication.ProcessRequest(P: PRequest_Rec): Integer;
-begin
-  result := TApacheHandler(WebHandler).ProcessRequest(p);
-end;
-
-function TCustomApacheApplication.AllowRequest(P: PRequest_Rec): Boolean;
-begin
-  result := TApacheHandler(WebHandler).AllowRequest(p);
-end;
-
-procedure TCustomApacheApplication.SetModuleRecord(var ModuleRecord: Module);
-begin
-  TApacheHandler(WebHandler).SetModuleRecord(ModuleRecord);
-end;
 
 Initialization
-  BeginThread(@__dummythread);//crash prevention for simultaneous requests
   InitApache;
   
 Finalization

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

@@ -54,6 +54,7 @@ Type
     FOnPassword: TPasswordEvent;
     FOnRedirect: TRedirectEvent;
     FPassword: String;
+    FIOTimeout: Integer;
     FSentCookies,
     FCookies: TStrings;
     FHTTPVersion: String;
@@ -73,6 +74,7 @@ Type
     Procedure ResetResponse;
     Procedure SetCookies(const AValue: TStrings);
     Procedure SetRequestHeaders(const AValue: TStrings);
+    procedure SetIOTimeout(AValue: Integer);
   protected
     // Called whenever data is read.
     Procedure DoDataRead; virtual;
@@ -211,6 +213,8 @@ Type
     // Simple form of Posting a file
     Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
   Protected
+    // Timeouts
+    Property IOTimeout : Integer read FIOTimeout write SetIOTimeout;
     // Before request properties.
     // Additional headers for request. Host; and Authentication are automatically added.
     Property RequestHeaders : TStrings Read FRequestHeaders Write SetRequestHeaders;
@@ -256,6 +260,7 @@ Type
 
   TFPHTTPClient = Class(TFPCustomHTTPClient)
   Public
+    Property IOTimeout;
     Property RequestHeaders;
     Property RequestBody;
     Property ResponseHeaders;
@@ -384,6 +389,14 @@ begin
   FRequestHeaders.Assign(AValue);
 end;
 
+procedure TFPCustomHTTPClient.SetIOTimeout(AValue: Integer);
+begin
+  if AValue=FIOTimeout then exit;
+  FIOTimeout:=AValue;
+  if Assigned(FSocket) then
+    FSocket.IOTimeout:=AValue;
+end;
+
 procedure TFPCustomHTTPClient.DoDataRead;
 begin
   If Assigned(FOnDataReceived) Then
@@ -457,6 +470,8 @@ begin
   G:=GetSocketHandler(UseSSL);    
   FSocket:=TInetSocket.Create(AHost,APort,G);
   try
+    if FIOTimeout<>0 then
+      FSocket.IOTimeout:=FIOTimeout;
     FSocket.Connect;
   except
     FreeAndNil(FSocket);
@@ -956,6 +971,8 @@ end;
 constructor TFPCustomHTTPClient.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
+  // Infinite timeout on most platforms
+  FIOTimeout:=0;
   FRequestHeaders:=TStringList.Create;
   FResponseHeaders:=TStringList.Create;
   FHTTPVersion:='1.1';

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

@@ -420,7 +420,7 @@ begin
     Exit;
     end;
   N:=Copy(V,1,P-1);
-  Delete(V,1,P+1);
+  Delete(V,1,P);
   V:=Trim(V);
   ARequest.SetFieldByName(N,V);
 end;
@@ -448,11 +448,13 @@ begin
   Request.Method:=GetNextWord(AStartLine);
   Request.URL:=GetNextWord(AStartLine);
   S:=Request.URL;
-  If (S<>'') and (S[1]='/') then
-    Delete(S,1,1);
   I:=Pos('?',S);
   if (I>0) then
     S:=Copy(S,1,I-1);
+  If (Length(S)>1) and (S[1]<>'/') then
+    S:='/'+S
+  else if S='/' then 
+    S:='';
   Request.PathInfo:=S;
   S:=GetNextWord(AStartLine);
   If (Pos('HTTP/',S)<>1) then

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

@@ -437,6 +437,7 @@ type
     Procedure InitContent(Var AContent : String);
     Property ContentRead : Boolean Read FContentRead Write FContentRead;
   public
+    Class Var DefaultRequestUploadDir : String;
     constructor Create; override;
     destructor destroy; override;
     Function GetNextPathInfo : String;
@@ -1662,7 +1663,7 @@ end;
 function TRequest.RequestUploadDir: String;
 
 begin
-  Result:='';
+  Result:=DefaultRequestUploadDir;
 end;
 
 function TRequest.GetTempUploadFileName(const AName, AFileName: String;

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

@@ -56,6 +56,7 @@ Type
     fadditionalProperties : TJSONObject;
     FBits : TBits;
     Function GetDynArrayProp(P: PPropInfo) : Pointer; virtual;
+    procedure SetArrayElements(AP: Pointer; ET: PTypeInfo; AValue: TJSONArray);
     procedure SetDynArrayProp(P: PPropInfo; AValue : Pointer); virtual;
     procedure SetObjectOptions(AValue: TObjectOptions);
     Function GetAdditionalProperties : TJSONObject;
@@ -536,10 +537,41 @@ begin
   Result:=Pointer(GetObjectProp(Self,P));
 end;
 
+{ $DEFINE DUMPARRAY}
+
+{$IFDEF DUMPARRAY}
+Procedure DumpArray(ClassName,N : String; P : Pointer);
+
+Type
+   pdynarray = ^tdynarray;   
+   tdynarray = packed record
+      refcount : ptrint;
+      high : tdynarrayindex;
+   end;
+   
+ Var
+   R : pdynarray;  
+   
+begin
+  if P=Nil then
+    Writeln(ClassName,' property ',N, ' is nil')
+  else
+    begin
+    r:=pdynarray(p-sizeof(tdynarray));
+    Writeln(ClassName,' property ',N, ' has ref count ',r^.refcount,' and high ',r^.high);
+    end;  
+end;
+{$ENDIF}
 
 procedure TBaseObject.SetDynArrayProp(P: PPropInfo; AValue: Pointer);
 begin
+{$IFDEF DUMPARRAY}
+  DumpArray(ClassName+' (set)',P^.PropType^.Name,AValue);
+{$ENDIF}
   SetObjectProp(Self,P,TObject(AValue));
+{$IFDEF DUMPARRAY}
+  DumpArray(ClassName+' (check)',P^.PropType^.Name,AValue);
+{$ENDIF}
 end;
 
 procedure TBaseObject.SetObjectOptions(AValue: TObjectOptions);
@@ -643,6 +675,53 @@ begin
     SetFloatProp(Self,P,0)
 end;
 
+procedure TBaseObject.SetArrayElements(AP : Pointer; ET: PTypeInfo; AValue: TJSONArray);
+
+Var
+  I : Integer;
+  AN : String;
+
+begin
+  AN:=ET^.Name;
+  // Fill in all elements
+  For I:=0 to AValue.Count-1 do
+    begin
+    Case ET^.Kind of
+      tkClass :
+        begin
+        // Writeln(ClassName,' Adding instance of type: ',AN);
+        TObjectArray(AP)[I]:=CreateObject(AN);
+        TObjectArray(AP)[I].LoadFromJSON(AValue.Objects[i]);
+        end;
+      tkFloat :
+        if IsDateTimeProp(ET) then
+          TDateTimeArray(AP)[I]:=RFC3339ToDateTime(AValue.Strings[i])
+        else
+          TFloatArray(AP)[I]:=AValue.Floats[i];
+      tkInt64 :
+        TInt64Array(AP)[I]:=AValue.Int64s[i];
+      tkBool :
+        begin
+        TBooleanArray(AP)[I]:=AValue.Booleans[i];
+        end;
+      tkInteger :
+       TIntegerArray(AP)[I]:=AValue.Integers[i];
+      tkUstring,
+      tkWstring :
+        TUnicodeStringArray(AP)[I]:=UTF8Decode(AValue.Strings[i]);
+      tkString,
+      tkAstring,
+      tkLString :
+        begin
+        // Writeln('Setting String ',i,': ',AValue.Strings[i]);
+        TStringArray(AP)[I]:=AValue.Strings[i];
+        end;
+    else
+      Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
+    end;
+    end;
+end;
+
 procedure TBaseObject.SetArrayProperty(P: PPropInfo; AValue: TJSONArray);
 
 Var
@@ -685,10 +764,10 @@ begin
     PA:=@(pdynarraytypeinfo(P^.PropType)^.elesize)+i;
     PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i;
     ET:=PTYpeInfo(PA^);
-    if ET^.Kind=tkClass then
+    if (ET^.Kind=tkClass) then
       begin
       // get object type name
-      AN:=PTYpeInfo(PA^)^.Name;
+      AN:=ET^.Name;
       // Free all objects
       O:=TObjectArray(AP);
       For I:=0 to Length(O)-1 do
@@ -715,43 +794,12 @@ begin
     I:=Length(TObjectArray(AP));
     SetDynArrayProp(P,AP);
 {$endif}
-    // Fill in all elements
-    For I:=0 to AValue.Count-1 do
-      begin
-      Case ET^.Kind of
-        tkClass :
-          begin
-          // Writeln(ClassName,' Adding instance of type: ',AN);
-          TObjectArray(AP)[I]:=CreateObject(AN);
-          TObjectArray(AP)[I].LoadFromJSON(AValue.Objects[i]);
-          end;
-        tkFloat :
-          if IsDateTimeProp(ET) then
-            TDateTimeArray(AP)[I]:=RFC3339ToDateTime(AValue.Strings[i])
-          else
-            TFloatArray(AP)[I]:=AValue.Floats[i];
-        tkInt64 :
-          TInt64Array(AP)[I]:=AValue.Int64s[i];
-        tkBool :
-          begin
-          TBooleanArray(AP)[I]:=AValue.Booleans[i];
-          end;
-        tkInteger :
-         TIntegerArray(AP)[I]:=AValue.Integers[i];
-        tkUstring,
-        tkWstring :
-          TUnicodeStringArray(AP)[I]:=UTF8Decode(AValue.Strings[i]);
-        tkString,
-        tkAstring,
-        tkLString :
-          begin
-          // Writeln('Setting String ',i,': ',AValue.Strings[i]);
-          TStringArray(AP)[I]:=AValue.Strings[i];
-          end;
-      else
-        Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
-      end;
-      end;
+    try
+      SetArrayElements(AP,ET,AValue);
+    finally
+      // Reduce ref. count, compiler does not do it for us for a pointer.
+      TObjectArray(AP):=Nil;
+    end;
     end;
 end;
 
@@ -1011,6 +1059,7 @@ end;
 
 procedure TBaseObject.ClearChildren(ChildTypes: TChildTypes);
 
+
 Type
   TObjectArr = Array of TObject;
 
@@ -1045,6 +1094,9 @@ begin
             if PTYpeInfo(PA^)^.Kind=tkClass then
               begin
               A:=GetDynArrayProp(P);
+{$IFDEF DUMPARRAY}              
+              DumpArray(ClassName+' (clear)',P^.PropType^.Name,A);
+{$ENDIF}
 //              Writeln(ClassName,' Examining array: ',P^.Name,'Count:',Length(TObjectArr(A)));
               For J:=0 to Length(TObjectArr(A))-1 do
                 begin