# revisions: 41456,41461,41465,41466,41467,41468,41473,41478,41479,41480,41482,41483,41494,41495,41496,41500,41501,41502,41503,41504,41505,41527,41528,41529,41530,41542,41557,41558,41561,41572,41573,41581,41582,41583,41585,41586,41587,41590,41593,41594,41598,41600,41603,41611,41617,41618,41619,41621,41622,41623,41624,41630,41631,41632,41633,41634,41657,41658,41661,41663,41664,41665,41666,41676,41680,41681,41684,41690,41691,41694

git-svn-id: branches/fixes_3_2@41997 -

.gitattributes

@@ -3242,6 +3242,8 @@ packages/fcl-web/examples/jsonrpc/extdirect/extdirect.in svneol=native#text/plai
 packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp svneol=native#text/plain
 packages/fcl-web/examples/restbridge/README.txt svneol=native#text/plain
+packages/fcl-web/examples/restbridge/cmdclient/cmdclient.lpi svneol=native#text/plain
+packages/fcl-web/examples/restbridge/cmdclient/cmdclient.pas svneol=native#text/plain
 packages/fcl-web/examples/restbridge/delphiclient/frmmain.dfm svneol=native#text/plain
 packages/fcl-web/examples/restbridge/delphiclient/frmmain.pas svneol=native#text/plain
 packages/fcl-web/examples/restbridge/delphiclient/sqldbrestclient.dpr svneol=native#text/plain
@@ -3250,7 +3252,9 @@ packages/fcl-web/examples/restbridge/delphiclient/sqldbrestclient.res -text
 packages/fcl-web/examples/restbridge/demorestbridge.lpi svneol=native#text/plain
 packages/fcl-web/examples/restbridge/demorestbridge.pp svneol=native#text/plain
 packages/fcl-web/examples/restbridge/expenses-data.sql svneol=native#text/plain
+packages/fcl-web/examples/restbridge/expenses-fb.sql svneol=native#text/plain
 packages/fcl-web/examples/restbridge/expenses-pq.sql svneol=native#text/plain
+packages/fcl-web/examples/restbridge/expenses-sqlite.sql svneol=native#text/plain
 packages/fcl-web/examples/routing-session/routingsessiondemo.lpi svneol=native#text/plain
 packages/fcl-web/examples/routing-session/routingsessiondemo.lpr svneol=native#text/plain
 packages/fcl-web/examples/routing/README svneol=native#text/plain
@@ -3384,6 +3388,7 @@ packages/fcl-web/src/jsonrpc/fpextdirect.pp svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/fpjsonrpc.pp svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/readme.txt svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/webjsonrpc.pp svneol=native#text/plain
+packages/fcl-web/src/restbridge/sqldbrestado.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestauth.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestauthini.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestbridge.pp svneol=native#text/plain
@@ -3394,6 +3399,7 @@ packages/fcl-web/src/restbridge/sqldbrestdata.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestini.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestio.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestjson.pp svneol=native#text/plain
+packages/fcl-web/src/restbridge/sqldbrestmodule.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestschema.pp svneol=native#text/plain
 packages/fcl-web/src/restbridge/sqldbrestxml.pp svneol=native#text/plain
 packages/fcl-web/src/webdata/Makefile svneol=native#text/plain

packages/fcl-js/tests/testjs.lpr

@@ -12,10 +12,6 @@ uses
 var
   Application: TTestRunner;
 
-{$IFDEF WINDOWS}{$R testjs.rc}{$ENDIF}
-
-{$R *.res}
-
 begin
   DefaultFormat:=fplain;
   DefaultRunAllTests:=True;

packages/fcl-json/src/fpjson.pp

@@ -2496,7 +2496,7 @@ begin
       vtChar       : Result:=CreateJSON(VChar);
       vtExtended   : Result:=CreateJSON(VExtended^);
       vtString     : Result:=CreateJSON(vString^);
-      vtAnsiString : Result:=CreateJSON(AnsiString(vAnsiString));
+      vtAnsiString : Result:=CreateJSON(UTF8Decode(StrPas(VPChar)));
       vtPChar      : Result:=CreateJSON(StrPas(VPChar));
       vtPointer    : If (VPointer<>Nil) then
                        TJSONData.DoError(SErrPointerNotNil,[SourceType])
@@ -3153,7 +3153,7 @@ constructor TJSONObject.Create(const Elements: array of {$ifdef pas2js}jsvalue{$
 
 Var
   I : integer;
-  AName : String;
+  AName : TJSONUnicodeStringType;
   J : TJSONData;
 
 begin
@@ -3171,10 +3171,10 @@ begin
     {$else}
     With Elements[i] do
       Case VType of
-        vtChar       : AName:=VChar;
-        vtString     : AName:=vString^;
-        vtAnsiString : AName:=(AnsiString(vAnsiString));
-        vtPChar      : AName:=StrPas(VPChar);
+        vtChar       : AName:=TJSONUnicodeStringType(VChar);
+        vtString     : AName:=TJSONUnicodeStringType(vString^);
+        vtAnsiString : AName:=UTF8Decode(StrPas(VPChar));
+        vtPChar      : AName:=TJSONUnicodeStringType(StrPas(VPChar));
       else
         DoError(SErrNameMustBeString,[I+1]);
       end;
@@ -3183,7 +3183,11 @@ begin
       DoError(SErrNameMustBeString,[I+1]);
     Inc(I);
     J:=VarRecToJSON(Elements[i],'Object');
+    {$IFDEF FPC_HAS_CPSTRING}
+    Add(UTF8Encode(AName),J);
+    {$ELSE}
     Add(AName,J);
+    {$ENDIF}
     Inc(I);
     end;
 end;

packages/fcl-json/src/jsonconf.pp

@@ -90,13 +90,21 @@ type
     Procedure EnumValues(Const APath : UnicodeString; List : TStrings);
 
     function  GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString; overload;
+    function  GetValue(const APath: RawByteString; const ADefault: RawByteString): UnicodeString; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Integer): Integer; overload;
+    function  GetValue(const APath: RawByteString; ADefault: Integer): Integer; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Int64): Int64; overload;
+    function  GetValue(const APath: RawByteString; ADefault: Int64): Int64; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; overload;
+    function  GetValue(const APath: RawByteString; ADefault: Boolean): Boolean; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Double): Double; overload;
+    function  GetValue(const APath: RawByteString; ADefault: Double): Double; overload;
     Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: String) : Boolean; overload;
+    Function GetValue(const APath: RawByteString; 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: RawByteString; const AValue: RawByteString); 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;
@@ -289,6 +297,12 @@ begin
 end;
 
 
+function TJSONConfig.GetValue(const APath: RawByteString; const ADefault: RawByteString): UnicodeString;
+
+begin
+  Result:=GetValue(UTF8Decode(aPath),UTF8Decode(ADefault));
+end;
+
 function TJSONConfig.GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString;
 
 var
@@ -302,6 +316,12 @@ begin
     Result:=ADefault;
 end;
 
+function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Integer): Integer;
+
+begin
+  Result:=GetValue(UTF8Decode(aPath),ADefault);
+end;
+
 function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Integer): Integer;
 var
   El : TJSONData;
@@ -316,6 +336,12 @@ begin
     Result:=StrToIntDef(El.AsString,ADefault);
 end;
 
+function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Int64): Int64;
+
+begin
+  Result:=GetValue(UTF8Decode(aPath),ADefault);
+end;
+
 function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Int64): Int64;
 var
   El : TJSONData;
@@ -330,6 +356,12 @@ begin
     Result:=StrToInt64Def(El.AsString,ADefault);
 end;
 
+function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Boolean): Boolean;
+
+begin
+  Result:=GetValue(UTF8Decode(aPath),ADefault);
+end;
+
 function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean;
 
 var
@@ -345,6 +377,12 @@ begin
     Result:=StrToBoolDef(El.AsString,ADefault);
 end;
 
+function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Double): Double;
+
+begin
+  Result:=GetValue(UTF8Decode(aPath),ADefault);
+end;
+
 function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Double): Double;
 
 var
@@ -360,6 +398,14 @@ begin
     Result:=StrToFloatDef(El.AsString,ADefault);
 end;
 
+function TJSONConfig.GetValue(const APath: RawByteString; AValue: TStrings;
+  const ADefault: String): Boolean;
+
+begin
+  Result:=GetValue(UTF8Decode(aPath),AValue, ADefault);
+end;
+
+
 function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings;
   const ADefault: String): Boolean;
 var
@@ -418,6 +464,13 @@ begin
   FModified:=True;
 end;
 
+
+procedure TJSONConfig.SetValue(const APath: RawByteString;
+  const AValue: RawByteString);
+begin
+  SetValue(UTF8Decode(APath),UTF8Decode(AValue));
+end;
+
 procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString);
 begin
   if AValue = DefValue then

packages/fcl-json/src/jsonreader.pp

@@ -36,7 +36,7 @@ Type
     procedure DoError(const Msg: String);
     Procedure DoParse(AtCurrent,AllowEOF: Boolean);
     function GetNextToken: TJSONToken;
-    function CurrentTokenString: String;
+    function CurrentTokenString: RawByteString;
     function CurrentToken: TJSONToken; inline;
 
     Procedure KeyValue(Const AKey : TJSONStringType); virtual; abstract;
@@ -203,7 +203,7 @@ begin
   Result:=FScanner.CurToken;
 end;
 
-function TBaseJSONReader.CurrentTokenString: String;
+function TBaseJSONReader.CurrentTokenString: RawByteString;
 
 begin
   If CurrentToken in [tkString,tkIdentifier,tkNumber,tkComment] then

packages/fcl-json/src/jsonscanner.pp

@@ -28,7 +28,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';
+  SErrOpenString = 'string exceeds end of line %d';
 
 type
 
@@ -331,7 +331,7 @@ begin
                       u1:=u2;
                       end
                     end;
-              #0  : Error(SErrOpenString);
+              #0  : Error(SErrOpenString,[FCurRow]);
             else
               Error(SErrInvalidCharacter, [CurRow,CurColumn,FTokenStr[0]]);
             end;
@@ -355,11 +355,11 @@ begin
           else
             MaybeAppendUnicode;
           if FTokenStr[0] = #0 then
-            Error(SErrOpenString);
+            Error(SErrOpenString,[FCurRow]);
           Inc(FTokenStr);
           end;
         if FTokenStr[0] = #0 then
-          Error(SErrOpenString);
+          Error(SErrOpenString,[FCurRow]);
         MaybeAppendUnicode;
         SectionLength := FTokenStr - TokenStart;
         SetLength(FCurTokenString, OldLength + SectionLength);

packages/fcl-json/tests/jsonconftest.pp

@@ -27,6 +27,7 @@ type
     procedure TestKey;
     procedure TestStrings;
     procedure TestUnicodeStrings;
+    procedure TestUnicodeStrings2;
   end;
 
 implementation
@@ -352,6 +353,34 @@ begin
   end;
 end;
 
+procedure TTestJSONConfig.TestUnicodeStrings2;
+
+Const
+  utf8str = 'Größe ÄÜÖ ㎰ す 가';
+  utf8path = 'Größe/す가';
+
+Var
+  Co : TJSONCOnfig;
+
+
+begin
+  Co:=CreateConf('test.json');
+  try
+    Co.SetValue('/проверка',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('/проверка','')));
+    AssertEquals('UTF8 path read/Write','something',Co.GetValue(utf8path,'something'));
+  finally
+    DeleteConf(Co,True);
+  end;
+end;
+
 
 initialization
 

packages/fcl-json/tests/testjsonconf.lpi

@@ -14,9 +14,6 @@
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
-      <IgnoreBinaries Value="False"/>
-      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
-      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
     </PublishOptions>
     <RunParams>
       <local>

packages/fcl-passrc/src/pasresolveeval.pas

@@ -181,12 +181,13 @@ const
   nDerivedXMustExtendASubClassY = 3115;
   nDefaultPropertyNotAllowedInHelperForX = 3116;
   nHelpersCannotBeUsedAsTypes = 3117;
-  nBitWiseOperationsAre32Bit = 3118;
+  nMessageHandlersInvalidParams = 3118;
   nImplictConversionUnicodeToAnsi = 3119;
   nWrongTypeXInArrayConstructor = 3120;
   nUnknownCustomAttributeX = 3121;
   nAttributeIgnoredBecauseAbstractX = 3122;
   nCreatingAnInstanceOfAbstractClassY = 3123;
+  nIllegalExpressionAfterX = 3124;
 
   // using same IDs as FPC
   nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@@ -315,12 +316,13 @@ resourcestring
   sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself';
   sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s';
   sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types';
-  sBitWiseOperationsAre32Bit = 'Bitwise operations are 32-bit';
+  sMessageHandlersInvalidParams = 'Message handlers can take only one call by ref. parameter';
   sImplictConversionUnicodeToAnsi = 'Implicit string type conversion with potential data loss from "UnicodeString" to "AnsiString"';
   sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor';
   sUnknownCustomAttributeX = 'Unknown custom attribute "%s"';
   sAttributeIgnoredBecauseAbstractX = 'attribute ignored because abstract %s';
   sCreatingAnInstanceOfAbstractClassY = 'Creating an instance of abstract class "%s"';
+  sIllegalExpressionAfterX = 'illegal expression after %s';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }

packages/fcl-passrc/src/pasresolver.pp

@@ -1234,7 +1234,7 @@ type
     SubType: TResolverBaseType; // for btSet, btArrayLit, btArrayOrSet, btRange
     IdentEl: TPasElement; // if set then this specific identifier is the value, can be a type
     LoTypeEl: TPasType; // can be nil for const expression, all alias resolved
-    HiTypeEl: TPasType; // same as BaseTypeEl, except alias types are not resolved
+    HiTypeEl: TPasType; // same as LoTypeEl, except alias types are not resolved
     ExprEl: TPasExpr;
     Flags: TPasResolverResultFlags;
   end;
@@ -1438,7 +1438,7 @@ type
     procedure OnFindFirst(El: TPasElement; ElScope, StartScope: TPasScope;
       FindFirstElementData: Pointer; var Abort: boolean); virtual;
     procedure OnFindCallElements(El: TPasElement; ElScope, StartScope: TPasScope;
-      FindProcsData: Pointer; var Abort: boolean); virtual; // find candidates for Name(params)
+      FindCallElData: Pointer; var Abort: boolean); virtual; // find candidates for Name(params)
     procedure OnFindProc(El: TPasElement; ElScope, StartScope: TPasScope;
       FindProcData: Pointer; var Abort: boolean); virtual;
     function IsSameProcContext(ProcParentA, ProcParentB: TPasElement): boolean;
@@ -4373,9 +4373,9 @@ begin
 end;
 
 procedure TPasResolver.OnFindCallElements(El: TPasElement; ElScope,
-  StartScope: TPasScope; FindProcsData: Pointer; var Abort: boolean);
+  StartScope: TPasScope; FindCallElData: Pointer; var Abort: boolean);
 var
-  Data: PFindCallElData absolute FindProcsData;
+  Data: PFindCallElData absolute FindCallElData;
   Proc, PrevProc: TPasProcedure;
   Distance: integer;
   BuiltInProc: TResElDataBuiltInProc;
@@ -4680,7 +4680,7 @@ var
   end;
 
 begin
-  //writeln('TPasResolver.OnFindProcSameSignature START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc);
+  //writeln('TPasResolver.OnFindProc START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc);
   if not (El is TPasProcedure) then
     begin
     // identifier is not a proc
@@ -4711,8 +4711,13 @@ begin
           begin
           // give a hint
           if Data^.Proc.Parent is TPasMembersType then
-            LogMsg(20171118205344,mtHint,nFunctionHidesIdentifier_NonProc,sFunctionHidesIdentifier,
-              [GetElementSourcePosStr(El)],Data^.Proc.ProcType);
+            begin
+            if El.Visibility=visStrictPrivate then
+            else if (El.Visibility=visPrivate) and (El.GetModule<>Data^.Proc.GetModule) then
+            else
+              LogMsg(20171118205344,mtHint,nFunctionHidesIdentifier_NonProc,sFunctionHidesIdentifier,
+                [GetElementSourcePosStr(El)],Data^.Proc.ProcType);
+            end;
           end;
       fpkMethod:
         // method hides a non proc
@@ -4732,7 +4737,7 @@ begin
     end;
 
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.OnFindProcSameSignature ',GetTreeDbg(El,2));
+  writeln('TPasResolver.OnFindProc ',GetTreeDbg(El,2));
   {$ENDIF}
   Store:=CheckOverloadProcCompatibility(Data^.Proc,Proc);
   if Data^.Kind=fpkSameSignature then
@@ -4803,7 +4808,11 @@ begin
             if (Data^.Proc.Parent is TPasMembersType) then
               begin
               ProcScope:=Proc.CustomData as TPasProcedureScope;
-              if (ProcScope.ImplProc<>nil)  // not abstract, external
+              if (Proc.Visibility=visStrictPrivate)
+                  or ((Proc.Visibility=visPrivate)
+                    and (Proc.GetModule<>Data^.Proc.GetModule)) then
+                // a private private is hidden by definition -> no hint
+              else if (ProcScope.ImplProc<>nil)  // not abstract, external
                   and (not ProcHasImplElements(ProcScope.ImplProc)) then
                 // hidden method has implementation, but no statements -> useless
                 // -> do not give a hint for hiding this useless method
@@ -4812,9 +4821,12 @@ begin
                   and (Data^.Proc.ClassType=Proc.ClassType) then
                 // do not give a hint for hiding a constructor
               else
+                begin
+                //writeln('TPasResolver.OnFindProc Proc=',Proc.PathName,' Data^.Proc=',Data^.Proc.PathName,' ',Proc.Visibility);
                 LogMsg(20171118214523,mtHint,
                   nFunctionHidesIdentifier_NonVirtualMethod,sFunctionHidesIdentifier,
                   [GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
+                end;
               end;
             end;
           Abort:=true;
@@ -5846,6 +5858,9 @@ var
   ptm: TProcTypeModifier;
   ObjKind: TPasObjKind;
   ParentBody: TProcedureBody;
+  HelperForType: TPasType;
+  Args: TFPList;
+  Arg: TPasArgument;
 begin
   if El.Parent is TPasProcedure then
     Proc:=TPasProcedure(El.Parent)
@@ -5940,19 +5955,28 @@ begin
         {if msDelphi in CurrentParser.CurrentModeswitches then
           begin
           // Delphi allows virtual/override in class helpers
-          // But this works differently to normal virtual/override and
-          // requires helpers to be TInterfacedObject
+          // But using them crashes in Delphi 10.3
+          // -> do not support them
           end
         }
         if Proc.IsVirtual then
           RaiseMsg(20190116215823,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
         if Proc.IsOverride then
           RaiseMsg(20190116215825,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
-        if (ObjKind<>okClassHelper) and IsClassMethod(Proc) and not IsClassConDestructor then
+        HelperForType:=ResolveAliasType(TPasClassType(Proc.Parent).HelperForType);
+        if (not Proc.IsStatic) and IsClassMethod(Proc) and not IsClassConDestructor then
           begin
-          if not Proc.IsStatic then
+          // non static class methods require a class
+          if (not (HelperForType.ClassType=TPasClassType))
+              or (TPasClassType(HelperForType).ObjKind<>okClass) then
             RaiseMsg(20190201153831,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,[ObjKindNames[ObjKind]],Proc);
           end;
+        if Proc.ClassType=TPasDestructor then
+          RaiseMsg(20190302151019,nXIsNotSupported,sXIsNotSupported,['destructor'],Proc);
+        if (Proc.ClassType=TPasConstructor)
+            and (HelperForType.ClassType=TPasClassType)
+            and (TPasClassType(HelperForType).ObjKind<>okClass) then
+          RaiseMsg(20190302151514,nXIsNotSupported,sXIsNotSupported,['constructor'],Proc);
         end;
       end;
       if Proc.IsAbstract then
@@ -6036,10 +6060,28 @@ begin
     if El is TPasFunctionType then
       EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType);
 
+    if Proc.PublicName<>nil then
+      ResolveExpr(Proc.PublicName,rraRead);
     if Proc.LibraryExpr<>nil then
       ResolveExpr(Proc.LibraryExpr,rraRead);
     if Proc.LibrarySymbolName<>nil then
       ResolveExpr(Proc.LibrarySymbolName,rraRead);
+    if Proc.DispIDExpr<>nil then
+      ResolveExpr(Proc.DispIDExpr,rraRead);
+    if Proc.MessageExpr<>nil then
+      begin
+      // message modifier
+      ResolveExpr(Proc.MessageExpr,rraRead);
+      Args:=Proc.ProcType.Args;
+      if Args.Count<>1 then
+        RaiseMsg(20190303223701,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El);
+      Arg:=TPasArgument(Args[0]);
+      if not (Arg.Access in [argVar,argOut]) then
+        RaiseMsg(20190303223834,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El);
+      if (Proc.ClassType<>TPasProcedure)
+          and (Proc.ClassType<>TPasFunction) then
+        RaiseMsg(20190303224128,nXExpectedButYFound,sXExpectedButYFound,['procedure name(var Msg);message id;',GetElementTypeName(El)],El);
+      end;
 
     if Proc.Parent is TPasMembersType then
       begin
@@ -6345,7 +6387,8 @@ begin
         SelfType:=TPasClassType(SelfType).HelperForType;
         end;
       LoSelfType:=ResolveAliasType(SelfType);
-      if LoSelfType is TPasClassType then
+      if (LoSelfType is TPasClassType)
+          and (TPasClassType(LoSelfType).ObjKind=okClass) then
         SelfArg.Access:=argConst
       else
         SelfArg.Access:=argVar;
@@ -7234,7 +7277,7 @@ begin
       else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
           and (HelperForType.CustomData is TResElDataBaseType)) then
       else if (HelperForType.ClassType=TPasClassType)
-          and (TPasClassType(HelperForType).ObjKind=okClass) then
+          and (TPasClassType(HelperForType).ObjKind in [okClass,okInterface]) then
         begin
         if TPasClassType(HelperForType).IsForward then
           RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined,
@@ -9205,7 +9248,8 @@ begin
       end
     else if LTypeEl.ClassType=TPasEnumType then
       begin
-      if LeftResolved.IdentEl is TPasEnumType then
+      if (LeftResolved.IdentEl is TPasType)
+          and (ResolveAliasType(TPasType(LeftResolved.IdentEl)).ClassType=TPasEnumType) then
         begin
         // e.g. TShiftState.ssAlt
         DotScope:=PushEnumDotScope(TPasEnumType(LTypeEl));
@@ -16283,23 +16327,25 @@ begin
         if (TypeEl.ClassType=TPasClassType)
             and (TPasClassType(TypeEl).HelperForType<>nil) then
           TypeEl:=ResolveAliasType(TPasClassType(TypeEl).HelperForType) as TPasType;
-        if (TypeEl.ClassType=TPasClassType) and
-            TPasClassType(TypeEl).IsAbstract then
-          LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
-            sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl);
         TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
         if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
           begin
-          AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
-          if (length(AbstractProcs)>0) then
+          if (TypeEl.ClassType=TPasClassType) and TPasClassType(TypeEl).IsAbstract then
+            LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
+              sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl)
+          else
             begin
-            if IsClassOf then
-              // aClass.Create: do not warn
-            else
-              for i:=0 to length(AbstractProcs)-1 do
-                LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
-                  sConstructingClassXWithAbstractMethodY,
-                  [TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
+            AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
+            if (length(AbstractProcs)>0) then
+              begin
+              if IsClassOf then
+                // aClass.Create: do not warn
+              else
+                for i:=0 to length(AbstractProcs)-1 do
+                  LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
+                    sConstructingClassXWithAbstractMethodY,
+                    [TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
+              end;
             end;
           end;
         end;
@@ -17094,7 +17140,7 @@ begin
             Scope.Add(HelperScope);
             HelperScope:=HelperScope.AncestorScope;
             end;
-          if not (msMultipleScopeHelpers in CurrentParser.CurrentModeswitches) then
+          if not (msMultiHelpers in CurrentParser.CurrentModeswitches) then
             break;
           end;
         end;
@@ -20164,18 +20210,25 @@ begin
         end;
       exit;
       end;
+    if (Param.ArgType=nil) then
+      exit(cExact); // untyped argument
     if (ParamResolved.BaseType=ExprResolved.BaseType) then
       begin
       if msDelphi in CurrentParser.CurrentModeswitches then
         begin
+        // Delphi allows passing alias, but not type alias to a var arg
         if IsSameType(ParamResolved.HiTypeEl,ExprResolved.HiTypeEl,prraSimple) then
           exit(cExact);
         end
       else if IsSameType(ParamResolved.LoTypeEl,ExprResolved.LoTypeEl,prraNone) then
-        exit(cExact);
+        begin
+        // ObjFPC allows passing type alias to a var arg, but simple alias wins
+        if IsSameType(ParamResolved.HiTypeEl,ExprResolved.HiTypeEl,prraSimple) then
+          exit(cExact)
+        else
+          exit(cAliasExact);
+        end;
       end;
-    if (Param.ArgType=nil) then
-      exit(cExact); // untyped argument
     if RaiseOnError then
       RaiseIncompatibleTypeRes(20170216152452,nIncompatibleTypeArgNoVarParamMustMatchExactly,
         [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,
@@ -22103,6 +22156,8 @@ begin
     exit(TPasArgument(IdentEl).ArgType<>nil)
   else if IdentEl.ClassType=TPasResultElement then
     exit(TPasResultElement(IdentEl).ResultType<>nil)
+  else if IdentEl is TPasType then
+    Result:=true
   else
     Result:=false;
 end;

packages/fcl-passrc/src/pastree.pp

@@ -1054,6 +1054,7 @@ type
     LibrarySymbolName,
     LibraryExpr : TPasExpr; // e.g. external LibraryExpr name LibrarySymbolName;
     DispIDExpr :  TPasExpr;
+    MessageExpr: TPasExpr;
     AliasName : String;
     ProcType : TPasProcedureType;
     Body : TProcedureBody;
@@ -3398,6 +3399,7 @@ begin
   ReleaseAndNil(TPasElement(LibraryExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibraryExpr'{$ENDIF});
   ReleaseAndNil(TPasElement(LibrarySymbolName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibrarySymbolName'{$ENDIF});
   ReleaseAndNil(TPasElement(DispIDExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.DispIDExpr'{$ENDIF});
+  ReleaseAndNil(TPasElement(MessageExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.MessageExpr'{$ENDIF});
   ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF});
   ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF});
   inherited Destroy;
@@ -4472,6 +4474,7 @@ begin
   ForEachChildCall(aMethodCall,Arg,PublicName,false);
   ForEachChildCall(aMethodCall,Arg,LibraryExpr,false);
   ForEachChildCall(aMethodCall,Arg,LibrarySymbolName,false);
+  ForEachChildCall(aMethodCall,Arg,MessageExpr,false);
   ForEachChildCall(aMethodCall,Arg,Body,false);
 end;
 

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1037,9 +1037,10 @@ begin
   repeat
     El:=El.Parent;
     if not (El is TPasType) then break;
-    MarkElementAsUsed(El);
-    if El is TPasMembersType then
-      UseClassConstructor(TPasMembersType(El));
+    UseType(TPasType(El),paumElement);
+    //MarkElementAsUsed(El);
+    //if El is TPasMembersType then
+    //  UseClassConstructor(TPasMembersType(El));
   until false;
 end;
 
@@ -1475,6 +1476,7 @@ var
   ModScope: TPasModuleScope;
   Access: TResolvedRefAccess;
   SubEl: TPasElement;
+  ParamsExpr: TParamsExpr;
 begin
   if El=nil then exit;
   // Note: expression itself is not marked, but it can reference identifiers
@@ -1527,7 +1529,8 @@ begin
         case BuiltInProc.BuiltIn of
         bfExit:
           begin
-          if El.Parent is TParamsExpr then
+          ParamsExpr:=Resolver.GetParamsOfNameExpr(El);
+          if ParamsExpr<>nil then
             begin
             Params:=(El.Parent as TParamsExpr).Params;
             if length(Params)=1 then
@@ -1546,7 +1549,10 @@ begin
           end;
         bfTypeInfo:
           begin
-          Params:=(El.Parent as TParamsExpr).Params;
+          ParamsExpr:=Resolver.GetParamsOfNameExpr(El);
+          if ParamsExpr=nil then
+            RaiseNotSupported(20190225150136,El);
+          Params:=ParamsExpr.Params;
           if length(Params)<>1 then
             RaiseNotSupported(20180226144217,El.Parent);
           Resolver.ComputeElement(Params[0],ParamResolved,[rcNoImplicitProc]);
@@ -1773,6 +1779,9 @@ begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.UseProcedure ',GetElModName(Proc));
   {$ENDIF}
+  if Proc.Parent is TPasMembersType then
+    UseClassOrRecType(TPasMembersType(Proc.Parent),paumElement);
+
   UseScopeReferences(ProcScope.References);
 
   UseProcedureType(Proc.ProcType);
@@ -1997,6 +2006,9 @@ begin
     else
       begin
       if ElementVisited(El,Mode) then exit;
+      // this class has been used (e.g. paumElement), which marked ancestors
+      // and published members
+      // -> now mark all members paumAllPasUsable
       FirstTime:=false;
       end;
     end;
@@ -2006,7 +2018,7 @@ begin
     RaiseInconsistency(20170414152143,IntToStr(ord(Mode)));
   end;
   {$IFDEF VerbosePasAnalyzer}
-  writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime);
+  writeln('TPasAnalyzer.UseClassOrRecType ',GetElModName(El),' ',Mode,' First=',FirstTime);
   {$ENDIF}
   aClass:=nil;
   ClassScope:=nil;
@@ -2023,8 +2035,6 @@ begin
       end;
 
     ClassScope:=aClass.CustomData as TPasClassScope;
-    if ClassScope=nil then
-      exit; // ClassScope can be nil if msIgnoreInterfaces
 
     if FirstTime then
       begin
@@ -2107,6 +2117,11 @@ begin
         end;
         //writeln('TPasAnalyzer.UseClassType ',El.FullName,' ',Mode,' ',Member.Name);
         end;
+      if Proc.MessageExpr<>nil then
+        begin
+        UseProcedure(Proc);
+        continue;
+        end;
       end
     else if Member.ClassType=TPasAttributes then
       continue; // attributes are never used directly

packages/fcl-passrc/src/pparser.pp

@@ -3909,7 +3909,7 @@ begin
             NextToken;
             if not (CurToken in [tkChar,tkString,tkIdentifier]) then
               ParseExcTokenError(TokenInfos[tkString]);
-            Result.ExportName:=DoParseExpression(Parent);
+            Result.ExportName:=DoParseExpression(Result);
             Result.IsConst:=true; // external const is readonly
             end
           else if CurToken=tkSemicolon then
@@ -4326,7 +4326,7 @@ begin
     UngetToken;
     exit;
     end;
-  Include(varMods,ExtMod);
+  Include(VarMods,ExtMod);
   Result:=Result+';'+CurTokenText;
 
   NextToken;
@@ -4444,14 +4444,14 @@ begin
       NextToken;
       If Curtoken<>tkSemicolon then
         UnGetToken;
-      VarEl:=TPasVariable(VarList[0]);
+      VarEl:=TPasVariable(VarList[OldListCount]);
       AllowedVarMods:=[];
       if ExternalStruct then
         AllowedVarMods:=[vmExternal]
       else
         AllowedVarMods:=[vmCVar,vmExternal,vmPublic,vmExport];
       Mods:=GetVariableModifiers(VarEl,VarMods,aLibName,aExpName,AllowedVarMods);
-      if (mods='') and (CurToken<>tkSemicolon) then
+      if (Mods='') and (CurToken<>tkSemicolon) then
         NextToken;
       end
     else
@@ -4866,21 +4866,24 @@ begin
     end;
   pmMessage:
     begin
-    Repeat
-      NextToken;
-      If CurToken<>tkSemicolon then
-        begin
-        if Parent is TPasProcedure then
-          TPasProcedure(Parent).MessageName:=CurtokenString;
-        If (CurToken=tkString) and (Parent is TPasProcedure) then
-          TPasProcedure(Parent).Messagetype:=pmtString;
-        end;
-    until CurToken = tkSemicolon;
-    UngetToken;
+    NextToken;
+    E:=DoParseExpression(Parent);
+    TPasProcedure(Parent).MessageExpr:=E;
+    if E is TPrimitiveExpr then
+      begin
+      TPasProcedure(Parent).MessageName:=TPrimitiveExpr(E).Value;
+      case E.Kind of
+      pekNumber, pekUnary: TPasProcedure(Parent).Messagetype:=pmtInteger;
+      pekString: TPasProcedure(Parent).Messagetype:=pmtString;
+      end;
+      end;
+    if CurToken = tkSemicolon then
+      UngetToken;
     end;
   pmDispID:
     begin
-    TPasProcedure(Parent).DispIDExpr:=DoParseExpression(Parent,Nil);
+    NextToken;
+    TPasProcedure(Parent).DispIDExpr:=DoParseExpression(Parent);
     if CurToken = tkSemicolon then
       UngetToken;
     end;

packages/fcl-passrc/src/pscanner.pp

@@ -78,6 +78,8 @@ const
   nIllegalStateForWarnDirective = 1027;
   nErrIncludeLimitReached = 1028;
   nMisplacedGlobalCompilerSwitch = 1029;
+  nLogMacroXSetToY = 1030;
+  nInvalidDispatchFieldName = 1031;
 
 // resourcestring patterns of messages
 resourcestring
@@ -112,6 +114,8 @@ resourcestring
   SIllegalStateForWarnDirective = 'Illegal state "%s" for $WARN directive';
   SErrIncludeLimitReached = 'Include file limit reached';
   SMisplacedGlobalCompilerSwitch = 'Misplaced global compiler switch, ignored';
+  SLogMacroXSetToY = 'Macro %s set to %s';
+  SInvalidDispatchFieldName = 'Invalid Dispatch field name';
 
 type
   TMessageType = (
@@ -294,7 +298,7 @@ type
     msExternalClass,       { Allow external class definitions }
     msPrefixedAttributes,  { Allow attributes, disable proc modifier [] }
     msOmitRTTI,            { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch }
-    msMultipleScopeHelpers { off=only one helper per type, on=all }
+    msMultiHelpers         { off=only one helper per type, on=all }
     );
   TModeSwitches = Set of TModeSwitch;
 
@@ -376,13 +380,19 @@ const
 
 type
   TValueSwitch = (
-    vsInterfaces
+    vsInterfaces,
+    vsDispatchField,
+    vsDispatchStrField
     );
   TValueSwitches = set of TValueSwitch;
   TValueSwitchArray = array[TValueSwitch] of string;
 const
   vsAllValueSwitches = [low(TValueSwitch)..high(TValueSwitch)];
-  DefaultVSInterfaces = 'com';
+  DefaultValueSwitches: array[TValueSwitch] of string = (
+     'com', // vsInterfaces
+     'Msg', // vsDispatchField
+     'MsgStr' // vsDispatchStrField
+     );
   DefaultMaxIncludeStackDepth = 20;
 
 type
@@ -763,6 +773,8 @@ type
     function HandleDirective(const ADirectiveText: String): TToken; virtual;
     function HandleLetterDirective(Letter: char; Enable: boolean): TToken; virtual;
     procedure HandleBoolDirective(bs: TBoolSwitch; const Param: String); virtual;
+    procedure DoHandleDirective(Sender: TObject; Directive, Param: String;
+      var Handled: boolean); virtual;
     procedure HandleIFDEF(const AParam: String);
     procedure HandleIFNDEF(const AParam: String);
     procedure HandleIFOPT(const AParam: String);
@@ -771,6 +783,7 @@ type
     procedure HandleELSE(const AParam: String);
     procedure HandleENDIF(const AParam: String);
     procedure HandleDefine(Param: String); virtual;
+    procedure HandleDispatchField(Param: String; vs: TValueSwitch); virtual;
     procedure HandleError(Param: String); virtual;
     procedure HandleMessageDirective(Param: String); virtual;
     procedure HandleIncludeFile(Param: String); virtual;
@@ -1038,7 +1051,7 @@ const
     'EXTERNALCLASS',
     'PREFIXEDATTRIBUTES',
     'OMITRTTI',
-    'MULTIPLESCOPEHELPERS'
+    'MULTIHELPERS'
     );
 
   LetterSwitchNames: array['A'..'Z'] of string=(
@@ -1106,7 +1119,9 @@ const
     );
 
   ValueSwitchNames: array[TValueSwitch] of string = (
-    'Interfaces'
+    'Interfaces', // vsInterfaces
+    'DispatchField', // vsDispatchField
+    'DispatchStrField' // vsDispatchStrField
     );
 
 const
@@ -2655,6 +2670,8 @@ constructor TPascalScanner.Create(AFileResolver: TBaseFileResolver);
     Result.Duplicates:=dupError;
   end;
 
+var
+  vs: TValueSwitch;
 begin
   inherited Create;
   FFileResolver := AFileResolver;
@@ -2669,7 +2686,8 @@ begin
   FCurrentBoolSwitches:=bsFPCMode;
   FAllowedBoolSwitches:=bsAll;
   FAllowedValueSwitches:=vsAllValueSwitches;
-  FCurrentValueSwitches[vsInterfaces]:=DefaultVSInterfaces;
+  for vs in TValueSwitch do
+    FCurrentValueSwitches[vs]:=DefaultValueSwitches[vs];
 
   FConditionEval:=TCondDirectiveEvaluator.Create;
   FConditionEval.OnLog:=@OnCondEvalLog;
@@ -2731,9 +2749,9 @@ begin
   FCurSourceFile := FileResolver.FindSourceFile(AFilename);
   FCurFilename := AFilename;
   AddFile(FCurFilename);
-{$IFDEF HASFS}
+  {$IFDEF HASFS}
   FileResolver.BaseDirectory := IncludeTrailingPathDelimiter(ExtractFilePath(FCurFilename));
-{$ENDIF}
+  {$ENDIF}
   if LogEvent(sleFile) then
     DoLog(mtInfo,nLogOpeningFile,SLogOpeningFile,[FormatPath(AFileName)],True);
 end;
@@ -3271,10 +3289,8 @@ begin
       DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[Identifier]);
       exit;
       end;
-    end;
-
-  if Number>=0 then
     SetWarnMsgState(Number,State);
+    end;
 end;
 
 procedure TPascalScanner.HandleDefine(Param: String);
@@ -3297,6 +3313,26 @@ begin
     end;
 end;
 
+procedure TPascalScanner.HandleDispatchField(Param: String; vs: TValueSwitch);
+var
+  NewValue: String;
+begin
+  if not (vs in AllowedValueSwitches) then
+    Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,[ValueSwitchNames[vs]]);
+  NewValue:=ReadIdentifier(Param);
+  if NewValue='-' then
+    NewValue:=''
+  else if not IsValidIdent(NewValue,false) then
+    DoLog(mtWarning,nInvalidDispatchFieldName,SInvalidDispatchFieldName,[]);
+  if SameText(NewValue,CurrentValueSwitch[vs]) then exit;
+  if vs in ReadOnlyValueSwitches then
+    begin
+    Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,[ValueSwitchNames[vs]]);
+    exit;
+    end;
+  CurrentValueSwitch[vs]:=NewValue;
+end;
+
 procedure TPascalScanner.HandleError(Param: String);
 begin
   if po_StopOnErrorDirective in Options then
@@ -3682,6 +3718,10 @@ begin
           HandleDefine(Param);
         'GOTO':
           DoBoolDirective(bsGoto);
+        'DIRECTIVEFIELD':
+          HandleDispatchField(Param,vsDispatchField);
+        'DIRECTIVESTRFIELD':
+          HandleDispatchField(Param,vsDispatchStrField);
         'ERROR':
           HandleError(Param);
         'HINT':
@@ -3735,8 +3775,7 @@ begin
       end;
       end;
 
-    if Assigned(OnDirective) then
-      OnDirective(Self,Directive,Param,Handled);
+    DoHandleDirective(Self,Directive,Param,Handled);
     if (not Handled) then
       if LogEvent(sleDirective) then
         DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,
@@ -3801,6 +3840,13 @@ begin
     CurrentBoolSwitches:=CurrentBoolSwitches-[bs];
 end;
 
+procedure TPascalScanner.DoHandleDirective(Sender: TObject; Directive,
+  Param: String; var Handled: boolean);
+begin
+  if Assigned(OnDirective) then
+    OnDirective(Self,Directive,Param,Handled);
+end;
+
 function TPascalScanner.DoFetchToken: TToken;
 var
   TokenStart: {$ifdef UsePChar}PChar{$else}integer{$endif};
@@ -4855,7 +4901,7 @@ begin
     end;
   Result:=true;
   if (not Quiet) and LogEvent(sleConditionals) then
-    DoLog(mtInfo,nLogMacroDefined,sLogMacroDefined,[aName])
+    DoLog(mtInfo,nLogMacroXSetToY,SLogMacroXSetToY,[aName,aValue])
 end;
 
 function TPascalScanner.RemoveMacro(const aName: String; Quiet: boolean

packages/fcl-passrc/tests/tcresolver.pas

@@ -557,6 +557,7 @@ type
     Procedure TestClass_MethodOverloadUnit;
     Procedure TestClass_HintMethodHidesNonVirtualMethod;
     Procedure TestClass_HintMethodHidesNonVirtualMethodWithoutBody_NoHint;
+    Procedure TestClass_NoHintMethodHidesPrivateMethod;
     Procedure TestClass_MethodReintroduce;
     Procedure TestClass_MethodOverloadArrayOfTClass;
     Procedure TestClass_ConstructorHidesAncestorWarning;
@@ -609,6 +610,7 @@ type
     Procedure TestClass_UntypedParam_TypeCast;
     Procedure TestClass_Sealed;
     Procedure TestClass_SealedDescendFail;
+    Procedure TestClass_Abstract;
     Procedure TestClass_AbstractCreateFail;
     Procedure TestClass_VarExternal;
     Procedure TestClass_WarnOverrideLowerVisibility;
@@ -619,6 +621,8 @@ type
     Procedure TestClass_EnumeratorFunc;
     Procedure TestClass_ForInPropertyStaticArray;
     Procedure TestClass_TypeAlias;
+    Procedure TestClass_Message;
+    Procedure TestClass_Message_MissingParamFail;
 
     // published
     Procedure TestClass_PublishedClassVarFail;
@@ -913,7 +917,7 @@ type
     Procedure TestClassHelper_ReintroduceHides_CallFail;
     Procedure TestClassHelper_DefaultProperty;
     Procedure TestClassHelper_DefaultClassProperty;
-    Procedure TestClassHelper_MultipleScopeHelpers;
+    Procedure TestClassHelper_MultiHelpers;
     Procedure TestRecordHelper;
     Procedure TestRecordHelper_ForByteFail;
     Procedure TestRecordHelper_ClassNonStaticFail;
@@ -929,8 +933,11 @@ type
     Procedure TestTypeHelper_Enumerator;
     Procedure TestTypeHelper_String;
     Procedure TestTypeHelper_Boolean;
+    Procedure TestTypeHelper_Double;
+    Procedure TestTypeHelper_DoubleAlias;
     Procedure TestTypeHelper_Constructor_NewInstance;
-    Procedure TestTypeHelper_InterfaceFail;
+    Procedure TestTypeHelper_Interface;
+    Procedure TestTypeHelper_Interface_ConstructorFail;
 
     // attributes
     Procedure TestAttributes_Globals;
@@ -3681,25 +3688,30 @@ end;
 procedure TTestResolver.TestEnums;
 begin
   StartProgram(false);
-  Add('type {#TFlag}TFlag = ({#Red}Red, {#Green}Green, {#Blue}Blue);');
-  Add('var');
-  Add('  {#f}{=TFlag}f: TFlag;');
-  Add('  {#v}{=TFlag}v: TFlag = Green;');
-  Add('  {#i}i: longint;');
-  Add('begin');
-  Add('  {@f}f:={@Red}Red;');
-  Add('  {@f}f:={@v}v;');
-  Add('  if {@f}f={@Red}Red then ;');
-  Add('  if {@f}f={@v}v then ;');
-  Add('  if {@f}f>{@v}v then ;');
-  Add('  if {@f}f<{@v}v then ;');
-  Add('  if {@f}f>={@v}v then ;');
-  Add('  if {@f}f<={@v}v then ;');
-  Add('  if {@f}f<>{@v}v then ;');
-  Add('  if ord({@f}f)<>ord({@Red}Red) then ;');
-  Add('  {@f}f:={@TFlag}TFlag.{@Red}Red;');
-  Add('  {@f}f:={@TFlag}TFlag({@i}i);');
-  Add('  {@i}i:=longint({@f}f);');
+  Add([
+  'type',
+  '  {#TFlag}TFlag = ({#Red}Red, {#Green}Green, {#Blue}Blue);',
+  '  {#TAlias}TAlias = TFlag;',
+  'var',
+  '  {#f}{=TFlag}f: TFlag;',
+  '  {#v}{=TFlag}v: TFlag = Green;',
+  '  {#i}i: longint;',
+  'begin',
+  '  {@f}f:={@Red}Red;',
+  '  {@f}f:={@v}v;',
+  '  if {@f}f={@Red}Red then ;',
+  '  if {@f}f={@v}v then ;',
+  '  if {@f}f>{@v}v then ;',
+  '  if {@f}f<{@v}v then ;',
+  '  if {@f}f>={@v}v then ;',
+  '  if {@f}f<={@v}v then ;',
+  '  if {@f}f<>{@v}v then ;',
+  '  if ord({@f}f)<>ord({@Red}Red) then ;',
+  '  {@f}f:={@TFlag}TFlag.{@Red}Red;',
+  '  {@f}f:={@TFlag}TFlag({@i}i);',
+  '  {@i}i:=longint({@f}f);',
+  '  {@f}f:={@TAlias}TAlias.{@Green}Green;',
+  '']);
   ParseProgram;
 end;
 
@@ -6411,14 +6423,26 @@ begin
   '  TAliasValue = TValue;',
   '  TColor = type TAliasValue;',
   '  TAliasColor = TColor;',
-  'procedure DoIt(i: TAliasValue); external;',
-  'procedure DoIt(i: TAliasColor); external;',
+  'procedure {#a}DoIt(i: TAliasValue); external;',
+  'procedure {#b}DoIt(i: TAliasColor); external;',
+  'procedure {#c}Fly(var i: TAliasValue); external;',
+  'procedure {#d}Fly(var i: TAliasColor); external;',
   'var',
   '  v: TAliasValue;',
   '  c: TAliasColor;',
   'begin',
-  '  DoIt(v);',
-  '  DoIt(c);',
+  '  {@a}DoIt(v);',
+  '  {@a}DoIt(TAliasValue(c));',
+  '  {@a}DoIt(TValue(c));',
+  '  {@b}DoIt(c);',
+  '  {@b}DoIt(TAliasColor(v));',
+  '  {@b}DoIt(TColor(v));',
+  '  {@c}Fly(v);',
+  '  {@c}Fly(TAliasValue(c));',
+  '  {@c}Fly(TValue(c));',
+  '  {@d}Fly(c);',
+  '  {@d}Fly(TAliasColor(v));',
+  '  {@d}Fly(TColor(v));',
   '']);
   ParseProgram;
 end;
@@ -9485,6 +9509,47 @@ begin
   CheckResolverUnexpectedHints(true);
 end;
 
+procedure TTestResolver.TestClass_NoHintMethodHidesPrivateMethod;
+begin
+  AddModuleWithIntfImplSrc('unit2.pas',
+    LinesToStr([
+    'type',
+    '  TObject = class',
+    '  private',
+    '    procedure DoIt(p: pointer);',
+    '  end;',
+    '']),
+    LinesToStr([
+    'procedure TObject.DoIt(p: pointer);',
+    'begin',
+    '  if p=nil then ;',
+    'end;',
+    '']) );
+  StartProgram(true);
+  Add([
+  'uses unit2;',
+  'type',
+  '  TAnimal = class',
+  '  strict private',
+  '    procedure Fly(p: pointer);',
+  '  end;',
+  '  TBird = class(TAnimal)',
+  '    procedure DoIt(i: longint);',
+  '    procedure Fly(b: boolean);',
+  '  end;',
+  'procedure TAnimal.Fly(p: pointer);',
+  'begin',
+  '  if p=nil then ;',
+  'end;',
+  'procedure TBird.DoIt(i: longint); begin end;',
+  'procedure TBird.Fly(b: boolean); begin end;',
+  'var b: TBird;',
+  'begin',
+  '  b.DoIt(3);']);
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+end;
+
 procedure TTestResolver.TestClass_MethodReintroduce;
 begin
   StartProgram(false);
@@ -9703,40 +9768,42 @@ end;
 procedure TTestResolver.TestClassCallInherited;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TObject = class');
-  Add('    procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;');
-  Add('    procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;');
-  Add('  end;');
-  Add('  {#A}TClassA = class');
-  Add('    procedure {#A_ProcA}ProcA({#i1}vI: longint); override;');
-  Add('    procedure {#A_ProcB}ProcB(vJ: longint); override;');
-  Add('    procedure {#A_ProcC}ProcC; virtual;');
-  Add('  end;');
-  Add('procedure TObject.ProcA(vi: longint);');
-  Add('begin');
-  Add('  inherited; // ignore, do not raise error');
-  Add('end;');
-  Add('procedure TObject.ProcB(vj: longint);');
-  Add('begin');
-  Add('end;');
-  Add('procedure TClassA.ProcA(vi: longint);');
-  Add('begin');
-  Add('  {@A_ProcA}ProcA({@i1}vI);');
-  Add('  {@TOBJ_ProcA}inherited;');
-  Add('  inherited {@TOBJ_ProcA}ProcA({@i1}vI);');
-  Add('  {@A_ProcB}ProcB({@i1}vI);');
-  Add('  inherited {@TOBJ_ProcB}ProcB({@i1}vI);');
-  Add('end;');
-  Add('procedure TClassA.ProcB(vJ: longint);');
-  Add('begin');
-  Add('end;');
-  Add('procedure TClassA.ProcC;');
-  Add('begin');
-  Add('  inherited; // ignore, do not raise error');
-  Add('end;');
-  Add('begin');
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;',
+  '    procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;',
+  '  end;',
+  '  {#A}TClassA = class',
+  '    procedure {#A_ProcA}ProcA({#i1}vI: longint); override;',
+  '    procedure {#A_ProcB}ProcB(vJ: longint); override;',
+  '    procedure {#A_ProcC}ProcC; virtual;',
+  '  end;',
+  'procedure TObject.ProcA(vi: longint);',
+  'begin',
+  '  inherited; // ignore, do not raise error',
+  'end;',
+  'procedure TObject.ProcB(vj: longint);',
+  'begin',
+  'end;',
+  'procedure TClassA.ProcA(vi: longint);',
+  'begin',
+  '  {@A_ProcA}ProcA({@i1}vI);',
+  '  {@TOBJ_ProcA}inherited;',
+  '  inherited {@TOBJ_ProcA}ProcA({@i1}vI);',
+  '  {@A_ProcB}ProcB({@i1}vI);',
+  '  inherited {@TOBJ_ProcB}ProcB({@i1}vI);',
+  'end;',
+  'procedure TClassA.ProcB(vJ: longint);',
+  'begin',
+  'end;',
+  'procedure TClassA.ProcC;',
+  'begin',
+  '  inherited; // ignore, do not raise error',
+  'end;',
+  'begin']);
   ParseProgram;
+  CheckResolverUnexpectedHints;
 end;
 
 procedure TTestResolver.TestClassCallInheritedNoParamsAbstractFail;
@@ -10836,6 +10903,32 @@ begin
     nCannotCreateADescendantOfTheSealedXY);
 end;
 
+procedure TTestResolver.TestClass_Abstract;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    constructor Create;',
+  '  end;',
+  '  TNop = class abstract(TObject)',
+  '  end;',
+  '  TBird = class(TNop)',
+  '    constructor Create(w: word);',
+  '  end;',
+  'constructor TObject.Create;',
+  'begin',
+  'end;',
+  'constructor TBird.Create(w: word);',
+  'begin',
+  '  inherited Create;',
+  'end;',
+  'begin',
+  '  TBird.Create;']);
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+end;
+
 procedure TTestResolver.TestClass_AbstractCreateFail;
 begin
   StartProgram(false);
@@ -11082,6 +11175,42 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClass_Message;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  FlyId = 2;',
+  '  RunStr = ''Fast'';',
+  'type',
+  '  TObject = class',
+  '    procedure Fly(var msg); message 3+FlyId;',
+  '    procedure Run(var msg); virtual; abstract; message ''prefix''+RunStr;',
+  '  end;',
+  'procedure TObject.Fly(var msg);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClass_Message_MissingParamFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure Fly; message 3;',
+  '  end;',
+  'procedure TObject.Fly;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sMessageHandlersInvalidParams,nMessageHandlersInvalidParams);
+end;
+
 procedure TTestResolver.TestClass_PublishedClassVarFail;
 begin
   StartProgram(false);
@@ -16963,11 +17092,11 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolver.TestClassHelper_MultipleScopeHelpers;
+procedure TTestResolver.TestClassHelper_MultiHelpers;
 begin
   StartProgram(false);
   Add([
-  '{$modeswitch multiplescopehelpers}',
+  '{$modeswitch multihelpers}',
   'type',
   '  TObject = class',
   '  end;',
@@ -17454,6 +17583,56 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestTypeHelper_Double;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  Float = double;',
+  '  THelper = type helper for float',
+  '    const NPI = 3.141592;',
+  '    function ToStr: String;',
+  '  end;',
+  'function THelper.ToStr: String;',
+  'begin',
+  'end;',
+  'var',
+  '  a,b: Float;',
+  '  s: string;',
+  'begin',
+  '  s:=(a * b.NPI).ToStr;',
+  '  s:=(a * float.NPI).ToStr;',
+  '  s:=float.NPI.ToStr;',
+  '  s:=3.2.ToStr;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_DoubleAlias;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  Float = type double;',
+  '  THelper = type helper for float',
+  '    const NPI = 3.141592;',
+  '    function ToStr: String;',
+  '  end;',
+  'function THelper.ToStr: String;',
+  'begin',
+  'end;',
+  'var',
+  '  a,b: Float;',
+  '  s: string;',
+  'begin',
+  '  s:=(a * b.NPI).ToStr;',
+  '  s:=(a * float.NPI).ToStr;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestTypeHelper_Constructor_NewInstance;
 var
   aMarker: PSrcMarker;
@@ -17534,18 +17713,69 @@ begin
     end;
 end;
 
-procedure TTestResolver.TestTypeHelper_InterfaceFail;
+procedure TTestResolver.TestTypeHelper_Interface;
 begin
   StartProgram(false);
   Add([
   '{$modeswitch typehelpers}',
   'type',
-  '  IUnknown = interface end;',
+  '  IUnknown = interface',
+  '    function GetSizes(Index: word): word;',
+  '    procedure SetSizes(Index: word; value: word);',
+  '  end;',
+  '  TObject = class(IUnknown)',
+  '    function GetSizes(Index: word): word; virtual; abstract;',
+  '    procedure SetSizes(Index: word; value: word); virtual; abstract;',
+  '  end;',
+  '  THelper = type helper for IUnknown',
+  '    procedure Fly;',
+  '    class procedure Run; static;',
+  '    property Sizes[Index: word]: word read GetSizes write SetSizes; default;',
+  '  end;',
+  'var',
+  '  i: IUnknown;',
+  '  o: TObject;',
+  'procedure THelper.Fly;',
+  'begin',
+  '  i:=Self;',
+  '  o:=Self as TObject;',
+  '  Self:=nil;',
+  '  Self:=i;',
+  '  Self:=o;',
+  'end;',
+  'class procedure THelper.Run;',
+  'begin',
+  'end;',
+  'begin',
+  '  i.Fly;',
+  '  i.Fly();',
+  '  i.Run;',
+  '  i.Run();',
+  '  i.Sizes[3]:=i.Sizes[4];',
+  '  i[5]:=i[6];',
+  '  IUnknown.Run;',
+  '  IUnknown.Run();',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_Interface_ConstructorFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  IUnknown = interface',
+  '  end;',
   '  THelper = type helper for IUnknown',
+  '    constructor Fly;',
   '  end;',
+  'constructor THelper.Fly;',
+  'begin',
+  'end;',
   'begin',
   '']);
-  CheckResolverException('Type "IUnknown" cannot be extended by a type helper',nTypeXCannotBeExtendedByATypeHelper);
+  CheckResolverException('constructor is not supported',nXIsNotSupported);
 end;
 
 procedure TTestResolver.TestAttributes_Globals;

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -168,6 +168,7 @@ type
     procedure TestWP_ClassHelper_ClassConstrucor_Used;
     procedure TestWP_Attributes;
     procedure TestWP_Attributes_ForwardClass;
+    procedure TestWP_Attributes_Params;
 
     // scope references
     procedure TestSR_Proc_UnitVar;
@@ -2265,20 +2266,20 @@ end;
 
 procedure TTestUseAnalyzer.TestWP_UnitInitialization;
 begin
-  AddModuleWithIntfImplSrc('unit1.pp',
+  AddModuleWithIntfImplSrc('unit2.pp',
     LinesToStr([
-    'uses unit2;',
+    'var i: longint;',
     '']),
     LinesToStr([
-    'initialization',
-    'i:=2;']));
+    '']));
 
-  AddModuleWithIntfImplSrc('unit2.pp',
+  AddModuleWithIntfImplSrc('unit1.pp',
     LinesToStr([
-    'var i: longint;',
+    'uses unit2;',
     '']),
     LinesToStr([
-    '']));
+    'initialization',
+    'i:=2;']));
 
   StartProgram(true);
   Add('uses unit1;');
@@ -3204,6 +3205,37 @@ begin
   AnalyzeWholeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestWP_Attributes_Params;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch prefixedattributes}',
+  'type',
+  '  TObject = class',
+  '    constructor {#TObject_Create_notused}Create;',
+  '    destructor {#TObject_Destroy_used}Destroy; virtual;',
+  '  end;',
+  '  {#TCustomAttribute_used}TCustomAttribute = class',
+  '  end;',
+  '  {#BigAttribute_used}BigAttribute = class(TCustomAttribute)',
+  '    constructor {#Big_A_used}Create(Id: word = 3); overload;',
+  '    destructor {#Big_B_used}Destroy; override;',
+  '  end;',
+  'constructor TObject.Create; begin end;',
+  'destructor TObject.Destroy; begin end;',
+  'constructor BigAttribute.Create(Id: word); begin end;',
+  'destructor BigAttribute.Destroy; begin end;',
+  'var',
+  '  [Big(3)]',
+  '  o: TObject;',
+  '  a: TCustomAttribute;',
+  'begin',
+  '  if typeinfo(o)=nil then ;',
+  '  a.Destroy;',
+  '']);
+  AnalyzeWholeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestSR_Proc_UnitVar;
 begin
   StartUnit(false);

packages/fcl-web/examples/restbridge/cmdclient/cmdclient.lpi

@@ -0,0 +1,57 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="SQLDB Rest Bridge client application"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="0"/>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="cmdclient.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="cmdclient"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-web/examples/restbridge/cmdclient/cmdclient.pas

@@ -0,0 +1,166 @@
+program cmdclient;
+
+{$mode objfpc}{$H+}
+
+uses
+  cwstring,Classes, SysUtils, CustApp, fphttpclient, db, bufdataset, XMLDatapacketReader;
+
+type
+
+  { TSQLDBRestClientApplication }
+
+  TSQLDBRestClientApplication = class(TCustomApplication)
+  Private
+    FURL: String;
+    FUserName: string;
+    FPassword: string;
+    FShowRaw : Boolean;
+  protected
+    procedure RunQuery(aDataset: TBufDataset);
+    Procedure ShowData(aDataset: TDataset);
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure WriteHelp; virtual;
+  end;
+
+{ TSQLDBRestClientApplication }
+
+procedure TSQLDBRestClientApplication.RunQuery(aDataset : TBufDataset);
+
+Var
+  C : TFPHTTPClient;
+  S : TStringStream;
+  U : String;
+
+begin
+  U:=FURL;
+  S:=Nil;
+  C:=TFPHTTPClient.Create(Self);
+  try
+    C.UserName:=FUserName;
+    C.Password:=FPassword;
+    S:=TStringStream.Create;
+    if Pos('?',U)=0 then
+      U:=U+'?'
+    else
+      U:=U+'&';
+    U:=U+'fmt=buf';
+    C.Get(U,S);
+    if FShowRaw then
+      begin
+      Writeln('Raw request data:');
+      Writeln('---');
+      Writeln(S.Datastring);
+      Writeln('---');
+      end;
+    S.Position:=0;
+    aDataset.LoadFromStream(S,dfXML);
+  finally
+    S.Free;
+    C.Free;
+  end;
+end;
+
+procedure TSQLDBRestClientApplication.ShowData(aDataset: TDataset);
+
+Var
+  I : Integer;
+  F : TField;
+  FL : Integer;
+
+begin
+  FL:=0;
+  With aDataset do
+    begin
+    For I:=0 to FieldDefs.Count-1 do
+      if Length(FieldDefs[I].Name)>FL then
+        FL:=Length(FieldDefs[I].Name);
+    While not EOF do
+      begin
+      Writeln(StringOfChar('-',FL));
+      Writeln('Record: ',RecNo:4);
+      Writeln(StringOfChar('-',FL));
+      For F in Fields do
+        With F do
+          begin
+          Write(FieldName:FL,': ');
+          if F.IsNull then
+            Writeln('<NULL>')
+          else
+            Writeln(F.AsString);
+          end;
+      Next;
+      end;
+    end;
+end;
+
+procedure TSQLDBRestClientApplication.DoRun;
+var
+  ErrorMsg: String;
+  D : TBufDataset;
+
+begin
+  // quick check parameters
+  ErrorMsg:=CheckOptions('hU:u:p:r', ['help','url:','username:','password:','raw']);
+  if ErrorMsg<>'' then begin
+    ShowException(Exception.Create(ErrorMsg));
+    Terminate;
+    Exit;
+  end;
+
+  // parse parameters
+  if HasOption('h', 'help') then begin
+    WriteHelp;
+    Terminate;
+    Exit;
+  end;
+  FURL:=GetOptionValue('U','url');
+  FUserName:=GetOptionValue('u','username');
+  FPassword:=GetOptionValue('p','password');
+  FShowRaw:=HasOption('r','raw');
+  D:=TBufDataset.Create(Self);
+  try
+    RunQuery(D);
+    ShowData(D);
+  Finally
+    D.Free;
+  end;
+
+  // stop program loop
+  Terminate;
+end;
+
+constructor TSQLDBRestClientApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+end;
+
+destructor TSQLDBRestClientApplication.Destroy;
+begin
+  inherited Destroy;
+end;
+
+procedure TSQLDBRestClientApplication.WriteHelp;
+begin
+  { add your help code here }
+  writeln('Usage: ', ExeName, ' [options]');
+  Writeln('Where options is one or more of:');
+  Writeln('-h --help            this message');
+  Writeln('-p --password=PWD    HTTP Basic authentication password.');
+  Writeln('-r --raw             Show raw request data');
+  Writeln('-U --url=URL         URL to get data from. Do not add format (fmt) parameter');
+  Writeln('-u --username=User   HTTP Basic authentication username');
+end;
+
+var
+  Application: TSQLDBRestClientApplication;
+begin
+  Application:=TSQLDBRestClientApplication.Create(nil);
+  Application.Title:='SQLDB Rest Bridge client application';
+  Application.Run;
+  Application.Free;
+end.
+

packages/fcl-web/examples/restbridge/demorestbridge.pp

@@ -23,8 +23,7 @@ uses
   {$ENDIF}{$ENDIF}
   Classes, SysUtils, CustApp, sqldbrestbridge, fphttpapp, IBConnection, odbcconn, mysql55conn, mysql56conn, pqconnection,
   mssqlconn, oracleconnection, sqldbrestxml, sqldbrestio, sqldbrestschema, sqldbrestdata, sqldbrestjson, sqldbrestcsv, sqldbrestcds,
-  sqldbrestconst, sqldbrestauth, sqldbrestini, sqldb, sqldbrestauthini
-  ;
+  sqldbrestado,  sqldbrestconst, sqldbrestauth, sqldbrestini, sqldb, sqldbrestauthini;
 
 type
   { TXMLSQLDBRestDispatcher }
@@ -57,7 +56,7 @@ function TXMLSQLDBRestDispatcher.CreateOutputStreamer(IO: TRestIO): TRestOutputS
 begin
   io.Response.ContentStream:=TMemoryStream.Create;
   io.Response.FreeContentStream:=True;
-  Result:=TXMLOutputStreamer.Create(IO.Response.ContentStream,Strings,@IO.DoGetVariable);
+  Result:=TXMLOutputStreamer.Create(IO.Response.ContentStream,Strings,Statuses, @IO.DoGetVariable);
 end;
 
 { TRestServerDemoApplication }
@@ -91,18 +90,22 @@ begin
     Exit;
   end;
   Port:=3000;
-  FDisp:=TSQLDBRestDispatcher.Create(Self);
+  if HasOption('x','xml-only') then
+    FDisp:=TXMLSQLDBRestDispatcher.Create(Self)
+  else
+    FDisp:=TSQLDBRestDispatcher.Create(Self);
   if HasOption('c', 'config') then
     FDisp.LoadFromFile(GetOptionValue('c', 'config'),[dioSkipReadSchemas])
   else
     begin
     // create a Default setup
     FAuth:=TRestBasicAuthenticator.Create(Self);
+    // This is not the DB user !
     FAuth.DefaultUserName:='me';
     FAuth.DefaultPassword:='secret';
     FAuth.AuthenticateUserSQL.Text:='select uID from users where (uLogin=:UserName) and (uPassword=:Password)';
-    FDisp.DispatchOptions:=FDisp.DispatchOptions+[rdoConnectionInURL,rdoCustomView,rdoHandleCORS];
-    FDisp.ExposeDatabase(TPQConnectionDef.TypeName,'localhost','expensetracker','me','secret',Nil,[foFilter,foInInsert,foInUpdate,foOrderByDesc]);
+    FDisp.DispatchOptions:=FDisp.DispatchOptions+[rdoCustomView,rdoHandleCORS];
+    FDisp.ExposeDatabase(TPQConnectionDef.TypeName,'localhost','expensetracker','You','YourSecret',Nil,[foFilter,foInInsert,foInUpdate,foOrderByDesc]);
     With FDisp.Schemas[0].Schema.Resources do
       begin
       FindResourceByName('users').Fields.FindByFieldName('uID').GeneratorName:='seqUsersID';
@@ -146,6 +149,7 @@ begin
   Writeln('-c --config=File      Read config from .ini file');
   Writeln('-m --max-requests=N   Server at most N requests, then quit.');
   Writeln('-s --saveconfig=File  Write config to .ini file (ignored when -c or --config is used)');
+  Writeln('-x --xml-only         Only allow XML requests)');
 end;
 
 var

packages/fcl-web/examples/restbridge/expenses-fb.sql

@@ -0,0 +1,86 @@
+create domain bool smallint check (value in (1,0,Null));
+
+create table ExpenseTypes (
+  etID bigint not null,
+  etName varchar(50) not null,
+  etDescription varchar(100) not null,
+  etMaxAmount decimal(10,2),
+  etCost decimal(10,2) default 1,
+  etActive bool default 1 not null
+);
+
+
+create table Users (
+  uID bigint not null,
+  uLogin varchar(50) not null,
+  uFullName varchar(100) not null,
+  uPassword varchar(100) not null,
+  uActive bool default 1 not null
+);
+
+create table Projects (
+  pID bigint not null,
+  pName varchar(50) not null,
+  pDescription varchar(100) not null,
+  pActive bool default 1 not null
+);
+
+create table Expenses (
+  eID bigint not null,
+  eUserFK bigint not null,
+  eProjectFK bigint not null,
+  eTypeFK bigint not null,
+  eAmount decimal(10,2) not null,
+  eDate date default 'today' not null,
+  eComment varchar(1024)
+);
+
+create sequence seqExpenseTypesID;
+create sequence seqUsersID;
+create sequence seqProjectsID;
+create sequence seqExpenseID;
+
+alter table ExpenseTypes add constraint pkExpenseTypes primary key (etID);
+alter table Users add constraint pkUsers primary key (uID);
+alter table Projects add constraint pkProjects primary key (pID);
+alter table Expenses add  constraint pkExpenses primary key (eID);
+
+SET TERM ^ ;
+CREATE TRIGGER ExpenseTypesID FOR ExpenseTypes ACTIVE
+BEFORE INSERT POSITION 0
+AS
+begin
+  if (NEW.etID is null)  then
+    NEW.etID=GEN_ID(seqExpenseTypesID,1);
+end^
+
+CREATE TRIGGER ExpensesID FOR Expenses ACTIVE
+BEFORE INSERT POSITION 0
+AS
+begin
+  if (NEW.eID is null)  then
+    NEW.eID=GEN_ID(seqExpenseID,1);
+end^
+
+CREATE TRIGGER ProjectsID FOR Projects ACTIVE
+BEFORE INSERT POSITION 0
+AS
+begin
+  if (NEW.pID is null)  then
+    NEW.pID=GEN_ID(seqProjectsID,1);
+end^
+
+CREATE TRIGGER UsersID FOR Users ACTIVE
+BEFORE INSERT POSITION 0
+AS
+begin
+  if (NEW.uID is null)  then
+    NEW.uID=GEN_ID(seqUsersID,1);
+end^
+
+set term ^ ;
+
+COMMIT ;
+
+
+

packages/fcl-web/examples/restbridge/expenses-pq.sql

@@ -1,4 +1,4 @@
-drop table ExpenseTypes;
+create sequence seqExpenseTypesID;
 create table ExpenseTypes (
   etID bigint not null default nextval('seqExpenseTypesID'),
   etName varchar(50) not null,
@@ -25,8 +25,6 @@ create table Projects (
   pActive boolean not null default true
 );
 
-create sequence seqExpenseTypesID;
-
 create sequence seqExpenseID;
 drop table Expenses;
 create table Expenses (

packages/fcl-web/examples/restbridge/expenses-sqlite.sql

@@ -0,0 +1,41 @@
+create table t2(id integer primary key autoincrement);
+insert into  sqlite_sequence (name,seq) values ('seqExpenseTypesID',1);
+insert into  sqlite_sequence (name,seq) values ('seqExpenseID',1);
+insert into  sqlite_sequence (name,seq) values ('seqUsersID',1);
+insert into  sqlite_sequence (name,seq) values ('seqProjectsID',1);
+drop table t2;
+ 
+create table ExpenseTypes (
+  etID bigint primary key,
+  etName varchar(50) not null,
+  etDescription varchar(100) not null,
+  etMaxAmount decimal(10,2),
+  etCost decimal(10,2) default 1,
+  etActive boolean not null default true
+);
+
+create table Users (
+  uID bigint primary key,
+  uLogin varchar(50) not null,
+  uFullName varchar(100) not null,
+  uPassword varchar(100) not null,
+  uActive boolean not null default true 
+);
+
+create table Projects (
+  pID bigint primary key,
+  pName varchar(50) not null,
+  pDescription varchar(100) not null,
+  pActive boolean not null default true
+);
+
+create table Expenses (
+  eID bigint primary key,
+  eUserFK bigint not null,
+  eProjectFK bigint not null,
+  eTypeFK bigint not null,
+  eAmount decimal(10,2) not null,
+  eDate date not null default CURRENT_DATE,
+  eComment varchar(1024)
+);
+

packages/fcl-web/fpmake.pp

@@ -353,6 +353,13 @@ begin
       AddUnit('sqldbrestconst');
       end;
     T:=P.Targets.AddUnit('sqldbrestxml.pp');
+    With T.Dependencies do  
+      begin
+      AddUnit('sqldbrestio');
+      AddUnit('sqldbrestschema');
+      AddUnit('sqldbrestconst');
+      end;
+    T:=P.Targets.AddUnit('sqldbrestado.pp');
     With T.Dependencies do  
       begin
       AddUnit('sqldbrestio');
@@ -373,6 +380,12 @@ begin
       AddUnit('sqldbrestschema');
       AddUnit('sqldbrestconst');
       end;
+    T:=P.Targets.AddUnit('sqldbrestmodule.pp');
+    With T.Dependencies do  
+      begin
+      AddUnit('sqldbrestbridge');
+      AddUnit('sqldbrestconst');
+      end;
     
 {$ifndef ALLPACKAGES}
     Run;

packages/fcl-web/src/restbridge/sqldbrestado.pp

@@ -0,0 +1,390 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2019 by the Free Pascal development team
+
+    SQLDB REST bridge : ADO-styled XML input/output
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit sqldbrestado;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, DateUtils, db,fpjson, dom, XMLRead, XMLWrite,sqldbrestschema,sqldbrestio, sqldbrestbridge;
+
+Type
+
+  { TADOInputStreamer }
+
+  TADOInputStreamer = Class(TRestInputStreamer)
+  private
+    FDataName: UTF8String;
+    FRowName: UTF8String;
+    FXML: TXMLDocument;
+    FPacket : TDOMElement;
+    FData : TDOMElement; // Equals FPacket
+    FRow : TDOMElement;
+  Protected
+    function GetNodeText(N: TDOmNode): UnicodeString;
+  Public
+    Destructor Destroy; override;
+    Class Function GetContentType: String; override;
+    Function SelectObject(aIndex : Integer) : Boolean; override;
+    function GetContentField(aName: UTF8string): TJSONData; override;
+    procedure InitStreaming; override;
+    Property XML : TXMLDocument Read FXML;
+    Property Packet : TDOMElement Read FPacket;
+    Property Data : TDOMElement Read FData;
+    Property Row : TDOMElement Read FRow;
+    Property DataName : UTF8String Read FDataName Write FDataName;
+    Property RowName : UTF8String Read FRowName Write FRowName;
+  end;
+
+  { TADOOutputStreamer }
+
+  TADOOutputStreamer = Class(TRestOutputStreamer)
+  Private
+    FDataName: UTF8String;
+    FRowName: UTF8String;
+    FXML: TXMLDocument;
+    FData : TDOMElement; // Equals FRoot
+    FRow: TDOMElement;
+    FRoot: TDomElement;
+    function CreateXSD: TDomElement;
+  Public
+    procedure EndData; override;
+    procedure EndRow; override;
+    procedure FinalizeOutput; override;
+    procedure StartData; override;
+    procedure StartRow; override;
+    // Return Nil for null field.
+    function FieldToXML(aPair: TRestFieldPair): TDOMElement; virtual;
+    procedure WriteField(aPair: TRestFieldPair); override;
+    procedure WriteMetadata(aFieldList: TRestFieldPairArray); override;
+    Procedure CreateErrorContent(aCode : Integer; Const aMessage: String); override;
+    Property XML : TXMLDocument Read FXML;
+    Property Data : TDOMelement Read FData;
+    Property Row : TDOMelement Read FRow;
+  Public
+    Destructor Destroy; override;
+    Class Function GetContentType: String; override;
+    function RequireMetadata : Boolean; override;
+    procedure InitStreaming; override;
+    Property DataName : UTF8String Read FDataName Write FDataName;
+    Property RowName : UTF8String Read FRowName Write FRowName;
+  end;
+
+implementation
+
+uses sqldbrestconst;
+
+{ TADOInputStreamer }
+
+destructor TADOInputStreamer.Destroy;
+begin
+  FreeAndNil(FXML);
+  inherited Destroy;
+end;
+
+class function TADOInputStreamer.GetContentType: String;
+begin
+  Result:='text/xml';
+end;
+
+function TADOInputStreamer.SelectObject(aIndex: Integer): Boolean;
+
+Var
+  N : TDomNode;
+  NN : UnicodeString;
+begin
+  Result:=False;
+  NN:=UTF8Decode(RowName);
+  N:=FData.FindNode(NN);
+  While (aIndex>0) and (N<>Nil) and (N.NodeName<>NN) and (N.NodeType<>ELEMENT_NODE) do
+    begin
+    N:=N.NextSibling;
+    Dec(aIndex);
+    end;
+  Result:=(aIndex=0) and (N<>Nil);
+  If Result then
+    FRow:=N as TDomElement
+  else
+    FRow:=Nil;
+end;
+
+function TADOInputStreamer.GetNodeText(N: TDOmNode): UnicodeString;
+
+Var
+  V : TDomNode;
+
+begin
+  Result:='';
+  V:=N.FirstChild;
+  While (V<>Nil) and (V.NodeType<>TEXT_NODE) do
+    V:=V.NextSibling;
+  If Assigned(V) then
+    Result:=V.NodeValue;
+end;
+
+function TADOInputStreamer.GetContentField(aName: UTF8string): TJSONData;
+
+Var
+  NN : UnicodeString;
+  N : TDomNode;
+begin
+  NN:=UTF8Decode(aName);
+  N:=FRow.FindNode(NN);
+  if Assigned(N) and (N.NodeType=ELEMENT_NODE) then
+    Result:=TJSONString.Create(UTF8Encode(GetNodeText(N)));
+end;
+
+procedure TADOInputStreamer.InitStreaming;
+
+Var
+  Msg : String;
+  NN : UnicodeString;
+
+begin
+  if DataName='' then
+    DataName:='Data';
+  if RowName='' then
+    RowName:='Row';
+  FreeAndNil(FXML);
+  if Stream.Size<=0 then
+    exit;
+  try
+    ReadXMLFile(FXML,Stream);
+  except
+    On E : Exception do
+      begin
+      Msg:=E.Message;
+      FXML:=Nil;
+      end;
+  end;
+  if (FXML=Nil)  then
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[Msg]);
+  FPacket:=FXML.DocumentElement;
+  NN:=UTF8Decode(DataName);
+  if FPacket.NodeName<>NN then
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[SErrMissingDocumentRoot]);
+  FData:=FPacket;
+end;
+
+{ TADOOutputStreamer }
+
+
+procedure TADOOutputStreamer.EndData;
+begin
+  FData:=Nil;
+end;
+
+procedure TADOOutputStreamer.EndRow;
+begin
+  FRow:=Nil;
+end;
+
+procedure TADOOutputStreamer.FinalizeOutput;
+
+begin
+{$IFNDEF VER3_0}
+  if Not (ooHumanReadable in OutputOptions) then
+    begin
+    With TDOMWriter.Create(Stream,FXML) do
+      try
+        LineBreak:='';
+        IndentSize:=0;
+        WriteNode(FXML);
+      finally
+        Free;
+      end;
+    end
+  else
+{$ENDIF}
+    xmlwrite.WriteXML(FXML,Stream);
+  FreeAndNil(FXML);
+end;
+
+procedure TADOOutputStreamer.StartData;
+begin
+  // Rows are straight under the Data packet
+  FData:=FRoot;
+end;
+
+procedure TADOOutputStreamer.StartRow;
+begin
+  if (FRow<>Nil) then
+    Raise ESQLDBRest.Create(Statuses.GetStatusCode(rsError),SErrDoubleRowStart);
+  FRow:=FXML.CreateElement(UTF8Decode(RowName));
+  FData.AppendChild(FRow);
+end;
+
+function TADOOutputStreamer.FieldToXML(aPair: TRestFieldPair): TDOMElement;
+
+Var
+  F : TField;
+  S : UTF8String;
+
+begin
+  Result:=Nil;
+  F:=aPair.DBField;;
+  If (aPair.RestField.FieldType=rftUnknown) then
+    raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
+  If (F.IsNull) then
+    Exit;
+  S:=FieldToString(aPair.RestField.FieldType,F);
+  Result:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName));
+  Result.AppendChild(FXML.CreateTextNode(UTF8Decode(S)));
+end;
+
+procedure TADOOutputStreamer.WriteField(aPair: TRestFieldPair);
+
+Var
+  D : TDOMElement;
+  N : UTF8String;
+
+begin
+  N:=aPair.RestField.PublicName;
+  if FRow=Nil then
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]);
+  D:=FieldToXML(aPair);
+  if (D=Nil) and (not HasOption(ooSparse)) then
+    D:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName));
+  if D<>Nil then
+    FRow.AppendChild(D);
+end;
+
+function TADOOutputStreamer.CreateXSD: TDomElement;
+
+// Create XSD and append to root. Return element to which field list must be appended.
+
+Var
+  SN,N,E,TLN : TDomElement;
+
+begin
+  SN:=FXML.CreateElement('xs:schema');
+  SN['id']:=Utf8Decode(DataName);
+  SN['xmlns']:='';
+  SN['xmlns:xs']:='http://www.w3.org/2001/XMLSchema';
+  SN['xmlns:msdata']:= 'urn:schemas-microsoft-com:xml-msdata';
+  FRoot.AppendChild(SN);
+  // Add table list with 1 table.
+  // Element
+  N:=FXML.CreateElement('xs:element');
+  SN.AppendChild(N);
+  N['name']:=UTF8Decode(DataName);
+  N['msdata:IsDataSet']:='true';
+  N['msdata:UseCurrentLocale']:='true';
+  // element is a complex type
+  TLN:=FXML.CreateElement('xs:complexType');
+  N.AppendChild(TLN);
+  // Complex type is a choice (0..Unbounded] of records
+  N:=FXML.CreateElement('xs:choice');
+  TLN.AppendChild(N);
+  N['minOccurs']:='0';
+  N['maxOccurs']:='unbounded';
+  // Each record is an element
+  E:=FXML.CreateElement('xs:element');
+  N.AppendChild(E);
+  E['name']:=Utf8Decode(RowName);
+  // Record is a complex type of fields
+  N:=FXML.CreateElement('xs:complexType');
+  E.AppendChild(N);
+  // Fields are a sequence. To this sequence, the fields may be appended.
+  Result:=FXML.CreateElement('xs:sequence');
+  N.AppendChild(Result);
+end;
+
+Const
+  XMLPropTypeNames : Array [TRestFieldType] of string = (
+   'unknown',          { rtfUnknown }
+   'xs:int',          { rftInteger }
+   'xs:int',          { rftLargeInt}
+   'xs:double',       { rftFloat }
+   'xs:dateTime',     { rftDate }
+   'xs:dateTime',     { rftTime }
+   'xs:dateTime',     { rftDateTime }
+   'xs:string',       { rftString }
+   'xs:boolean',      { rftBoolean }
+   'xs:base64Binary'  { rftBlob }
+  );
+
+procedure TADOOutputStreamer.WriteMetadata(aFieldList: TRestFieldPairArray);
+
+Var
+  FMetadata : TDOMElement;
+  F : TDomElement;
+  P : TREstFieldPair;
+  I : integer;
+  S : Utf8String;
+  K : TRestFieldType;
+
+begin
+  FMetadata:=CreateXSD;
+  For I:=0 to Length(aFieldList)-1 do
+    begin
+    P:=aFieldList[i];
+    K:=P.RestField.FieldType;
+    S:=XMLPropTypeNames[K];
+    F:=FXML.CreateElement('xs:element');
+    F['name']:=Utf8Decode(P.Restfield.PublicName);
+    F['type']:=Utf8decode(S);
+    F['minOccurs']:='0';
+    FMetaData.AppendChild(F);
+    end;
+end;
+
+class function TADOOutputStreamer.GetContentType: String;
+begin
+  Result:='text/xml';
+end;
+
+function TADOOutputStreamer.RequireMetadata: Boolean;
+begin
+  Result:=True;
+end;
+
+procedure TADOOutputStreamer.CreateErrorContent(aCode: Integer; const aMessage: String);
+
+Var
+  ErrorObj : TDomElement;
+
+begin
+  ErrorObj:=FXML.CreateElement(UTF8Decode(GetString(rpErrorRoot)));
+  ErrorObj['code']:=UTF8Decode(IntToStr(aCode));
+  ErrorObj['message']:=UTF8Decode(aMessage);
+  FRoot.AppendChild(ErrorObj);
+end;
+
+destructor TADOOutputStreamer.Destroy;
+begin
+  FreeAndNil(FXML);
+  inherited Destroy;
+end;
+
+procedure TADOOutputStreamer.InitStreaming;
+
+begin
+  FXML:=TXMLDocument.Create;
+  FXML.XMLStandalone:=True;
+  if DataName='' then
+    DataName:='Data';
+  FRoot:=FXML.CreateElement('Data');
+  FXML.AppendChild(FRoot);
+  if RowName='' then
+    RowName:='Row';
+end;
+
+Initialization
+  TADOInputStreamer.RegisterStreamer('ado');
+  TADOOutputStreamer.RegisterStreamer('ado');
+end.
+

packages/fcl-web/src/restbridge/sqldbrestauth.pp

@@ -236,7 +236,7 @@ begin
     IO.UserID:=UID
   else
     begin
-    IO.Response.Code:=401;
+    IO.Response.Code:=IO.RestStatuses.GetStatusCode(rsUnauthorized);
     IO.Response.CodeText:=SUnauthorized;
     IO.Response.WWWAuthenticate:=Format('BASIC Realm: "%s"',[AuthenticationRealm]);
     end;

packages/fcl-web/src/restbridge/sqldbrestbridge.pp

@@ -22,7 +22,7 @@ uses
   Classes, SysUtils, DB, SQLDB, httpdefs, httproute, fpjson, sqldbrestschema, sqldbrestio, sqldbrestdata, sqldbrestauth;
 
 Type
-  TRestDispatcherOption = (rdoConnectionInURL,rdoExposeMetadata,rdoCustomView,rdoHandleCORS);
+  TRestDispatcherOption = (rdoConnectionInURL,rdoExposeMetadata,rdoCustomView,rdoHandleCORS,rdoAccessCheckNeedsDB);
   TRestDispatcherOptions = set of TRestDispatcherOption;
 
 Const
@@ -56,6 +56,7 @@ Type
     constructor Create(ACollection: TCollection); override;
     Destructor Destroy; override;
     Procedure Assign(Source: TPersistent); override;
+    Procedure ConfigConnection(aConn : TSQLConnection); virtual;
   Published
     // Always use this connection instance
     Property SingleConnection : TSQLConnection Read FConnection Write SetConnection;
@@ -160,7 +161,9 @@ Type
     Class Var FIOClass : TRestIOClass;
     Class Var FDBHandlerClass : TSQLDBRestDBHandlerClass;
   private
+    FCORSAllowCredentials: Boolean;
     FCORSAllowedOrigins: String;
+    FCORSMaxAge: Integer;
     FDispatchOptions: TRestDispatcherOptions;
     FInputFormat: String;
     FCustomViewResource : TSQLDBRestResource;
@@ -192,11 +195,13 @@ Type
     FSchemas: TSQLDBRestSchemaList;
     FListRoute: THTTPRoute;
     FItemRoute: THTTPRoute;
+    FStatus: TRestStatusConfig;
     FStrings: TRestStringsConfig;
     procedure SetActive(AValue: Boolean);
     procedure SetAuthenticator(AValue: TRestAuthenticator);
     procedure SetConnections(AValue: TSQLDBRestConnectionList);
     procedure SetSchemas(AValue: TSQLDBRestSchemaList);
+    procedure SetStatus(AValue: TRestStatusConfig);
     procedure SetStrings(AValue: TRestStringsConfig);
   Protected
     // Auxiliary methods.
@@ -207,6 +212,7 @@ Type
     Function CreateConnectionList : TSQLDBRestConnectionList; virtual;
     Function CreateSchemaList : TSQLDBRestSchemaList; virtual;
     function CreateRestStrings: TRestStringsConfig; virtual;
+    function CreateRestStatusConfig: TRestStatusConfig; virtual;
     function CreateDBHandler(IO: TRestIO): TSQLDBRestDBHandler; virtual;
     function CreateInputStreamer(IO: TRestIO): TRestInputStreamer; virtual;
     function CreateOutputStreamer(IO: TRestIO): TRestOutputStreamer; virtual;
@@ -227,6 +233,10 @@ Type
     function ExtractRestOperation(aRequest: TRequest;AccessControl : Boolean = false): TRestoperation; virtual;
     function FindRestResource(aResource: UTF8String): TSQLDBRestResource; virtual;
     function AllowRestResource(aIO : TRestIO): Boolean; virtual;
+    function AllowRestOperation(aIO: TRestIO): Boolean; virtual;
+    // Called twice: once before connection is established, once after.
+    // checks rdoAccessCheckNeedsDB and availability of connection
+    function CheckResourceAccess(IO: TRestIO): Boolean;
     function ExtractRestResourceName(IO: TRestIO): UTF8String; virtual;
     // Override if you want to create non-sqldb based resources
     function CreateSpecialResourceDataset(IO: TRestIO; AOwner: TComponent): TDataset; virtual;
@@ -245,6 +255,7 @@ Type
     // General HTTP handling
     procedure DoRegisterRoutes; virtual;
     procedure DoHandleEvent(IsBefore : Boolean;IO: TRestIO); virtual;
+    function ResolvedCORSAllowedOrigins: String; virtual;
     procedure HandleCORSRequest(aConnection: TSQLDBRestConnection; IO: TRestIO); virtual;
     procedure HandleResourceRequest(aConnection : TSQLDBRestConnection; IO: TRestIO); virtual;
     procedure DoHandleRequest(IO: TRestIO); virtual;
@@ -273,6 +284,8 @@ Type
     Property DefaultConnection : UTF8String Read FDefaultConnection Write FDefaultConnection;
     // Input/Output strings configuration
     Property Strings : TRestStringsConfig Read FStrings Write SetStrings;
+    // HTTP Status codes configuration
+    Property Statuses : TRestStatusConfig Read FStatus Write SetStatus;
     // default Output options, modifiable by query.
     Property OutputOptions : TRestOutputOptions Read FOutputOptions Write FOutputOptions Default allOutputOptions;
     // Set this to allow only this input format.
@@ -287,6 +300,10 @@ Type
     Property EnforceLimit : Integer Read FEnforceLimit Write FEnforceLimit;
     // Domains that are allowed to use this REST service
     Property CORSAllowedOrigins: String Read FCORSAllowedOrigins  Write FCORSAllowedOrigins;
+    // Access-Control-Max-Age header value. Set to zero not to send the header
+    Property CORSMaxAge : Integer Read FCORSMaxAge Write FCORSMaxAge;
+    // Access-Control-Allow-Credentials header value. Set to zero not to send the header
+    Property CORSAllowCredentials : Boolean Read FCORSAllowCredentials Write FCORSAllowCredentials;
     // Called when Basic authentication is sufficient.
     Property OnBasicAuthentication : TBasicAuthenticationEvent Read FOnBasicAuthentication Write FOnBasicAuthentication;
     // Allow a particular resource or not.
@@ -424,6 +441,12 @@ begin
   FSchemas.Assign(AValue);
 end;
 
+procedure TSQLDBRestDispatcher.SetStatus(AValue: TRestStatusConfig);
+begin
+  if FStatus=AValue then Exit;
+  FStatus.Assign(AValue);
+end;
+
 procedure TSQLDBRestDispatcher.SetStrings(AValue: TRestStringsConfig);
 begin
   if FStrings=AValue then Exit;
@@ -519,8 +542,8 @@ begin
     aName:='json';
   D:=TStreamerFactory.Instance.FindStreamerByName(rstInput,aName);
   if (D=Nil) then
-    Raise ESQLDBRest.CreateFmt(400,SErrUnknownOrUnSupportedFormat,[aName]);
-  Result:=TRestInputStreamer(D.MyClass.Create(IO.RequestContentStream,Fstrings,@IO.DoGetVariable));
+    Raise ESQLDBRest.CreateFmt(FStatus.GetStatusCode(rsInvalidParam),SErrUnknownOrUnSupportedFormat,[aName]);
+  Result:=TRestInputStreamer(D.MyClass.Create(IO.RequestContentStream,Fstrings,FStatus,@IO.DoGetVariable));
 end;
 
 function TSQLDBRestDispatcher.CreateOutputStreamer(IO : TRestIO): TRestOutputStreamer;
@@ -535,8 +558,8 @@ begin
     aName:='json';
   D:=TStreamerFactory.Instance.FindStreamerByName(rstOutput,aName);
   if (D=Nil) then
-    Raise ESQLDBRest.CreateFmt(400,SErrUnknownOrUnSupportedFormat,[aName]);
-  Result:=TRestOutputStreamer(D.MyClass.Create(IO.Response.ContentStream,Fstrings,@IO.DoGetVariable));
+    Raise ESQLDBRest.CreateFmt(FStatus.GetStatusCode(rsInvalidParam),SErrUnknownOrUnSupportedFormat,[aName]);
+  Result:=TRestOutputStreamer(D.MyClass.Create(IO.Response.ContentStream,Fstrings,FStatus,@IO.DoGetVariable));
 end;
 
 
@@ -554,6 +577,7 @@ begin
     // Set up output
     Result.Response.ContentStream:=TMemoryStream.Create;
     Result.Response.FreeContentStream:=True;
+    Result.SetRestStatuses(FStatus);
     Result.SetRestStrings(FStrings);
     aInput:=CreateInputStreamer(Result);
     aoutPut:=CreateOutPutStreamer(Result);
@@ -606,6 +630,9 @@ begin
   FSchemas:=CreateSchemaList;
   FOutputOptions:=allOutputOptions;
   FDispatchOptions:=DefaultDispatcherOptions;
+  FStatus:=CreateRestStatusConfig;
+  FCORSMaxAge:=SecsPerDay;
+  FCORSAllowCredentials:=True;
 end;
 
 destructor TSQLDBRestDispatcher.Destroy;
@@ -617,6 +644,7 @@ begin
   FreeAndNil(FSchemas);
   FreeAndNil(FConnections);
   FreeAndNil(FStrings);
+  FreeAndNil(FStatus);
   inherited Destroy;
 end;
 
@@ -626,6 +654,11 @@ begin
   Result:=TRestStringsConfig.Create
 end;
 
+function TSQLDBRestDispatcher.CreateRestStatusConfig: TRestStatusConfig;
+begin
+  Result:=TRestStatusConfig.Create;
+end;
+
 function TSQLDBRestDispatcher.ExtractRestResourceName(IO: TRestIO): UTF8String;
 
 begin
@@ -634,10 +667,10 @@ begin
     Result:=IO.Request.QueryFields.Values[Strings.ResourceParam];
 end;
 
-function TSQLDBRestDispatcher.AllowRestResource( aIO: TRestIO): Boolean;
+function TSQLDBRestDispatcher.AllowRestResource(aIO: TRestIO): Boolean;
 
 begin
-  Result:=True;
+  Result:=aIO.Resource.AllowResource(aIO.RestContext);
   if Assigned(FOnAllowResource) then
     FOnAllowResource(Self,aIO.Request,aIO.ResourceName,Result);
 end;
@@ -660,7 +693,10 @@ Var
 begin
   Result:=TSQLDBRestResource.Create(Nil);
   Result.ResourceName:='metaData';
-  Result.AllowedOperations:=[roGet];
+  if rdoHandleCORS in DispatchOptions then
+    Result.AllowedOperations:=[roGet,roOptions,roHead]
+  else
+    Result.AllowedOperations:=[roGet,roHead];
   Result.Fields.AddField('name',rftString,[foRequired]);
   Result.Fields.AddField('schemaName',rftString,[foRequired]);
   for O in TRestOperation do
@@ -681,7 +717,10 @@ Var
 begin
   Result:=TSQLDBRestResource.Create(Nil);
   Result.ResourceName:='metaDataField';
-  Result.AllowedOperations:=[roGet];
+  if rdoHandleCORS in DispatchOptions then
+    Result.AllowedOperations:=[roGet,roOptions,roHead]
+  else
+    Result.AllowedOperations:=[roGet,roHead];
   Result.Fields.AddField('name',rftString,[]);
   Result.Fields.AddField('type',rftString,[]);
   Result.Fields.AddField('maxlen',rftInteger,[]);
@@ -841,14 +880,7 @@ begin
     if (Result=Nil) then
       begin
       Result:=CreateConnection;
-      Result.CharSet:=aConnection.CharSet;
-      Result.HostName:=aConnection.HostName;
-      Result.DatabaseName:=aConnection.DatabaseName;
-      Result.UserName:=aConnection.UserName;
-      Result.Password:=aConnection.Password;
-      Result.Params:=Aconnection.Params;
-      if Result is TRestSQLConnector then
-        TRestSQLConnector(Result).ConnectorType:=aConnection.ConnectionType;
+      aConnection.ConfigConnection(Result);
       aConnection.SingleConnection:=Result;
       end;
     end;
@@ -917,18 +949,18 @@ end;
 procedure TSQLDBRestDispatcher.SetDefaultResponsecode(IO : TRestIO);
 
 Const
-  DefaultCodes : Array[TRestOperation] of Integer = (500,200,201,200,204,200,200);
+  DefaultCodes : Array[TRestOperation] of TRestStatus = (rsError,rsGetOK,rsPOSTOK,rsPUTOK,rsDeleteOK,rsCORSOK,rsGetOK);
   DefaultTexts : Array[TRestOperation] of string = ('Internal Error','OK','Created','OK','No content','OK','OK');
 
 Var
-  aCode : Integer;
+  aCode : TRestStatus;
   aText : String;
 
 begin
   aCode:=DefaultCodes[IO.Operation];
   aText:=DefaultTexts[IO.Operation];
   if IO.Response.Code=0 then
-    IO.Response.Code:=aCode;
+    IO.Response.Code:=FStatus.GetStatusCode(aCode);
   if (IO.Response.CodeText='') then
     IO.Response.CodeText:=aText;
 end;
@@ -1102,7 +1134,7 @@ Var
 begin
   ST:=IO.Connection.GetStatementInfo(aSQL).StatementType;
   if (st<>stSelect) then
-    Raise ESQLDBRest.Create(400,'Only SELECT SQL is allowed for custom view'); // Should never happen.
+    raise ESQLDBRest.Create(FStatus.GetStatusCode(rsInvalidParam), SErrOnlySELECTSQLAllowedInCustomView); // Should never happen.
   Q:=TRestSQLQuery.Create(aOwner);
   try
     Q.DataBase:=IO.Connection;
@@ -1130,16 +1162,23 @@ begin
   else if (IO.Resource=FMetadataDetailResource) then
     begin
     if IO.GetVariable('ID',RN,[vsRoute,vsQuery])=vsNone then
-      Raise ESQLDBRest.Create(500,'Could not find resource name'); // Should never happen.
+      raise ESQLDBRest.Create(FStatus.GetStatusCode(rsError), SErrCouldNotFindResourceName); // Should never happen.
     Result:=CreateMetadataDetailDataset(IO,RN,AOwner)
     end
   else   if (IO.Resource=FCustomViewResource) then
     begin
     if IO.GetVariable(FStrings.GetRestString(rpCustomViewSQLParam),RN,[vsRoute,vsQuery])=vsNone then
-      Raise ESQLDBRest.Create(400,'Could not find SQL statement for custom view'); // Should never happen.
+      raise ESQLDBRest.Create(FStatus.GetStatusCode(rsInvalidParam), SErrNoSQLStatement); // Should never happen.
     Result:=CreateCustomViewDataset(IO,RN,aOwner);
     end
+end;
+
+function TSQLDBRestDispatcher.ResolvedCORSAllowedOrigins: String;
 
+begin
+  Result:=FCORSAllowedOrigins;
+  if Result='' then
+     Result:='*';
 end;
 
 procedure TSQLDBRestDispatcher.HandleCORSRequest(aConnection : TSQLDBRestConnection; IO : TRestIO);
@@ -1155,19 +1194,20 @@ begin
     Allowed:=(ExtractRestOperation(IO.Request,True) in ([roUnknown]+IO.Resource.AllowedOperations));
   if not Allowed then
     begin
-    IO.Response.Code:=403;
+    IO.Response.Code:=FStatus.GetStatusCode(rsCORSNotAllowed);
     IO.Response.CodeText:='FORBIDDEN';
     IO.CreateErrorResponse;
     end
   else
     begin
-    S:=FCORSAllowedOrigins;
-    if S='' then
-      S:='*';
-    IO.Response.SetCustomHeader('Access-Control-Allow-Origin',S);
+    IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins);
     S:=IO.Resource.GetHTTPAllow;
     IO.Response.SetCustomHeader('Access-Control-Allow-Methods',S);
-    IO.Response.Code:=200;
+    IO.Response.SetCustomHeader('Access-Control-Allow-Headers','x-requested-with, content-type, authorization');
+    if CorsMaxAge>0 then
+      IO.Response.SetCustomHeader('Access-Control-Max-Age',IntToStr(CorsMaxAge));
+    IO.Response.SetCustomHeader('Access-Control-Allow-Credentials',BoolToStr(CORSAllowCredentials,'true','false'));
+    IO.Response.Code:=FStatus.GetStatusCode(rsCORSOK);
     IO.Response.CodeText:='OK';
     end;
 end;
@@ -1186,8 +1226,12 @@ begin
   try
     IO.SetConn(Conn,TR);
     Try
+      if (rdoHandleCORS in DispatchOptions) then
+        IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins);
       if not AuthenticateRequest(IO,True) then
         exit;
+      if Not CheckResourceAccess(IO) then
+        exit;
       DoHandleEvent(True,IO);
       H:=CreateDBHandler(IO);
       if IsSpecialResource(IO.Resource) then
@@ -1265,6 +1309,33 @@ begin
   Result:=TSQLDBRestSchemaList.Create(TSQLDBRestSchemaRef);
 end;
 
+function TSQLDBRestDispatcher.AllowRestOperation(aIO: TRestIO): Boolean;
+
+begin
+  Result:=(aIO.Operation in aIO.Resource.GetAllowedOperations(aIO.RestContext));
+end;
+
+function TSQLDBRestDispatcher.CheckResourceAccess(IO: TRestIO): Boolean;
+
+Var
+  NeedDB : Boolean;
+
+begin
+  NeedDB:=(rdoAccessCheckNeedsDB in DispatchOptions);
+  Result:=NeedDB<>Assigned(IO.Connection);
+  if Result then
+    exit;
+  Result:=AllowRestResource(IO);
+  if not Result then
+    CreateErrorContent(IO,FStatus.GetStatusCode(rsResourceNotAllowed),'FORBIDDEN')
+  else
+    begin
+    Result:=AllowRestOperation(IO);
+    if not Result then
+      CreateErrorContent(IO,FStatus.GetStatusCode(rsRestOperationNotAllowed),'METHOD NOT ALLOWED')
+    end;
+end;
+
 procedure TSQLDBRestDispatcher.DoHandleRequest(IO : TRestIO);
 
 var
@@ -1276,22 +1347,20 @@ var
 begin
   Operation:=ExtractRestOperation(IO.Request);
   if (Operation=roUnknown) then
-    CreateErrorContent(IO,400,'Invalid method')
+    CreateErrorContent(IO,FStatus.GetStatusCode(rsInvalidMethod),'INVALID METHOD')
   else
     begin
     IO.SetOperation(Operation);
     ResourceName:=ExtractRestResourceName(IO);
     if (ResourceName='') then
-      CreateErrorContent(IO,404,'Invalid resource')
+      CreateErrorContent(IO,FStatus.GetStatusCode(rsNoResourceSpecified),'INVALID RESOURCE')
     else
       begin
       Resource:=FindSpecialResource(IO,ResourceName);
       If Resource=Nil then
         Resource:=FindRestResource(ResourceName);
       if Resource=Nil then
-        CreateErrorContent(IO,404,'Invalid resource')
-      else if Not (Operation in Resource.AllowedOperations) then
-        CreateErrorContent(IO,405,'Method not allowed')
+        CreateErrorContent(IO,FStatus.GetStatusCode(rsUnknownResource),'NOT FOUND')
       else
         begin
         IO.SetResource(Resource);
@@ -1299,13 +1368,11 @@ begin
         if Connection=Nil then
           begin
           if (rdoConnectionInURL in DispatchOptions) then
-            CreateErrorContent(IO,400,Format(SErrNoconnection,[GetConnectionName(IO)]))
+            CreateErrorContent(IO,FStatus.GetStatusCode(rsNoConnectionSpecified),Format(SErrNoconnection,[GetConnectionName(IO)]))
           else
-            CreateErrorContent(IO,500,Format(SErrNoconnection,[GetConnectionName(IO)]));
+            CreateErrorContent(IO,FStatus.GetStatusCode(rsError), Format(SErrNoconnection,[GetConnectionName(IO)]));
           end
-        else if not AllowRestResource(IO) then
-          CreateErrorContent(IO,403,'Forbidden')
-        else
+        else if CheckResourceAccess(IO) then
           if Operation=roOptions then
             HandleCORSRequest(Connection,IO)
           else
@@ -1365,7 +1432,7 @@ begin
         end;
       if (Code=0) then
         begin
-        Code:=500;
+        Code:=FStatus.GetStatusCode(rsError);
         Msg:=Format(SErrUnexpectedException,[E.ClassName,E.Message]);
         end;
       IO.Response.Code:=Code;
@@ -1377,7 +1444,7 @@ begin
   except
     on Ex : exception do
      begin
-     IO.Response.Code:=500;
+     IO.Response.Code:=FStatus.GetStatusCode(rsError);
      IO.Response.CodeText:=Format('Unexpected exception %s while handling original exception %s : "%s" (Original: "%s")',[Ex.ClassName,E.ClassName,Ex.Message,E.Message]);
      end;
   end;
@@ -1788,6 +1855,18 @@ begin
     inherited Assign(Source);
 end;
 
+procedure TSQLDBRestConnection.ConfigConnection(aConn: TSQLConnection);
+begin
+  aConn.CharSet:=Self.CharSet;
+  aConn.HostName:=Self.HostName;
+  aConn.DatabaseName:=Self.DatabaseName;
+  aConn.UserName:=Self.UserName;
+  aConn.Password:=Self.Password;
+  aConn.Params:=Self.Params;
+  if aConn is TSQLConnector then
+    TSQLConnector(aConn).ConnectorType:=Self.ConnectionType;
+end;
+
 
 Procedure InitSQLDBRest;
 

packages/fcl-web/src/restbridge/sqldbrestcds.pp

@@ -34,6 +34,7 @@ Type
   Public
     Destructor Destroy; override;
     Class Function GetContentType: String; override;
+    Class Function ForBufDataset: Boolean; virtual;
     Function SelectObject(aIndex : Integer) : Boolean; override;
     function GetContentField(aName: UTF8string): TJSONData; override;
     procedure InitStreaming; override;
@@ -53,6 +54,7 @@ Type
     FRow : TDOMElement;
     FRowData: TDOMElement;
   Protected
+    Class Function ForBufDataset: Boolean; virtual;
     Procedure SetOutputOptions(AValue: TRestOutputOptions); override;
   Public
     procedure EndData; override;
@@ -74,6 +76,20 @@ Type
     procedure InitStreaming; override;
   end;
 
+  { TBufDatasetOutputStreamer }
+
+  TBufDatasetOutputStreamer = Class(TCDSOutputStreamer)
+  Protected
+    Class Function ForBufDataset: Boolean; override;
+  end;
+
+  { TBufDatasetInputStreamer }
+
+  TBufDatasetInputStreamer = Class(TCDSInputStreamer)
+  Protected
+    Class Function ForBufDataset: Boolean; override;
+  end;
+
 implementation
 
 uses sqldbrestconst;
@@ -98,6 +114,20 @@ Const
     'bin.hex:Binary' {rftBlob}
   );
 
+{ TBufDatasetInputStreamer }
+
+class function TBufDatasetInputStreamer.ForBufDataset: Boolean;
+begin
+  Result:=True;
+end;
+
+{ TBufDatasetOutputStreamer }
+
+class function TBufDatasetOutputStreamer.ForBufDataset: Boolean;
+begin
+  Result:=True;
+end;
+
 { TCDSInputStreamer }
 
 destructor TCDSInputStreamer.Destroy;
@@ -111,6 +141,11 @@ begin
   Result:='text/xml';
 end;
 
+class function TCDSInputStreamer.ForBufDataset: Boolean;
+begin
+  Result:=False;
+end;
+
 function TCDSInputStreamer.SelectObject(aIndex: Integer): Boolean;
 
 Var
@@ -182,6 +217,11 @@ end;
 
 { TCDSOutputStreamer }
 
+class function TCDSOutputStreamer.ForBufDataset: Boolean;
+begin
+  Result:=False;
+end;
+
 procedure TCDSOutputStreamer.SetOutputOptions(AValue: TRestOutputOptions);
 begin
   Include(AValue,ooMetadata); // We always need metadata
@@ -201,6 +241,20 @@ end;
 procedure TCDSOutputStreamer.FinalizeOutput;
 
 begin
+{$IFNDEF VER3_0}
+  if Not (ooHumanReadable in OutputOptions) then
+    begin
+    With TDOMWriter.Create(Stream,FXML) do
+      try
+        LineBreak:='';
+        IndentSize:=0;
+        WriteNode(FXML);
+      finally
+        Free;
+      end;
+    end
+  else
+{$ENDIF}
   xmlwrite.WriteXML(FXML,Stream);
   FreeAndNil(FXML);
 end;
@@ -242,6 +296,7 @@ begin
   FRow[UTF8Decode(N)]:=UTF8Decode(S);
 end;
 
+
 procedure TCDSOutputStreamer.WriteMetadata(aFieldList: TRestFieldPairArray);
 
 Var
@@ -269,7 +324,11 @@ begin
          ML:=P.RestField.MaxLen;
          if ML=0 then
            ML:=255;
-         F['WIDTH']:=Utf8Decode(IntToStr(P.RestField.MaxLen));
+         if ForBufDataset then
+           F['width']:=Utf8Decode(IntToStr(P.RestField.MaxLen))
+         else
+           F['WIDTH']:=Utf8Decode(IntToStr(P.RestField.MaxLen));
+
          end;
       if (ST<>'') then
         F['subtype']:=ST;
@@ -315,6 +374,8 @@ end;
 
 Initialization
   TCDSInputStreamer.RegisterStreamer('cds');
+  TBufDatasetInputStreamer.RegisterStreamer('buf');
   TCDSOutputStreamer.RegisterStreamer('cds');
+  TBufDatasetOutputStreamer.RegisterStreamer('buf');
 end.
 

packages/fcl-web/src/restbridge/sqldbrestconst.pp

@@ -44,6 +44,11 @@ Resourcestring
   SErrMissingDocumentRoot = 'Missing document root';
   SErrInvalidCDSMissingElement = 'Invalid CDS Data packet: missing %s element';
   SErrNoResourceDataFound = 'Failed to find resource data in input';
+  SErrNoRESTDispatcher = 'No REST bridge dispatcher assigned to handle request!';
+  SErrCouldNotFindResourceName = 'Could not find resource name';
+  SErrNoSQLStatement = 'Could not find SQL statement for custom view';
+  SErrOnlySELECTSQLAllowedInCustomView = 'Only SELECT SQL is allowed for '
+    +'custom view';
 
 Const
   DefaultAuthenticationRealm = 'REST API Server';

packages/fcl-web/src/restbridge/sqldbrestdata.pp

@@ -150,7 +150,7 @@ begin
   Result:='';
   if (IO.GetVariable('ID',Qry,[vsQuery,vsRoute,vsHeader])=vsNone) or (Qry='') then
     if not Assigned(PostParams) then
-      raise ESQLDBRest.Create(400,SErrNoKeyParam);
+      raise ESQLDBRest.Create(IO.RestStatuses.GetStatusCode(rsInvalidParam),SErrNoKeyParam);
   L:=FResource.GetFieldArray(flWhereKey);
   SetLength(FilteredFields,Length(L));
   for I:=0 to Length(L)-1 do
@@ -203,7 +203,7 @@ begin
           Case IO.StrToNullBoolean(Qry,True) of
             nbTrue : Result:=Result+Format('(%s IS NULL)',[RF.FieldName]);
             nbFalse : Result:=Result+Format('(%s IS NOT NULL)',[RF.FieldName]);
-            nbNone :  Raise ESQLDBRest.CreateFmt(400,SErrInvalidBooleanForField,[RF.PublicName])
+            nbNone :  Raise ESQLDBRest.CreateFmt(IO.RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidBooleanForField,[RF.PublicName])
           end;
         end;
   SetLength(FilteredFields,aLen);
@@ -252,11 +252,11 @@ begin
       While (J>=0) and Not SameText(L[J].PublicName,FN) do
         Dec(J);
       if J<0 then
-        Raise ESQLDBRest.CreateFmt(400,SErrInvalidSortField,[FN]);
+        Raise ESQLDBRest.CreateFmt(IO.RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidSortField,[FN]);
       F:=L[J];
       if Desc then
         if not (foOrderByDesc in F.Options) then
-          Raise ESQLDBRest.CreateFmt(400,SErrInvalidSortDescField,[FN]);
+          Raise ESQLDBRest.CreateFmt(IO.RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidSortDescField,[FN]);
       AddField(I-1,F,Desc)
       end;
     end;
@@ -447,7 +447,7 @@ begin
       begin
       P:=aQuery.Params.FindParam(FilterParamPrefix[FF.Operation]+F.FieldName);
       if not Assigned(P) then
-        Raise ESQLDBRest.CreateFmt(500,SErrFilterParamNotFound,[F.PublicName]);
+        Raise ESQLDBRest.CreateFmt(IO.RestStatuses.GetStatusCode(rsError),SErrFilterParamNotFound,[F.PublicName]);
       if Assigned(FF.ValueParam) then
         P.Value:=FF.ValueParam.Value
       else
@@ -481,7 +481,7 @@ begin
         if (D<>Nil) then
           SetParamFromData(P,F,D)
         else if (aOperation in [roDelete]) then
-          Raise ESQLDBRest.CreateFmt(400,SErrMissingParameter,[P.Name])
+          Raise ESQLDBRest.CreateFmt(IO.RestStatuses.GetStatusCode(rsInvalidParam),SErrMissingParameter,[P.Name])
         else
           P.Clear;
       finally
@@ -508,7 +508,7 @@ begin
   if aLimit=0 then
     exit;
   if Not (IO.Connection is TSQLConnector) then
-    Raise ESQLDBRest.Create(500,SErrLimitNotSupported);
+    Raise ESQLDBRest.Create(IO.RestStatuses.GetStatusCode(rsError),SErrLimitNotSupported);
   CT:=lowerCase(TSQLConnector(IO.Connection).ConnectorType);
   if Copy(CT,1,5)='mysql' then
     CT:='mysql';
@@ -532,7 +532,7 @@ Var
   i : Integer;
 
 begin
-  Result:=IO.Resource.AllowRecord(D);
+  Result:=IO.Resource.AllowRecord(IO.RestContext,D);
   if not Result then
     exit;
   O.StartRow;
@@ -598,7 +598,7 @@ begin
   if (Result=Nil) then
     begin
     GetLimitOffset(aLimit,aOffset);
-    Result:=FResource.GetDataset(aFieldList,GetOrderByFieldArray,aLimit,aOffset);
+    Result:=FResource.GetDataset(IO.RestContext,aFieldList,GetOrderByFieldArray,aLimit,aOffset);
     end;
 end;
 
@@ -656,7 +656,7 @@ end;
 procedure TSQLDBRestDBHandler.DoNotFound;
 
 begin
-  IO.Response.Code:=404;
+  IO.Response.Code:=IO.RestStatuses.GetStatusCode(rsRecordNotFound);
   IO.Response.CodeText:='NOT FOUND';  // Do not localize
   IO.CreateErrorResponse;
 end;
@@ -731,7 +731,7 @@ begin
       D.Free;
     end;
   // Give user a chance to look at it.
-  FResource.CheckParams(roPost,aParams);
+  FResource.CheckParams(io.RestContext,roPost,aParams);
   // Save so it can be used in GetWHereID for return
   FPostParams:=TParams.Create(TParam);
   FPostParams.Assign(aParams);
@@ -768,7 +768,7 @@ Var
 begin
   // We do this first, so we don't run any unnecessary queries
   if not IO.RESTInput.SelectObject(0) then
-    raise ESQLDBRest.Create(400, SErrNoResourceDataFound);
+    raise ESQLDBRest.Create(IO.RestStatuses.GetStatusCode(rsInvalidParam), SErrNoResourceDataFound);
   InsertNewRecord;
   // Now build response
   FieldList:=BuildFieldList(False);
@@ -797,7 +797,7 @@ begin
     S.SQL.Text:=SQL;
     SetPostParams(S.Params,OldData.Fields);
     // Give user a chance to look at it.
-    FResource.CheckParams(roPut,S.Params);
+    FResource.CheckParams(io.RestContext,roPut,S.Params);
     S.Execute;
     S.Transaction.Commit;
   finally
@@ -814,7 +814,7 @@ Var
 begin
   // We do this first, so we don't run any unnecessary queries
   if not IO.RESTInput.SelectObject(0) then
-    Raise ESQLDBRest.Create(400,SErrNoResourceDataFound);
+    Raise ESQLDBRest.Create(IO.RestStatuses.GetStatusCode(rsInvalidParam),SErrNoResourceDataFound);
   // Get the original record.
   FieldList:=BuildFieldList(True);
   D:=GetDatasetForResource(FieldList,True);

packages/fcl-web/src/restbridge/sqldbrestini.pp

@@ -530,7 +530,7 @@ begin
     begin
     if (scoClearOnRead in aOptions) then
        ClearValues;
-    ConnectionType:=ReadString(ASection,KeyType,'');
+    ConnectionType:=ReadString(ASection,KeyType,ConnectionType);
     HostName:=ReadString(ASection,KeyHost,HostName);
     DatabaseName:=ReadString(ASection,KeyDatabaseName,DatabaseName);
     UserName:=ReadString(ASection,KeyUserName,UserName);

packages/fcl-web/src/restbridge/sqldbrestio.pp

@@ -21,10 +21,8 @@ interface
 uses
   Classes, SysUtils, fpjson, sqldb, db, httpdefs, sqldbrestschema;
 
-Type
-  TVariableSource = (vsNone,vsQuery,vsContent,vsRoute,vsHeader);
-  TVariableSources = Set of TVariableSource;
 
+Type
   TRestOutputOption = (ooMetadata,ooSparse,ooHumanReadable);
   TRestOutputOptions = Set of TRestOutputOption;
 
@@ -37,6 +35,8 @@ Const
 
 
 Type
+  TRestIO = Class;
+
   TRestStringProperty = (rpDateFormat,
                          rpDateTimeFormat,
                          rpTimeFormat,
@@ -85,6 +85,7 @@ Type
   private
     FValues : Array[TRestStringProperty] of UTF8String;
     function GetRestPropName(AIndex: Integer): UTF8String;
+    function IsRestStringStored(AIndex: Integer): Boolean;
     procedure SetRestPropName(AIndex: Integer; AValue: UTF8String);
   Public
     Class Function GetDefaultString(aString : TRestStringProperty) :UTF8String;
@@ -93,43 +94,112 @@ Type
     Procedure Assign(aSource : TPersistent); override;
   Published
     // Indexes here MUST match TRestProperty
-    Property RESTDateFormat : UTF8String Index ord(rpDateFormat) Read GetRestPropName Write SetRestPropName;
-    Property RESTDateTimeFormat : UTF8String Index ord(rpDateTimeFormat)  Read GetRestPropName Write SetRestPropName;
-    Property RESTTimeFormat : UTF8String Index ord(rpTimeFormat)  Read GetRestPropName Write SetRestPropName;
-    Property DataProperty : UTF8String Index ord(rpDataRoot) Read GetRestPropName Write SetRestPropName;
-    Property MetaDataRoot : UTF8String Index ord(rpMetaDataRoot) Read GetRestPropName Write SetRestPropName;
-    Property ErrorProperty : UTF8String Index ord(rpErrorRoot) Read GetRestPropName Write SetRestPropName;
-    Property FieldNameProperty : UTF8String Index ord(rpFieldNameProp) Read GetRestPropName Write SetRestPropName;
-    Property FieldTypeProperty : UTF8String Index ord(rpFieldTypeProp) Read GetRestPropName Write SetRestPropName;
-    Property DateFormatProperty : UTF8String Index ord(rpFieldDateFormatProp) Read GetRestPropName Write SetRestPropName;
-    Property MaxLenProperty : UTF8String Index ord(rpFieldMaxLenProp) Read GetRestPropName Write SetRestPropName;
-    Property HumanReadableParam : UTF8String Index ord(rpHumanReadable) Read GetRestPropName Write SetRestPropName;
-    Property FieldListParam : UTF8String Index ord(rpFieldList) Read GetRestPropName Write SetRestPropName;
-    Property ExcludeFieldListParam : UTF8String Index ord(rpExcludeFieldList) Read GetRestPropName Write SetRestPropName;
-    Property ConnectionParam : UTF8String Index Ord(rpConnection) Read GetRestPropName Write SetRestPropName;
-    Property ResourceParam : UTF8String Index ord(rpResource) Read GetRestPropName Write SetRestPropName;
-    Property IncludeMetadataParam : UTF8String Index ord(rpIncludeMetadata) Read GetRestPropName Write SetRestPropName;
-    Property SparseParam : UTF8String Index Ord(rpSparse) Read GetRestPropName Write SetRestPropName;
-    Property RowName : UTF8String Index Ord(rpRowName) Read GetRestPropName Write SetRestPropName;
-    Property MetadataFields : UTF8String Index Ord(rpMetadataFields) Read GetRestPropName Write SetRestPropName;
-    Property MetadataField : UTF8String Index Ord(rpMetadataField) Read GetRestPropName Write SetRestPropName;
-    Property ErrorCode : UTF8String Index ord(rpErrorCode) Read GetRestPropName Write SetRestPropName;
-    Property ErrorMessage : UTF8String Index ord(rpErrorMessage) Read GetRestPropName Write SetRestPropName;
-    Property FilterParamEqual : UTF8String Index ord(rpFilterEqual) Read GetRestPropName Write SetRestPropName;
-    Property FilterParamLessThan : UTF8String Index ord(rpFilterLessThan) Read GetRestPropName Write SetRestPropName;
-    Property FilterParamGreaterThan : UTF8String Index ord(rpFilterGreaterThan) Read GetRestPropName Write SetRestPropName;
-    Property FilterParamLessThanEqual : UTF8String Index ord(rpFilterLessThanEqual) Read GetRestPropName Write SetRestPropName;
-    Property FilterParamGreaterThanEqual : UTF8String Index ord(rpFilterGreaterThanEqual) Read GetRestPropName Write SetRestPropName;
-    Property FilterParamIsNull : UTF8String Index ord(rpFilterIsNull) Read GetRestPropName Write SetRestPropName;
-    Property LimitParam : UTF8string Index ord(rpLimit) Read GetRestPropName Write SetRestPropName;
-    Property OffsetParam : UTF8string Index ord(rpOffset) Read GetRestPropName Write SetRestPropName;
-    Property SortParam : UTF8string Index ord(rpOrderBy) Read GetRestPropName Write SetRestPropName;
-    Property MetadataResourceName : UTF8string Index ord(rpMetadataResourceName) Read GetRestPropName Write SetRestPropName;
-    Property InputFormatParam : UTF8string Index ord(rpInputFormat) Read GetRestPropName Write SetRestPropName;
-    Property OutputFormatParam : UTF8string Index ord(rpOutputFormat) Read GetRestPropName Write SetRestPropName;
-    Property CustomViewResourceName : UTF8string Index ord(rpCustomViewResourceName) Read GetRestPropName Write SetRestPropName;
-    Property CustomViewSQLParam : UTF8string Index ord(rpCustomViewSQLParam) Read GetRestPropName Write SetRestPropName;
-    Property XMLDocumentRoot : UTF8string Index ord(rpXMLDocumentRoot) Read GetRestPropName Write SetRestPropName;
+    Property RESTDateFormat : UTF8String Index ord(rpDateFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property RESTDateTimeFormat : UTF8String Index ord(rpDateTimeFormat)  Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property RESTTimeFormat : UTF8String Index ord(rpTimeFormat)  Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property DataProperty : UTF8String Index ord(rpDataRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property MetaDataRoot : UTF8String Index ord(rpMetaDataRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property ErrorProperty : UTF8String Index ord(rpErrorRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FieldNameProperty : UTF8String Index ord(rpFieldNameProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FieldTypeProperty : UTF8String Index ord(rpFieldTypeProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property DateFormatProperty : UTF8String Index ord(rpFieldDateFormatProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property MaxLenProperty : UTF8String Index ord(rpFieldMaxLenProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property HumanReadableParam : UTF8String Index ord(rpHumanReadable) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FieldListParam : UTF8String Index ord(rpFieldList) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property ExcludeFieldListParam : UTF8String Index ord(rpExcludeFieldList) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property ConnectionParam : UTF8String Index Ord(rpConnection) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property ResourceParam : UTF8String Index ord(rpResource) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property IncludeMetadataParam : UTF8String Index ord(rpIncludeMetadata) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property SparseParam : UTF8String Index Ord(rpSparse) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property RowName : UTF8String Index Ord(rpRowName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property MetadataFields : UTF8String Index Ord(rpMetadataFields) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property MetadataField : UTF8String Index Ord(rpMetadataField) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property ErrorCode : UTF8String Index ord(rpErrorCode) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property ErrorMessage : UTF8String Index ord(rpErrorMessage) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FilterParamEqual : UTF8String Index ord(rpFilterEqual) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FilterParamLessThan : UTF8String Index ord(rpFilterLessThan) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FilterParamGreaterThan : UTF8String Index ord(rpFilterGreaterThan) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FilterParamLessThanEqual : UTF8String Index ord(rpFilterLessThanEqual) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FilterParamGreaterThanEqual : UTF8String Index ord(rpFilterGreaterThanEqual) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property FilterParamIsNull : UTF8String Index ord(rpFilterIsNull) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property LimitParam : UTF8string Index ord(rpLimit) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property OffsetParam : UTF8string Index ord(rpOffset) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property SortParam : UTF8string Index ord(rpOrderBy) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property MetadataResourceName : UTF8string Index ord(rpMetadataResourceName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property InputFormatParam : UTF8string Index ord(rpInputFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property OutputFormatParam : UTF8string Index ord(rpOutputFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property CustomViewResourceName : UTF8string Index ord(rpCustomViewResourceName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property CustomViewSQLParam : UTF8string Index ord(rpCustomViewSQLParam) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+    Property XMLDocumentRoot : UTF8string Index ord(rpXMLDocumentRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
+  end;
+
+  TRestStatus = (rsError,                   // Internal logic/unexpected error (500)
+                 rsGetOK,                   // GET command completed OK (200)
+                 rsPostOK,                  // POST command completed OK (204)
+                 rsPutOK,                   // PUT command completed OK (200)
+                 rsDeleteOK,                // DELETE command completed OK (204)
+                 rsInvalidParam,            // Something wrong/missing in Query parameters (400)
+                 rsCORSOK,                  // CORS request completed OK (200)
+                 rsCORSNotAllowed,          // CORS request not allowed (403)
+                 rsUnauthorized,            // Authentication failed (401)
+                 rsResourceNotAllowed,      // Resource request not allowed (403)
+                 rsRestOperationNotAllowed, // Resource operation (method) not allowed (405)
+                 rsInvalidMethod,           // Invalid HTTP method (400)
+                 rsUnknownResource,         // Unknown resource (404)
+                 rsNoResourceSpecified,     // Unable to determine resource (404)
+                 rsNoConnectionSpecified,   // Unable to determine connection for (400)
+                 rsRecordNotFound,          // Query did not return record for single resource (404)
+                 rsInvalidContent           // Invalid content for POST/PUT operation (400)
+
+                 );
+  TRestStatuses = set of TRestStatus;
+
+  { TRestStatusConfig }
+
+  TRestStatusConfig = Class(TPersistent)
+  private
+    FStatus : Array[TRestStatus] of Word;
+    function GetStatus(AIndex: Integer): Word;
+    function IsStatusStored(AIndex: Integer): Boolean;
+    procedure SetStatus(AIndex: Integer; AValue: Word);
+  Public
+    Procedure Assign(aSource : TPersistent); override;
+    function GetStatusCode(aStatus : TRestStatus): Word;
+  Published
+    // Internal logic/unexpected error (500)
+    Property Error : Word Index Ord(rsError) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // GET command completed OK (200)
+    Property GetOK : Word Index Ord(rsGetOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // POST command completed OK (204)
+    Property PostOK : Word Index Ord(rsPostOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // PUT command completed OK (200)
+    Property PutOK : Word Index Ord(rsPutOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // DELETE command completed OK (204)
+    Property DeleteOK : Word Index Ord(rsDeleteOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Something wrong/missing in Query parameters (400)
+    Property InvalidParam : Word Index Ord(rsInvalidParam) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // CORS request completed OK (200)
+    Property CORSOK : Word Index Ord(rsCORSOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // CORS request not allowed (403)
+    Property CORSNotAllowed : Word Index Ord(rsCORSNotAllowed) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Authentication failed (401)
+    Property Unauthorized : Word Index Ord(rsUnauthorized) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Resource request not allowed (403)
+    Property ResourceNotAllowed : Word Index Ord(rsResourceNotAllowed) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Resource operation (method) not allowed (405)
+    Property RestOperationNotAllowed : Word Index Ord(rsRestOperationNotAllowed) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Invalid HTTP method (400)
+    Property InvalidMethod : Word Index Ord(rsInvalidMethod) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Unknown resource (404)
+    Property UnknownResource : Word Index Ord(rsUnknownResource) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Unable to determine resource (404)
+    Property NoResourceSpecified : Word Index Ord(rsNoResourceSpecified) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Unable to determine connection for (400)
+    Property NoConnectionSpecified : Word Index Ord(rsNoConnectionSpecified) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Query did not return record for single resource (404)
+    Property RecordNotFound : Word Index Ord(rsRecordNotFound) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Invalid content for POST/PUT operation (400)
+    Property InvalidContent : Word Index Ord(rsInvalidContent) Read GetStatus Write SetStatus Stored IsStatusStored;
   end;
 
   { TRestStreamer }
@@ -139,12 +209,14 @@ Type
     FStream: TStream;
     FOnGetVar : TRestGetVariableEvent;
     FStrings: TRestStringsConfig;
+    FStatuses : TRestStatusConfig;
   Public
     // Registry
     Class Function GetContentType : String; virtual;
-    Constructor Create(aStream : TStream;aStrings : TRestStringsConfig;aOnGetVar : TRestGetVariableEvent);
+    Constructor Create(aStream : TStream;aStrings : TRestStringsConfig;aStatus : TRestStatusConfig; aOnGetVar : TRestGetVariableEvent);
     Function GetString(aString : TRestStringProperty) : UTF8String;
     Property Strings : TRestStringsConfig Read FStrings;
+    Property Statuses : TRestStatusConfig Read FStatuses;
     procedure InitStreaming; virtual; abstract;
     Function GetVariable(const aName : UTF8String) : UTF8String;
     Property Stream : TStream Read FStream;
@@ -191,6 +263,17 @@ Type
   end;
   TRestOutputStreamerClass = class of TRestOutputStreamer;
 
+  { TRestContext }
+
+  TRestContext = Class(TBaseRestContext)
+  Private
+    FIO : TRestIO;
+  Protected
+    property IO : TRestIO Read FIO;
+  Public
+    Function GetVariable(Const aName : UTF8String; aSources : TVariableSources; Out aValue : UTF8String) : Boolean; override;
+  end;
+
   { TRestIO }
 
   TRestIO = Class
@@ -204,11 +287,14 @@ Type
     FResource: TSQLDBRestResource;
     FResourceName: UTF8String;
     FResponse: TResponse;
+    FRestContext: TRestContext;
+    FRestStatuses: TRestStatusConfig;
     FRestStrings: TRestStringsConfig;
     FSchema: UTF8String;
     FTrans: TSQLTransaction;
     FContentStream : TStream;
-    FUserID: String;
+    function GetUserID: String;
+    procedure SetUserID(AValue: String);
   Protected
   Public
     Constructor Create(aRequest : TRequest; aResponse : TResponse); virtual;
@@ -219,6 +305,7 @@ Type
     Procedure SetResource(aResource : TSQLDBRestResource);
     procedure SetOperation(aOperation : TRestOperation);
     Procedure SetRestStrings(aValue : TRestStringsConfig);
+    Procedure SetRestStatuses(aValue : TRestStatusConfig);
     // Get things
     class function StrToNullBoolean(S: String; Strict: Boolean): TNullBoolean;
     Procedure DoGetVariable(Sender : TObject; Const aName : UTF8String; Out aVal : UTF8String);
@@ -228,6 +315,7 @@ Type
     function GetRequestOutputOptions(aDefault: TRestOutputOptions): TRestOutputOptions;
     function GetLimitOffset(aEnforceLimit: Int64; out aLimit, aOffset: Int64): boolean;
     // Create error response in output
+    function CreateRestContext: TRestContext; virtual;
     Procedure CreateErrorResponse;
     Property Operation : TRestOperation Read FOperation;
     // Not owned by TRestIO
@@ -237,15 +325,17 @@ Type
     Property Transaction : TSQLTransaction Read FTrans Write FTrans;
     Property Resource : TSQLDBRestResource Read FResource;
     Property RestStrings : TRestStringsConfig Read FRestStrings;
+    Property RestStatuses : TRestStatusConfig Read FRestStatuses;
     // owned by TRestIO
     Property RESTInput : TRestInputStreamer read FInput;
     Property RESTOutput : TRestOutputStreamer read FOutput;
     Property RequestContentStream : TStream Read FContentStream;
+    Property RestContext : TRestContext Read FRestContext;
     // For informative purposes
     Property ResourceName : UTF8String Read FResourceName;
     Property Schema : UTF8String Read FSchema;
     Property ConnectionName : UTF8String Read FCOnnection;
-    Property UserID : String Read FUserID Write FUserID;
+    Property UserID : String Read GetUserID Write SetUserID;
   end;
   TRestIOClass = Class of TRestIO;
 
@@ -342,6 +432,80 @@ Const
     'sql',             { rpCustomViewSQLParam }
     'datapacket'       { rpXMLDocumentRoot}
   );
+  DefaultStatuses : Array[TRestStatus] of Word = (
+    500, { rsError }
+    200, { rsGetOK }
+    201, { rsPostOK }
+    200, { rsPutOK }
+    204, { rsDeleteOK }
+    400, { rsInvalidParam }
+    200, { rsCORSOK}
+    403, { rsCORSNotallowed}
+    401, { rsUnauthorized }
+    403, { rsResourceNotAllowed }
+    405, { rsRestOperationNotAllowed }
+    400, { rsInvalidMethod }
+    404, { rsUnknownResource }
+    404, { rsNoResourceSpecified }
+    400, { rsNoConnectionSpecified }
+    404, { rsRecordNotFound }
+    400  { rsInvalidContent }
+  );
+
+{ TRestStatusConfig }
+
+function TRestStatusConfig.GetStatus(AIndex: Integer): Word;
+begin
+  Result:=GetStatusCode(TRestStatus(aIndex));
+end;
+
+function TRestStatusConfig.IsStatusStored(AIndex: Integer): Boolean;
+
+Var
+  W : Word;
+
+begin
+  W:=FStatus[TRestStatus(aIndex)];
+  Result:=(W<>0) and (W<>DefaultStatuses[TRestStatus(aIndex)]);
+end;
+
+procedure TRestStatusConfig.SetStatus(AIndex: Integer; AValue: Word);
+begin
+  if (aValue<>DefaultStatuses[TRestStatus(aIndex)]) then
+    aValue:=0;
+  FStatus[TRestStatus(aIndex)]:=aValue;
+end;
+
+procedure TRestStatusConfig.Assign(aSource: TPersistent);
+
+Var
+  C : TRestStatusConfig;
+  S : TRestStatus;
+
+begin
+  if aSource is TRestStatusConfig then
+    begin
+    C:=aSource as TRestStatusConfig;
+    for S in TRestStatus do
+      FStatus[S]:=C.FStatus[S];
+    end
+  else
+    inherited Assign(aSource);
+end;
+
+function TRestStatusConfig.GetStatusCode(aStatus: TRestStatus): Word;
+begin
+  Result:=FStatus[aStatus];
+  if Result=0 then
+    Result:=DefaultStatuses[aStatus];
+end;
+
+{ TRestContext }
+
+function TRestContext.GetVariable(const aName: UTF8String; aSources : TVariableSources; out aValue: UTF8String): Boolean;
+begin
+  Result:=FIO.GetVariable(aName,aValue,aSources)<>vsNone;
+end;
 
 { TStreamerDefList }
 
@@ -491,6 +655,16 @@ begin
     Result:=DefaultPropertyNames[TRestStringProperty(AIndex)]
 end;
 
+function TRestStringsConfig.IsRestStringStored(AIndex: Integer): Boolean;
+
+Var
+  V : UTF8String;
+
+begin
+  V:=FValues[TRestStringProperty(AIndex)];
+  Result:=(V<>'') and (V<>DefaultPropertyNames[TRestStringProperty(AIndex)]);
+end;
+
 procedure TRestStringsConfig.SetRestPropName(AIndex: Integer; AValue: UTF8String);
 begin
   FValues[TRestStringProperty(AIndex)]:=aValue;
@@ -534,6 +708,8 @@ procedure TRestOutputStreamer.SetOutputOptions(AValue: TRestOutputOptions);
 begin
   if FOutputOptions=AValue then Exit;
   FOutputOptions:=AValue;
+  if RequireMetadata then
+    Include(FOutputOptions,ooMetadata);
 end;
 
 procedure TRestOutputStreamer.CreateErrorContent(aCode: Integer;
@@ -549,7 +725,7 @@ begin
     On E : Exception do
       begin
       S:=Format('Error formatting string "%s" with %d arguments. Original code: %d',[Fmt,Length(Args),aCode]);
-      aCode:=500;
+      aCode:=Statuses.GetStatusCode(rsError);
       end;
   end;
   CreateErrorContent(aCode,S);
@@ -597,11 +773,12 @@ end;
 
 { TRestStreamer }
 
-constructor TRestStreamer.Create(aStream: TStream; aStrings: TRestStringsConfig; aOnGetVar: TRestGetVariableEvent);
+constructor TRestStreamer.Create(aStream: TStream; aStrings: TRestStringsConfig; aStatus : TRestStatusConfig; aOnGetVar: TRestGetVariableEvent);
 begin
   FStream:=aStream;
   FOnGetVar:=aOnGetVar;
   FStrings:=aStrings;
+  FStatuses:=aStatus;
 end;
 
 function TRestStreamer.GetString(aString: TRestStringProperty): UTF8String;
@@ -696,21 +873,40 @@ begin
   FRestStrings:=aValue;
 end;
 
+procedure TRestIO.SetRestStatuses(aValue: TRestStatusConfig);
+begin
+  FRestStatuses:=aValue;
+end;
+
 procedure TRestIO.DoGetVariable(Sender: TObject; const aName: UTF8String; out
   aVal: UTF8String);
 begin
   GetVariable(aName,aVal);
 end;
 
+procedure TRestIO.SetUserID(AValue: String);
+begin
+  if (UserID=AValue) then Exit;
+  FRestContext.UserID:=AValue;
+end;
+
+function TRestIO.GetUserID: String;
+begin
+  Result:=FRestContext.UserID;
+end;
+
 constructor TRestIO.Create(aRequest: TRequest; aResponse: TResponse);
 begin
   FRequest:=aRequest;
   FResponse:=aResponse;
   FContentStream:=TStringStream.Create(aRequest.Content);
+  FRestContext:=CreateRestContext;
+  FRestContext.FIO:=Self;
 end;
 
 destructor TRestIO.Destroy;
 begin
+  FreeAndNil(FRestContext);
   if Assigned(FInput) then
     Finput.FOnGetVar:=Nil;
   if Assigned(Foutput) then
@@ -721,6 +917,12 @@ begin
   inherited Destroy;
 end;
 
+function TRestIO.CreateRestContext : TRestContext;
+
+begin
+  Result:=TRestContext.Create;
+end;
+
 function TRestIO.GetVariable(const aName: UTF8String; out aVal: UTF8String;
   AllowedSources: TVAriableSources): TVariableSource;
 
@@ -769,7 +971,8 @@ begin
   Result:=GetVariable(aName+FRestStrings.GetRestString(FilterStrings[aFilter]),aValue,[vsQuery]);
 end;
 
-Class function TRestIO.StrToNullBoolean(S: String; Strict: Boolean): TNullBoolean;
+class function TRestIO.StrToNullBoolean(S: String; Strict: Boolean
+  ): TNullBoolean;
 
 begin
   result:=nbNone;
@@ -799,7 +1002,8 @@ begin
     Result:=StrToNullBoolean(S,aStrict);
 end;
 
-Function TRestIO.GetRequestOutputOptions(aDefault : TRestOutputOptions) : TRestOutputOptions;
+function TRestIO.GetRequestOutputOptions(aDefault: TRestOutputOptions
+  ): TRestOutputOptions;
 
   Procedure CheckParam(aName : String; aOption: TRestOutputOption);
   begin
@@ -831,11 +1035,11 @@ begin
   if Not Result then
     Exit;
   if (S<>'') and not TryStrToInt64(S,aLimit) then
-    Raise ESQLDBRest.CreateFmt(400,SErrInvalidParam,[P]);
+    Raise ESQLDBRest.CreateFmt(RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidParam,[P]);
   P:=RestStrings.GetRestString(rpOffset);
   if GetVariable(P,S,[vsQuery])<>vsNone then
     if (S<>'') and not TryStrToInt64(S,aOffset) then
-      Raise ESQLDBRest.CreateFmt(400,SErrInvalidParam,[P]);
+      Raise ESQLDBRest.CreateFmt(RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidParam,[P]);
   if (aEnforceLimit>0) and (aLimit>aEnforceLimit) then
     aLimit:=aEnforceLimit;
 end;

packages/fcl-web/src/restbridge/sqldbrestjson.pp

@@ -87,7 +87,7 @@ begin
         end;
     end;
     if (FJSON=Nil)  then
-      Raise ESQLDBRest.CreateFmt(400,'Invalid JSON input: %s',[Msg]);
+      Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),'Invalid JSON input: %s',[Msg]);
     end;
 end;
 
@@ -150,7 +150,7 @@ end;
 procedure TJSONOutputStreamer.StartRow;
 begin
   if (FRow<>Nil) then
-    Raise ESQLDBRest.Create(500,SErrDoubleRowStart);
+    Raise ESQLDBRest.Create(Statuses.GetStatusCode(rsError),SErrDoubleRowStart);
   FRow:=TJSONObject.Create;
   FData.Add(FRow);
 end;
@@ -165,7 +165,7 @@ begin
   Result:=Nil;
   F:=aPair.DBField;;
   If (aPair.RestField.FieldType=rftUnknown) then
-    raise ESQLDBRest.CreateFmt(500,SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
+    raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
   If (F.IsNull) then
     Exit;
     Case aPair.RestField.FieldType of
@@ -190,7 +190,7 @@ Var
 begin
   N:=aPair.RestField.PublicName;
   if FRow=Nil then
-    Raise ESQLDBRest.CreateFmt(500,SErrFieldWithoutRow,[N]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]);
   D:=FieldToJSON(aPair);
   if (D=Nil) and ((not HasOption(ooSparse)) or (FRow is TJSONArray)) then
     D:=TJSONNull.Create;

packages/fcl-web/src/restbridge/sqldbrestmodule.pp

@@ -0,0 +1,78 @@
+unit sqldbrestmodule;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, httpdefs, fphttp, sqldbrestbridge;
+
+Type
+
+  { TSQLDBRestModule }
+
+  TSQLDBRestModule = Class (TSessionHTTPModule)
+  private
+    FDispatcher: TSQLDBRestDispatcher;
+    procedure SetDispatcher(AValue: TSQLDBRestDispatcher);
+  Protected
+    Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    Function FindDispatcher : TSQLDBRestDispatcher; virtual;
+  Public
+    constructor Create(AOwner: TComponent); override;
+    Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
+  Published
+    Property Dispatcher : TSQLDBRestDispatcher Read FDispatcher Write SetDispatcher;
+    Property Kind;
+  end;
+
+implementation
+
+uses sqldbrestconst;
+
+{ TSQLDBRestModule }
+
+procedure TSQLDBRestModule.SetDispatcher(AValue: TSQLDBRestDispatcher);
+begin
+  if FDispatcher=AValue then Exit;
+  if Assigned(Dispatcher) then
+    FDispatcher.RemoveFreeNotification(Self);
+  FDispatcher:=AValue;
+  if Assigned(Dispatcher) then
+    FDispatcher.FreeNotification(Self);
+end;
+
+procedure TSQLDBRestModule.Notification(AComponent: TComponent; Operation: TOperation);
+begin
+  inherited Notification(AComponent, Operation);
+  if Operation=opRemove then
+    if AComponent=FDispatcher then
+      FDispatcher:=Nil;
+end;
+
+function TSQLDBRestModule.FindDispatcher: TSQLDBRestDispatcher;
+begin
+  Result:=Dispatcher;
+end;
+
+constructor TSQLDBRestModule.Create(AOwner: TComponent);
+begin
+  Kind:=wkOneShot;
+  inherited Create(AOwner);
+end;
+
+procedure TSQLDBRestModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
+
+Var
+  Disp : TSQLDBRestDispatcher;
+
+begin
+  Disp:=FindDispatcher;
+  If assigned(Disp) then
+    Disp.HandleRequest(aRequest,aResponse)
+  else
+    Raise EHTTP.Create(SErrNoRESTDispatcher);
+end;
+
+end.
+

packages/fcl-web/src/restbridge/sqldbrestschema.pp

@@ -22,7 +22,6 @@ uses
   Classes, SysUtils, db, sqldb, fpjson;
 
 Type
-
   TRestFieldType = (rftUnknown,rftInteger,rftLargeInt,rftFloat,rftDate,rftTime,rftDateTime,rftString,rftBoolean,rftBlob);
   TRestFieldTypes = set of TRestFieldType;
 
@@ -41,6 +40,8 @@ Type
   TFieldListKind = (flSelect,flInsert,flInsertParams,flUpdate,flWhereKey,flFilter,flOrderby);
   TFieldListKinds = set of TFieldListKind;
 
+  TVariableSource = (vsNone,vsQuery,vsContent,vsRoute,vsHeader);
+  TVariableSources = Set of TVariableSource;
 
 Const
   AllRestOperations = [Succ(Low(TRestOperation))..High(TRestOperation)];
@@ -51,6 +52,22 @@ Const
 
 Type
 
+  { TBaseRestContext }
+
+  TBaseRestContext = Class(TObject)
+  private
+    FData: TObject;
+    FUserID: UTF8String;
+  Public
+    // Call this to get a HTTP Query variable, header,...
+    Function GetVariable(Const aName : UTF8String; aSources : TVariableSources; Out aValue : UTF8String) : Boolean; virtual; abstract;
+    // This will be set when calling.
+    Property UserID : UTF8String Read FUserID Write FUserID;
+    // You can attach data to this if you want to. It will be kept for the duration of the request.
+    // You are responsible for freeing this data, though.
+    Property Data : TObject Read FData Write FData;
+  end;
+
   { ESQLDBRest }
 
   ESQLDBRest = Class(Exception)
@@ -68,7 +85,8 @@ Type
   end;
 
   TSQLDBRestSchema = Class;
-
+  TSQLDBRestCustomBusinessProcessor = Class;
+  TSQLDBRestBusinessProcessor = Class;
 
   { TSQLDBRestField }
 
@@ -131,21 +149,26 @@ Type
   TSQLDBRestFieldListClass = Class of TSQLDBRestFieldList;
 
   { TSQLDBRestResource }
-  TSQLDBRestGetDatasetEvent = Procedure (aSender : TObject; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64; Var aDataset : TDataset) of object;
-  TSQLDBRestCheckParamsEvent = Procedure (aSender : TObject; aOperation : TRestOperation; Params : TParams) of object;
-  TSQLDBRestAllowRecordEvent = Procedure (aSender : TObject; aDataSet : TDataset; var allowRecord : Boolean) of object;
+  TSQLDBRestGetDatasetEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64; Var aDataset : TDataset) of object;
+  TSQLDBRestCheckParamsEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; aOperation : TRestOperation; Params : TParams) of object;
+  TSQLDBRestAllowRecordEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; aDataSet : TDataset; var allowRecord : Boolean) of object;
+  TSQLDBRestAllowResourceEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; var allowResource : Boolean) of object;
+  TSQLDBRestAllowedOperationsEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; var aOperations : TRestOperations) of object;
   TProcessIdentifier = Function (const S: UTF8String): UTF8String of object;
 
   TSQLDBRestResource = class(TCollectionItem)
   private
+    FBusinessProcessor: TSQLDBRestCustomBusinessProcessor;
     FAllowedOperations: TRestOperations;
     FConnectionName: UTF8String;
     FEnabled: Boolean;
     FFields: TSQLDBRestFieldList;
     FInMetadata: Boolean;
+    FOnAllowedOperations: TSQLDBRestAllowedOperationsEvent;
     FOnAllowRecord: TSQLDBRestAllowRecordEvent;
     FOnCheckParams: TSQLDBRestCheckParamsEvent;
     FOnGetDataset: TSQLDBRestGetDatasetEvent;
+    FOnResourceAllowed: TSQLDBRestAllowResourceEvent;
     FResourceName: UTF8String;
     FTableName: UTF8String;
     FSQL : Array[TSQLKind] of TStrings;
@@ -165,18 +188,21 @@ Type
   Public
     Constructor Create(ACollection: TCollection); override;
     Destructor Destroy; override;
-    Procedure CheckParams(aOperation : TRestoperation; P : TParams);
-    Function GetDataset(aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset;
+    Procedure CheckParams(aContext : TBaseRestContext; aOperation : TRestoperation; P : TParams);
+    Function GetDataset(aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset;
     Function GetSchema : TSQLDBRestSchema;
     function GenerateDefaultSQL(aKind: TSQLKind): UTF8String; virtual;
     Procedure Assign(Source: TPersistent); override;
-    Function AllowRecord(aDataset : TDataset) : Boolean;
+    Function AllowRecord(aContext : TBaseRestContext; aDataset : TDataset) : Boolean;
+    Function AllowResource(aContext : TBaseRestContext) : Boolean;
+    Function GetAllowedOperations(aContext : TBaseRestContext) : TRestOperations;
     Function GetHTTPAllow : String; virtual;
     function GetFieldList(aListKind: TFieldListKind): UTF8String;
     function GetFieldArray(aListKind: TFieldListKind): TSQLDBRestFieldArray;
     Function GetResolvedSQl(aKind : TSQLKind; Const AWhere : UTF8String; Const aOrderBy : UTF8String = ''; aLimit : UTF8String = '') : UTF8String;
     Procedure PopulateFieldsFromFieldDefs(Defs : TFieldDefs; aIndexFields : TStringArray; aProcessIdentifier : TProcessIdentifier; aMinFieldOpts : TRestFieldOptions);
     Property SQL [aKind : TSQLKind] : TStrings Read GetSQLTyped;
+    Property BusinessProcessor : TSQLDBRestCustomBusinessProcessor Read FBusinessProcessor;
   Published
     Property Fields : TSQLDBRestFieldList Read FFields Write SetFields;
     Property Enabled : Boolean Read FEnabled Write FEnabled default true;
@@ -189,6 +215,8 @@ Type
     Property SQLInsert : TStrings Index 1 Read GetSQL Write SetSQL;
     Property SQLUpdate : TStrings Index 2 Read GetSQL Write SetSQL;
     Property SQLDelete : TStrings Index 3 Read GetSQL Write SetSQL;
+    Property OnResourceAllowed : TSQLDBRestAllowResourceEvent Read FOnResourceAllowed Write FOnResourceAllowed;
+    Property OnAllowedOperations : TSQLDBRestAllowedOperationsEvent Read FOnAllowedOperations Write FOnAllowedOperations;
     Property OnGetDataset : TSQLDBRestGetDatasetEvent Read FOnGetDataset Write FOnGetDataset;
     Property OnCheckParams : TSQLDBRestCheckParamsEvent Read FOnCheckParams Write FOnCheckParams;
     Property OnAllowRecord : TSQLDBRestAllowRecordEvent Read FOnAllowRecord Write FOnAllowRecord;
@@ -222,14 +250,21 @@ Type
   private
     FConnectionName: UTF8String;
     FResources: TSQLDBRestResourceList;
+    FProcessors : TFPList;
     procedure SetResources(AValue: TSQLDBRestResourceList);
   Protected
     function CreateResourceList: TSQLDBRestResourceList; virtual;
     function GetPrimaryIndexFields(Q: TSQLQuery): TStringArray; virtual;
     function ProcessIdentifier(const S: UTF8String): UTF8String; virtual;
+    Function AttachProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor) : Boolean; Virtual;
+    Function DetachProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor) : Boolean; Virtual;
+    Procedure AttachAllProcessors; virtual;
+    Procedure DetachAllProcessors; virtual;
   Public
     Constructor Create(AOwner: TComponent); override;
     Destructor Destroy; override;
+    Procedure RemoveBusinessProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor);
+    Procedure AddBusinessProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor);
     Procedure SaveToFile(Const aFileName : UTF8String);
     Procedure SaveToStream(Const aStream : TStream);
     function AsJSON(const aPropName: UTF8String=''): TJSONData;
@@ -247,6 +282,54 @@ Type
   TCustomViewResource = Class(TSQLDBRestResource)
   end;
 
+  { TSQLDBRestCustomBusinessProcessor }
+
+  TSQLDBRestCustomBusinessProcessor = Class(TComponent)
+  private
+    FResource: TSQLDBRestResource;
+    FResourceName: UTF8String;
+    procedure SetResourceName(AValue: UTF8String);
+  Protected
+    Function GetSchema : TSQLDBRestSchema; virtual;
+    Function GetAllowedOperations(aContext : TBaseRestContext; aDefault : TRestOperations) : TRestOperations; virtual; abstract;
+    Function AllowResource(aContext : TBaseRestContext) : Boolean; virtual; abstract;
+    Procedure CheckParams(aContext : TBaseRestContext; aOperation : TRestoperation; P : TParams); virtual; abstract;
+    Function GetDataset(aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset; virtual;abstract;
+    Function AllowRecord(aContext : TBaseRestContext;aDataset : TDataset) : Boolean; virtual; abstract;
+  Public
+    Property Resource : TSQLDBRestResource Read FResource;
+    Property ResourceName : UTF8String Read FResourceName Write SetResourceName;
+  end;
+
+  { TSQLDBRestBusinessProcessor }
+  TOnGetHTTPAllow = Procedure(Sender : TObject; Var aHTTPAllow) of object;
+
+  TSQLDBRestBusinessProcessor = class(TSQLDBRestCustomBusinessProcessor)
+  private
+    FOnAllowedOperations: TSQLDBRestAllowedOperationsEvent;
+    FOnAllowRecord: TSQLDBRestAllowRecordEvent;
+    FOnCheckParams: TSQLDBRestCheckParamsEvent;
+    FOnGetDataset: TSQLDBRestGetDatasetEvent;
+    FOnResourceAllowed: TSQLDBRestAllowResourceEvent;
+    FSchema: TSQLDBRestSchema;
+    procedure SetSchema(AValue: TSQLDBRestSchema);
+  Protected
+    Function GetSchema : TSQLDBRestSchema; override;
+    Function AllowResource(aContext : TBaseRestContext) : Boolean; override;
+    Function GetAllowedOperations(aContext : TBaseRestContext; aDefault : TRestOperations) : TRestOperations; override;
+    Procedure CheckParams(aContext : TBaseRestContext; aOperation : TRestoperation; P : TParams); override;
+    Function GetDataset(aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset; override;
+    Function AllowRecord(aContext : TBaseRestContext; aDataset : TDataset) : Boolean; override;
+  Published
+    Property Schema : TSQLDBRestSchema Read GetSchema Write SetSchema;
+    Property ResourceName;
+    Property OnGetDataset : TSQLDBRestGetDatasetEvent Read FOnGetDataset Write FOnGetDataset;
+    Property OnCheckParams : TSQLDBRestCheckParamsEvent Read FOnCheckParams Write FOnCheckParams;
+    Property OnAllowResource : TSQLDBRestAllowResourceEvent Read FOnResourceAllowed Write FOnResourceAllowed;
+    Property OnAllowedOperations : TSQLDBRestAllowedOperationsEvent Read FOnAllowedOperations Write FOnAllowedOperations;
+    Property OnAllowRecord : TSQLDBRestAllowRecordEvent Read FOnAllowRecord Write FOnAllowRecord;
+  end;
+
 Const
   TypeNames : Array[TRestFieldType] of string = ('?','int','bigint','float','date','time','datetime','string','bool','blob');
 
@@ -254,6 +337,95 @@ implementation
 
 uses strutils, fpjsonrtti,dbconst, sqldbrestconst;
 
+{ TSQLDBRestCustomBusinessProcessor }
+
+procedure TSQLDBRestCustomBusinessProcessor.SetResourceName(AValue: UTF8String);
+
+Var
+  S : TSQLDBRestSchema;
+
+begin
+  if FResourceName=AValue then Exit;
+  // Reregister, so the attachment happens to the correct resource
+  S:=GetSchema;
+  If (FResourceName<>'') and Assigned(S) then
+    S.RemoveBusinessProcessor(Self);
+  FResourceName:=AValue;
+  S:=GetSchema;
+  If (FResourceName<>'') and Assigned(S) then
+    S.AddBusinessProcessor(Self);
+end;
+
+function TSQLDBRestCustomBusinessProcessor.GetSchema: TSQLDBRestSchema;
+
+begin
+  Result:=Nil;
+end;
+
+{ TSQLDBRestBusinessProcessor }
+
+procedure TSQLDBRestBusinessProcessor.SetSchema(AValue: TSQLDBRestSchema);
+begin
+  if FSchema=AValue then Exit;
+  if Assigned(FSchema) and (ResourceName<>'') then
+    begin
+    FSchema.RemoveBusinessProcessor(Self);
+    FSchema.RemoveFreeNotification(Self);
+    end;
+  FSchema:=AValue;
+  if Assigned(FSchema) and (ResourceName<>'') then
+    begin
+    FSchema.AddBusinessProcessor(Self);
+    FSchema.FreeNotification(Self);
+    end
+end;
+
+function TSQLDBRestBusinessProcessor.GetSchema: TSQLDBRestSchema;
+begin
+  Result:=FSchema;
+end;
+
+function TSQLDBRestBusinessProcessor.AllowResource(aContext: TBaseRestContext
+  ): Boolean;
+begin
+  Result:=True;
+  if Assigned(FOnResourceAllowed) then
+    FOnResourceAllowed(Self,aContext,Result);
+
+end;
+
+function TSQLDBRestBusinessProcessor.GetAllowedOperations(
+  aContext: TBaseRestContext; aDefault: TRestOperations): TRestOperations;
+begin
+  Result:=aDefault;
+  if Assigned(FOnAllowedOperations) then
+    FOnAllowedOperations(Self,aContext,Result);
+end;
+
+procedure TSQLDBRestBusinessProcessor.CheckParams(aContext: TBaseRestContext;
+  aOperation: TRestoperation; P: TParams);
+begin
+  if Assigned(FOnCheckParams) then
+    FOnCheckParams(Self,aContext,aOperation,P);
+end;
+
+function TSQLDBRestBusinessProcessor.GetDataset(aContext : TBaseRestContext;
+  aFieldList: TRestFieldPairArray; aOrderBy: TRestFieldOrderPairArray; aLimit,
+  aOffset: Int64): TDataset;
+begin
+  Result:=nil;
+  if Assigned(FOnGetDataset) then
+    FOnGetDataset(Self,aContext,aFieldList,aOrderBy,aLimit,aOffset,Result);
+end;
+
+function TSQLDBRestBusinessProcessor.AllowRecord(aContext : TBaseRestContext; aDataset: TDataset): Boolean;
+begin
+  Result:=True;
+  if Assigned(FOnAllowRecord) then
+    FOnAllowRecord(Self,acontext,aDataset,Result);
+end;
+
+
 
 { ESQLDBRest }
 
@@ -285,9 +457,10 @@ constructor TSQLDBRestSchema.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FResources:=CreateResourceList;
+  FProcessors:=TFPList.Create;
 end;
 
-Function TSQLDBRestSchema.CreateResourceList :  TSQLDBRestResourceList;
+function TSQLDBRestSchema.CreateResourceList: TSQLDBRestResourceList;
 
 begin
   Result:=TSQLDBRestResourceList.Create(Self,TSQLDBRestResource);
@@ -295,10 +468,26 @@ end;
 
 destructor TSQLDBRestSchema.Destroy;
 begin
+  FreeAndNil(FProcessors);
   FreeAndNil(FResources);
   inherited Destroy;
 end;
 
+procedure TSQLDBRestSchema.RemoveBusinessProcessor(
+  aProcessor: TSQLDBRestCustomBusinessProcessor);
+
+begin
+  DetachProcessor(aProcessor);
+  FProcessors.Remove(aProcessor);
+end;
+
+procedure TSQLDBRestSchema.AddBusinessProcessor(
+  aProcessor: TSQLDBRestCustomBusinessProcessor);
+begin
+  FProcessors.Remove(aProcessor);
+  AttachProcessor(aProcessor);
+end;
+
 procedure TSQLDBRestSchema.SaveToFile(const aFileName: UTF8String);
 Var
   F : TFileStream;
@@ -371,16 +560,69 @@ begin
   J:=aData as TJSONObject;
   Resources.FromJSON(J,JSONResourcesRoot);
   ConnectionName:=J.Get(aPropName,'');
+  AttachAllProcessors;
 end;
 
-Function TSQLDBRestSchema.ProcessIdentifier(Const S : UTF8String) : UTF8String;
+function TSQLDBRestSchema.ProcessIdentifier(const S: UTF8String): UTF8String;
 
 begin
   Result:=S;
 end;
 
+function TSQLDBRestSchema.AttachProcessor(aProcessor: TSQLDBRestCustomBusinessProcessor): Boolean;
 
-Function TSQLDBRestSchema.GetPrimaryIndexFields(Q : TSQLQuery) : TStringArray;
+Var
+  Res : TSQLDBRestResource;
+
+begin
+  if aProcessor.ResourceName='' then
+    exit;
+  Res:=FResources.FindResourceByName(aProcessor.ResourceName);
+  Result:=Assigned(Res);
+  if Result then
+    begin
+    Res.FBusinessProcessor:=aProcessor;
+    aProcessor.FResource:=Res;
+    end;
+end;
+
+function TSQLDBRestSchema.DetachProcessor(aProcessor: TSQLDBRestCustomBusinessProcessor): Boolean;
+Var
+  Res : TSQLDBRestResource;
+
+begin
+  if aProcessor.ResourceName='' then
+    exit;
+  Res:=FResources.FindResourceByName(aProcessor.ResourceName);
+  Result:=Assigned(Res);
+  if Result then
+    begin
+    Res.FBusinessProcessor:=Nil;
+    aProcessor.FResource:=Nil;
+    end;
+end;
+
+procedure TSQLDBRestSchema.AttachAllProcessors;
+
+Var
+  I : integer;
+
+begin
+  For I:=0 to FProcessors.Count-1 do
+    AttachProcessor(TSQLDBRestCustomBusinessProcessor(FProcessors[i]));
+end;
+
+procedure TSQLDBRestSchema.DetachAllProcessors;
+Var
+  I : integer;
+
+begin
+  For I:=0 to FProcessors.Count-1 do
+    DetachProcessor(TSQLDBRestCustomBusinessProcessor(FProcessors[i]));
+end;
+
+
+function TSQLDBRestSchema.GetPrimaryIndexFields(Q: TSQLQuery): TStringArray;
 
 Var
   C,I : Integer;
@@ -434,7 +676,8 @@ begin
   end;
 end;
 
-procedure TSQLDBRestSchema.PopulateResources(aConn: TSQLConnection; aTables : Array of string; aMinFieldOpts : TRestFieldOptions = []);
+procedure TSQLDBRestSchema.PopulateResources(aConn: TSQLConnection;
+  aTables: array of string; aMinFieldOpts: TRestFieldOptions);
 
 Var
   L : TStringList;
@@ -676,6 +919,7 @@ begin
   Result:=FSQL[aKind];
 end;
 
+
 procedure TSQLDBRestResource.SetFields(AValue: TSQLDBRestFieldList);
 begin
   if FFields=AValue then Exit;
@@ -713,23 +957,29 @@ Var
   K : TSQLKind;
 
 begin
+  If Assigned(FBusinessProcessor) then
+    FBusinessProcessor.FResource:=Nil;
   FreeAndNil(FFields);
   for K in TSQLKind do
     FreeAndNil(FSQL[K]);
   inherited Destroy;
 end;
 
-procedure TSQLDBRestResource.CheckParams(aOperation: TRestoperation; P: TParams);
+procedure TSQLDBRestResource.CheckParams(aContext : TBaseRestContext; aOperation: TRestoperation; P: TParams);
 begin
   if Assigned(FOnCheckParams) then
-    FOnCheckParams(Self,aOperation,P);
+    FOnCheckParams(Self,aContext,aOperation,P)
+  else if Assigned(FBusinessProcessor) then
+    FBusinessProcessor.CheckParams(aContext,aOperation,P)
 end;
 
-function TSQLDBRestResource.GetDataset(aFieldList: TRestFieldPairArray; aOrderBy: TRestFieldOrderPairArray; aLimit, aOffset: Int64): TDataset;
+function TSQLDBRestResource.GetDataset(aContext : TBaseRestContext; aFieldList: TRestFieldPairArray; aOrderBy: TRestFieldOrderPairArray; aLimit, aOffset: Int64): TDataset;
 begin
   Result:=Nil;
   If Assigned(FOnGetDataset) then
-    FOnGetDataset(Self,aFieldList,aOrderBy,aLimit,aOffset,Result);
+    FOnGetDataset(Self,aContext,aFieldList,aOrderBy,aLimit,aOffset,Result)
+  else if Assigned(FBusinessProcessor) then
+    Result:=FBusinessProcessor.GetDataset(aContext,aFieldList,aOrderBy,aLimit,aOffset);
 end;
 
 function TSQLDBRestResource.GetSchema: TSQLDBRestSchema;
@@ -763,11 +1013,32 @@ begin
     inherited Assign(Source);
 end;
 
-function TSQLDBRestResource.AllowRecord(aDataset: TDataset): Boolean;
+function TSQLDBRestResource.AllowRecord(aContext : TBaseRestContext; aDataset: TDataset): Boolean;
 begin
   Result:=True;
   if Assigned(FOnAllowRecord) then
-    FOnAllowRecord(Self,aDataset,Result);
+    FOnAllowRecord(Self,aContext,aDataset,Result)
+  else if Assigned(FBusinessProcessor) then
+    Result:=FBusinessProcessor.AllowRecord(aContext,aDataset);
+end;
+
+function TSQLDBRestResource.AllowResource(aContext : TBaseRestContext): Boolean;
+begin
+  Result:=True;
+  If Assigned(FOnResourceAllowed) then
+    FOnResourceAllowed(Self,aContext,Result)
+  else If Assigned(FBusinessProcessor) then
+    Result:=FBusinessProcessor.AllowResource(aContext);
+end;
+
+function TSQLDBRestResource.GetAllowedOperations(aContext: TBaseRestContext
+  ): TRestOperations;
+begin
+  Result:=AllowedOperations;
+  if Assigned(FOnAllowedOperations) then
+    FOnAllowedOperations(Self,aContext,Result)
+  else if Assigned(FBusinessProcessor) then
+    Result:=FBusinessProcessor.GetAllowedOperations(aContext,Result);
 end;
 
 function TSQLDBRestResource.GetHTTPAllow: String;

packages/fcl-web/src/restbridge/sqldbrestxml.pp

@@ -158,13 +158,13 @@ begin
       end;
   end;
   if (FXML=Nil)  then
-    Raise ESQLDBRest.CreateFmt(400,SErrInvalidXMLInput,[Msg]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[Msg]);
   FPacket:=FXML.DocumentElement;
   NN:=UTF8Decode(GetString(rpXMLDocumentRoot));
   if (NN<>'') then
     begin
     if FPacket.NodeName<>NN then
-      Raise ESQLDBRest.CreateFmt(400,SErrInvalidXMLInput,[SErrMissingDocumentRoot]);
+      Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[SErrMissingDocumentRoot]);
     NN:=UTF8Decode(GetString(rpDataRoot));
     N:=FPacket.FindNode(NN);
     end
@@ -178,7 +178,7 @@ begin
       N:=Nil
     end;
   if Not (Assigned(N) and (N is TDOMelement)) then
-    Raise ESQLDBRest.CreateFmt(400,SErrInvalidXMLInputMissingElement,[NN]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInputMissingElement,[NN]);
   FData:=(N as TDOMelement);
 end;
 
@@ -198,7 +198,21 @@ end;
 procedure TXMLOutputStreamer.FinalizeOutput;
 
 begin
-  xmlwrite.WriteXML(FXML,Stream);
+{$IFNDEF VER3_0}
+  if Not (ooHumanReadable in OutputOptions) then
+    begin
+    With TDOMWriter.Create(Stream,FXML) do
+      try
+        LineBreak:='';
+        IndentSize:=0;
+        WriteNode(FXML);
+      finally
+        Free;
+      end;
+    end
+  else
+{$ENDIF}
+    xmlwrite.WriteXML(FXML,Stream);
   FreeAndNil(FXML);
 end;
 
@@ -211,7 +225,7 @@ end;
 procedure TXMLOutputStreamer.StartRow;
 begin
   if (FRow<>Nil) then
-    Raise ESQLDBRest.Create(500,SErrDoubleRowStart);
+    Raise ESQLDBRest.Create(Statuses.GetStatusCode(rsError),SErrDoubleRowStart);
   FRow:=FXML.CreateElement(UTF8Decode(GetString(rpRowName)));
   FData.AppendChild(FRow);
 end;
@@ -226,7 +240,7 @@ begin
   Result:=Nil;
   F:=aPair.DBField;;
   If (aPair.RestField.FieldType=rftUnknown) then
-    raise ESQLDBRest.CreateFmt(500,SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
+    raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
   If (F.IsNull) then
     Exit;
   S:=FieldToString(aPair.RestField.FieldType,F);
@@ -243,7 +257,7 @@ Var
 begin
   N:=aPair.RestField.PublicName;
   if FRow=Nil then
-    Raise ESQLDBRest.CreateFmt(500,SErrFieldWithoutRow,[N]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]);
   D:=FieldToXML(aPair);
   if (D=Nil) and (not HasOption(ooSparse)) then
     D:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName));

packages/pastojs/src/pas2jscompiler.pp

@@ -53,7 +53,7 @@ const
 const
   nOptionIsEnabled = 101; sOptionIsEnabled = 'Option "%s" is %s';
   nSyntaxModeIs = 102; sSyntaxModeIs = 'Syntax mode is %s';
-  nMacroDefined = 103; sMacroDefined = 'Macro defined: %s';
+  // was: nMacroDefined = 103
   // 104 in unit Pas2JSFS
   // 105 in unit Pas2JSFS
   nNameValue = 106; sNameValue = '%s: %s';
@@ -88,7 +88,7 @@ const
   nSrcMapBaseDirIs = 135; sSrcMapBaseDirIs = 'source map "local base directory" is %s';
   nUnitFileNotFound = 136; sUnitFileNotFound = 'unit file not found %s';
   nClassInterfaceStyleIs = 137; sClassInterfaceStyleIs = 'Class interface style is %s';
-  nMacroXSetToY = 138; sMacroXSetToY = 'Macro %s set to %s';
+  // was nMacroXSetToY = 138
   nPostProcessorInfoX = 139; sPostProcessorInfoX = 'Post processor: %s';
   nPostProcessorRunX = 140; sPostProcessorRunX = 'Run post processor: %s';
   nPostProcessorFailX = 141; sPostProcessorFailX = 'Post processor failed: %s';
@@ -129,6 +129,7 @@ type
     coUseStrict,
     coWriteDebugLog,
     coWriteMsgToStdErr,
+    coPrecompile, // create precompile file
     // optimizations
     coEnumValuesAsNumbers,
     coKeepNotUsedPrivates,
@@ -180,6 +181,7 @@ const
     'Use strict',
     'Write pas2jsdebug.log',
     'Write messages to StdErr',
+    'Create precompiled units',
     'Enum values as numbers',
     'Keep not used private declarations',
     'Keep not used declarations (WPO)',
@@ -387,6 +389,7 @@ type
     function ReadContinue: boolean; // true=finished
     function ReaderState: TPas2jsReaderState;
     procedure CreateJS;
+    procedure EmitModuleHints;
     function GetPasFirstSection: TPasSection;
     function GetPasImplSection: TPasSection;
     function GetPasMainUsesClause: TPasUsesClause;
@@ -459,36 +462,36 @@ type
   TPas2jsCompiler = class
   private
     FAllJSIntoMainJS: Boolean;
-    FConverterGlobals: TPasToJSConverterGlobals;
     FCompilerExe: string;
+    FConfigSupport: TPas2JSConfigSupport;
+    FConverterGlobals: TPasToJSConverterGlobals;
     FDefines: TStrings; // Objects can be TMacroDef
-    FFS: TPas2jsFS;
-    FOwnsFS: boolean;
     FFiles: TPasAnalyzerKeySet; // set of TPas2jsCompilerFile, key is UnitFilename
-    FReadingModules: TFPList; // list of TPas2jsCompilerFile ordered by uses sections
+    FFS: TPas2jsFS;
     FHasShownEncoding: boolean;
     FHasShownLogo: boolean;
+    FInsertFilenames: TStringList;
+    FInterfaceType: TPasClassInterfaceType;
     FLog: TPas2jsLogger;
     FMainFile: TPas2jsCompilerFile;
-    FMainJSFileResolved: String;
-    FMainJSFileIsResolved: Boolean;
     FMainJSFile: String;
+    FMainJSFileIsResolved: Boolean;
+    FMainJSFileResolved: String;
     FMainSrcFile: String;
     FMode: TP2jsMode;
+    FNamespaces: TStringList;
+    FNamespacesFromCmdLine: integer;
     FOptions: TP2jsCompilerOptions;
+    FOwnsFS: boolean;
     FParamMacros: TPas2jsMacroEngine;
+    FPostProcessorSupport: TPas2JSPostProcessorSupport;
+    FPrecompileGUID: TGUID;
+    FReadingModules: TFPList; // list of TPas2jsCompilerFile ordered by uses sections
+    FRTLVersionCheck: TP2jsRTLVersionCheck;
+    FSrcMapBaseDir: string;
     FSrcMapSourceRoot: string;
     FUnits: TPasAnalyzerKeySet; // set of TPas2jsCompilerFile, key is PasUnitName
     FWPOAnalyzer: TPas2JSAnalyzer;
-    FInterfaceType: TPasClassInterfaceType;
-    FPrecompileGUID: TGUID;
-    FInsertFilenames: TStringList;
-    FNamespaces: TStringList;
-    FNamespacesFromCmdLine: integer;
-    FConfigSupport: TPas2JSConfigSupport;
-    FSrcMapBaseDir: string;
-    FRTLVersionCheck: TP2jsRTLVersionCheck;
-    FPostProcessorSupport: TPas2JSPostProcessorSupport;
     procedure AddInsertJSFilename(const aFilename: string);
     Procedure AddNamespaces(const Paths: string; FromCmdLine: boolean);
     function GetDefaultNamespace: String;
@@ -1041,9 +1044,11 @@ begin
   Scanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
   Scanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
   Scanner.CurrentModeSwitches:=GetInitialModeSwitches;
-  Scanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
-  Scanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
+  Scanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
+  Scanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
   Scanner.CurrentBoolSwitches:=GetInitialBoolSwitches;
+  Scanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
+  Scanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
   Scanner.CurrentValueSwitch[vsInterfaces]:=InterfaceTypeNames[Compiler.InterfaceType];
   if coAllowCAssignments in Compiler.Options then
     Scanner.Options:=Scanner.Options+[po_cassignments];
@@ -1308,7 +1313,6 @@ begin
 end;
 
 function TPas2jsCompilerFile.IsUnitReadFromPCU: Boolean;
-
 begin
   Result:=Assigned(PCUSupport) and PCUSupport.HasReader;
 end;
@@ -1336,7 +1340,8 @@ begin
     {$IFDEF ReallyVerbose}
     writeln('TPas2jsCompilerFile.ReaderFinished analyzed ',UnitFilename,' ScopeModule=',GetObjName(UseAnalyzer.ScopeModule));
     {$ENDIF}
-    if Assigned(PCUSupport) and Not PCUSupport.HasReader then
+    if Assigned(PCUSupport) and Not PCUSupport.HasReader
+        and (coPrecompile in Compiler.Options) then
       PCUSupport.WritePCU;
   except
     on E: ECompilerTerminate do
@@ -1479,13 +1484,6 @@ procedure TPas2jsCompilerFile.CreateJS;
 begin
   //writeln('TPas2jsCompilerFile.CreateJS START ',UnitFilename,' JS=',GetObjName(FJSModule));
   try
-    // show hints only for units that are actually converted
-    if (PCUSupport=nil) or not PCUSupport.HasReader then
-      begin
-      //writeln('TPas2jsCompilerFile.CreateJS ',UnitFilename);
-      UseAnalyzer.EmitModuleHints(PasModule);
-      end;
-
     // convert
     CreateConverter;
     Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
@@ -1505,6 +1503,27 @@ begin
   //writeln('TPas2jsCompilerFile.CreateJS END ',UnitFilename,' JS=',GetObjName(FJSModule));
 end;
 
+procedure TPas2jsCompilerFile.EmitModuleHints;
+begin
+  try
+    // show hints only for units with sources
+    if (PCUSupport=nil) or not PCUSupport.HasReader then
+      begin
+      //writeln('TPas2jsCompilerFile.EmitModuleHints ',UnitFilename);
+      UseAnalyzer.EmitModuleHints(PasModule);
+      end;
+  except
+    on E: ECompilerTerminate do
+      raise;
+    on E: Exception do
+      HandleException(E);
+    {$IFDEF pas2js}
+    else
+      HandleJSException('[20190226183324] TPas2jsCompilerFile.EmitModuleHints File="'+UnitFilename+'"',
+                        JSExceptValue);
+    {$ENDIF}
+  end;
+end;
 
 function TPas2jsCompilerFile.GetPasFirstSection: TPasSection;
 var
@@ -1971,11 +1990,17 @@ procedure TPas2jsCompiler.CreateJavaScript(aFile: TPas2jsCompilerFile;
 
 begin
   //writeln('TPas2jsCompiler.CreateJavaScript ',aFile.UnitFilename,' JS=',GetObjName(aFile.JSModule),' Need=',aFile.NeedBuild);
-  if (aFile.JSModule<>nil) or (not aFile.NeedBuild) then exit;
+  if aFile.JSModule<>nil then exit; // already created
+
   // check each file only once
   if Checked.ContainsItem(aFile) then exit;
   Checked.Add(aFile);
 
+  // emit module hints
+  aFile.EmitModuleHints;
+
+  if not aFile.NeedBuild then exit;
+
   Log.LogMsg(nCompilingFile,[FullFormatPath(aFile.UnitFilename)],'',0,0,
     not (coShowLineNumbers in Options));
 
@@ -2692,7 +2717,7 @@ begin
   LastMsgNumber:=-1;
   r(mtInfo,nOptionIsEnabled,sOptionIsEnabled);
   r(mtInfo,nSyntaxModeIs,sSyntaxModeIs);
-  r(mtInfo,nMacroDefined,sMacroDefined);
+  LastMsgNumber:=-1; // was nMacroDefined 103
   r(mtInfo,nUsingPath,sUsingPath);
   r(mtNote,nFolderNotFound,sFolderNotFound);
   r(mtInfo,nNameValue,sNameValue);
@@ -2727,7 +2752,7 @@ begin
   r(mtInfo,nSrcMapBaseDirIs,sSrcMapBaseDirIs);
   r(mtFatal,nUnitFileNotFound,sUnitFileNotFound);
   r(mtInfo,nClassInterfaceStyleIs,sClassInterfaceStyleIs);
-  r(mtInfo,nMacroXSetToY,sMacroXSetToY);
+  LastMsgNumber:=-1; ;// was nMacroXSetToY 138
   r(mtInfo,nPostProcessorInfoX,sPostProcessorInfoX);
   r(mtInfo,nPostProcessorRunX,sPostProcessorRunX);
   r(mtError,nPostProcessorFailX,sPostProcessorFailX);
@@ -2750,7 +2775,6 @@ end;
 
 procedure TPas2JSConfigSupport.LoadConfig(Const aFileName: String);
 type
-
   TSkip = (
     skipNone,
     skipIf,
@@ -2961,17 +2985,14 @@ begin
 end;
 
 procedure TPas2jsCompiler.HandleOptionPCUFormat(aValue: String);
-
 begin
-  ParamFatal('No PCU support in this compiler for '+aValue);
+  ParamFatal('No support in this compiler for precompiled format '+aValue);
 end;
 
 function TPas2jsCompiler.HandleOptionPaths(C: Char; aValue: String;
   FromCmdLine: Boolean): Boolean;
-
 Var
   ErrorMsg: String;
-
 begin
   Result:=True;
   case c of
@@ -2986,10 +3007,8 @@ begin
 end;
 
 function TPas2jsCompiler.HandleOptionOptimization(C: Char; aValue: String): Boolean;
-
 Var
   Enable: Boolean;
-
 begin
   Result:=True;
   case C of
@@ -4032,7 +4051,6 @@ begin
     RaiseInternalError(20170504161340,'internal error: TPas2jsCompiler.Run FileCount>0');
 
   try
-
     // set working directory, need by all relative filenames
     SetWorkingDir(aWorkingDir);
 
@@ -4307,7 +4325,7 @@ begin
   if FHasShownLogo then exit;
   FHasShownLogo:=true;
   WriteVersionLine;
-  Log.LogPlain('Copyright (c) 2018 Free Pascal team.');
+  Log.LogPlain('Copyright (c) 2019 Free Pascal team.');
   if coShowInfos in Options then
     WriteEncoding;
 end;
@@ -4371,9 +4389,9 @@ begin
     S:=Defines[i];
     M:=TMacroDef(Defines.Objects[i]);
     if M<>nil then
-      Log.LogMsgIgnoreFilter(nMacroXSetToY,[S,QuoteStr(M.Value)])
+      Log.Log(mtInfo,SafeFormat(SLogMacroXSetToY,[S,QuoteStr(M.Value)]),nLogMacroXSetToY,'',0,0,false)
     else
-      Log.LogMsgIgnoreFilter(nMacroDefined,[S]);
+      Log.Log(mtInfo,SafeFormat(SLogMacroDefined,[S]),nLogMacroDefined,'',0,0,false)
     end;
   for pbi in TPas2JSBuiltInName do
     if Pas2JSBuiltInNames[pbi]<>ConverterGlobals.BuiltInNames[pbi] then
@@ -4386,22 +4404,20 @@ begin
 end;
 
 procedure TPas2jsCompiler.WriteUsedTools;
-
 begin
-  If Assigned(FPostProcessorSupport) then
+  if Assigned(FPostProcessorSupport) then
     FPostProcessorSupport.WriteUsedTools;
 end;
 
 procedure TPas2jsCompiler.WriteFoldersAndSearchPaths;
-
-Var
+var
   I: integer;
-
 begin
+  Log.LogMsgIgnoreFilter(nNameValue,['Compiler exe',QuoteStr(CompilerExe)]);
   FS.WriteFoldersAndSearchPaths;
   for i:=0 to Namespaces.Count-1 do
-    Log.LogMsgIgnoreFilter(nUsingPath,['unit scope',Namespaces[i]]);
-  Log.LogMsgIgnoreFilter(nNameValue,['output file',QuoteStr(MainJSFile)]);
+    Log.LogMsgIgnoreFilter(nUsingPath,['Unit scope',Namespaces[i]]);
+  Log.LogMsgIgnoreFilter(nNameValue,['Output file',QuoteStr(MainJSFile)]);
 end;
 
 procedure TPas2jsCompiler.WriteInfo;

packages/pastojs/src/pas2jsfilecache.pp

@@ -257,7 +257,7 @@ type
     function FindCustomJSFileName(const aFilename: string): String; override;
     function FindUnitJSFileName(const aUnitFilename: string): String; override;
     function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; override;
-    function FindIncludeFileName(const aFilename: string): String; override;
+    function FindIncludeFileName(const aFilename, ModuleDir: string): String; override;
     function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddSrcUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
@@ -1494,6 +1494,7 @@ procedure TPas2jsFilesCache.WriteFoldersAndSearchPaths;
 var
   i: Integer;
 begin
+  WriteFolder('working directory',GetCurrentDirPJ);
   for i:=0 to ForeignUnitPaths.Count-1 do
     WriteFolder('foreign unit path',ForeignUnitPaths[i]);
   for i:=0 to UnitPaths.Count-1 do
@@ -1812,7 +1813,8 @@ begin
     UsePointDirectory, true, RelPath);
 end;
 
-function TPas2jsFilesCache.FindIncludeFileName(const aFilename: string): String;
+function TPas2jsFilesCache.FindIncludeFileName(const aFilename,
+  ModuleDir: string): String;
 
   function SearchCasedInIncPath(const Filename: string): string;
   var
@@ -1820,9 +1822,9 @@ function TPas2jsFilesCache.FindIncludeFileName(const aFilename: string): String;
   begin
     // file name is relative
     // first search in the same directory as the unit
-    if BaseDirectory<>'' then
+    if ModuleDir<>'' then
       begin
-      Result:=BaseDirectory+Filename;
+      Result:=IncludeTrailingPathDelimiter(ModuleDir)+Filename;
       if SearchLowUpCase(Result) then exit;
       end;
     // then search in include path

packages/pastojs/src/pas2jsfiler.pp

@@ -172,7 +172,7 @@ const
     'ExternalClass',
     'PrefixedAttributes',
     'OmitRTTI',
-    'MultipleScopeHelpers'
+    'MultiHelpers'
     ); // Dont forget to update ModeSwitchToInt !
 
   PCUDefaultBoolSwitches: TBoolSwitches = [
@@ -971,6 +971,7 @@ type
     procedure ReadClassIntfMapProcs(Obj: TJSONObject; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
     procedure ReadClassIntfMap(Obj: TJSONObject; Scope: TPas2JSClassScope; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
     procedure ReadClassScopeInterfaces(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
+    procedure ReadClassScopeDispatchProcs(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
     procedure ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope; aContext: TPCUReaderContext); virtual;
     procedure ReadClassType(Obj: TJSONObject; El: TPasClassType; aContext: TPCUReaderContext); virtual;
     procedure ReadArgument(Obj: TJSONObject; El: TPasArgument; aContext: TPCUReaderContext); virtual;
@@ -1047,6 +1048,9 @@ type
 
 var
   PrecompileFormats: TPas2JSPrecompileFormats = nil;
+  PCUFormat: TPas2JSPrecompileFormat = nil;
+
+procedure RegisterPCUFormat;
 
 function ComparePointer(Data1, Data2: Pointer): integer;
 function ComparePCUSrcFiles(File1, File2: Pointer): integer;
@@ -1073,6 +1077,12 @@ function dbgmem(p: PChar; Cnt: integer): string; overload;
 
 implementation
 
+procedure RegisterPCUFormat;
+begin
+  if PCUFormat=nil then
+    PCUFormat:=PrecompileFormats.Add('pcu','all used pcu must match exactly',TPCUReader,TPCUWriter);
+end;
+
 function ComparePointer(Data1, Data2: Pointer): integer;
 begin
   if Data1>Data2 then Result:=-1
@@ -1394,7 +1404,7 @@ begin
     // msIgnoreInterfaces: Result:=46;
     // msIgnoreAttributes: Result:=47;
     msOmitRTTI: Result:=48;
-    msMultipleScopeHelpers: Result:=49;
+    msMultiHelpers: Result:=49;
   end;
 end;
 
@@ -3485,6 +3495,11 @@ begin
       AddReferenceToArray(Arr,Scope.AbstractProcs[i]);
     end;
 
+  if Scope.DispatchField<>'' then
+    Obj.Add('DispatchField',Scope.DispatchField);
+  if Scope.DispatchStrField<>'' then
+    Obj.Add('DispatchStrField',Scope.DispatchStrField);
+
   if Scope.GUID<>'' then
     Obj.Add('SGUID',Scope.GUID);
 
@@ -3786,6 +3801,7 @@ begin
       Obj.Add('Alias',El.AliasName);
     DefProcMods:=GetDefaultProcModifiers(El);
     WriteProcedureModifiers(Obj,'PMods',El.Modifiers,DefProcMods);
+    WriteExpr(Obj,El,'Msg',El.MessageExpr,aContext);
     if (El.MessageName<>'') or (El.MessageType<>pmtNone) then
       begin
       Obj.Add('Message',El.MessageName);
@@ -4954,6 +4970,8 @@ begin
     begin
     s:=Names[i];
     Found:=false;
+    if (FileVersion<5) and (SameText(s,'multiplescopehelpers')) then
+      s:=PCUModeSwitchNames[msMultiHelpers];
     for f in TModeSwitch do
       if s=PCUModeSwitchNames[f] then
         begin
@@ -6990,6 +7008,16 @@ begin
     end;
 end;
 
+procedure TPCUReader.ReadClassScopeDispatchProcs(Obj: TJSONObject;
+  Scope: TPas2JSClassScope);
+var
+  El: TPasClassType;
+begin
+  El:=TPasClassType(Scope.Element);
+  ReadString(Obj,'DispatchField',Scope.DispatchField,El);
+  ReadString(Obj,'DispatchStrField',Scope.DispatchStrField,El);
+end;
+
 procedure TPCUReader.ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope;
   aContext: TPCUReaderContext);
 var
@@ -7086,10 +7114,13 @@ begin
   ReadElementList(Obj,El,'Members',El.Members,
     {$IFDEF CheckPasTreeRefCount}'TPasClassType.Members'{$ELSE}true{$ENDIF},
     aContext);
+
+
   if Scope<>nil then
     begin
     ReadClassScopeAbstractProcs(Obj,Scope);
     ReadClassScopeInterfaces(Obj,Scope);
+    ReadClassScopeDispatchProcs(Obj,Scope);
 
     if El.ObjKind in okAllHelpers then
       begin
@@ -7563,6 +7594,7 @@ begin
     El.LibrarySymbolName:=ReadExpr(Obj,El,'LibName',aContext);
     El.DispIDExpr:=ReadExpr(Obj,El,'DispId',aContext);
     ReadString(Obj,'Alias',El.AliasName,El);
+    El.MessageExpr:=ReadExpr(Obj,El,'Msg',aContext);
     if ReadString(Obj,'Message',s,El) then
       begin
       El.MessageName:=s;
@@ -7924,6 +7956,8 @@ end;
 
 procedure TPas2JSPrecompileFormats.Clear;
 begin
+  if (PCUFormat<>nil) and (FItems.IndexOf(PCUFormat)>=0) then
+    PCUFormat:=nil;
   FItems.Clear;
 end;
 
@@ -7995,7 +8029,6 @@ end;
 
 initialization
   PrecompileFormats:=TPas2JSPrecompileFormats.Create;
-  PrecompileFormats.Add('pcu','all used pcu must match exactly',TPCUReader,TPCUWriter);
 finalization
   PrecompileFormats.Free;
   PrecompileFormats:=nil;

packages/pastojs/src/pas2jsfs.pp

@@ -96,7 +96,7 @@ Type
     function FindSourceFileName(const aFilename: string): String; virtual; abstract;
   Public
     // Public Abstract. Must be overridden
-    function FindIncludeFileName(const aFilename: string): String; virtual; abstract;
+    function FindIncludeFileName(const aFilename, ModuleDir: string): String; virtual; abstract;
     function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; virtual; abstract;
     Function FileExists(Const aFileName: String): Boolean; virtual; abstract;
     function FindUnitJSFileName(const aUnitFilename: string): String; virtual; abstract;
@@ -416,7 +416,7 @@ var
   Filename: String;
 begin
   Result:=nil;
-  Filename:=FS.FindIncludeFileName(aFilename);
+  Filename:=FS.FindIncludeFileName(aFilename,BaseDirectory);
   if Filename='' then exit;
   try
     Result:=FindSourceFile(Filename);
@@ -433,7 +433,7 @@ end;
 function TPas2jsFSResolver.FindIncludeFileName(const aFilename: string): String;
 
 begin
-  Result:=FS.FindIncludeFileName(aFilename);
+  Result:=FS.FindIncludeFileName(aFilename,BaseDirectory);
 end;
 
 

packages/pastojs/src/pas2jslogger.pp

@@ -37,7 +37,9 @@ uses
   {$IFDEF HASFILESYSTEM}
   pas2jsfileutils,
   {$ENDIF}
-  Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson;
+  Types, Classes, SysUtils,
+  PasTree, PScanner,
+  jstree, jsbase, jswriter, fpjson;
 
 const
   ExitCodeErrorInternal = 1; // internal error
@@ -123,7 +125,7 @@ type
     FLastMsgNumber: integer;
     FLastMsgTxt: string;
     FLastMsgType: TMessageType;
-    FMsgNumberDisabled: array of Integer;// sorted ascending
+    FMsgNumberDisabled: TIntegerDynArray;// sorted ascending
     FMsg: TFPList; // list of TPas2jsMessage
     FOnFormatPath: TPScannerFormatPathEvent;
     FOnLog: TPas2jsLogEvent;
@@ -144,11 +146,14 @@ type
     procedure SetOutputFilename(AValue: string);
     procedure SetSorted(AValue: boolean);
     procedure DoLogRaw(const Msg: string; SkipEncoding : Boolean);
-    function Concatenate(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
   Protected
     // so it can be overridden
     function CreateTextWriter(const aFileName: string): TTextWriter; virtual;
   public
+    {$IFDEF EnableLogFile}
+    LogFile: TStringList;
+    procedure LogF(args: array of const);
+    {$ENDIF}
     constructor Create;
     destructor Destroy; override;
     procedure RegisterMsg(MsgType: TMessageType; MsgNumber: integer; Pattern: string);
@@ -185,6 +190,7 @@ type
     procedure CloseDebugLog;
     procedure DebugLogWriteLn(Msg: string); overload;
     function GetEncodingCaption: string;
+    class function Concatenate(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
   public
     property Encoding: string read FEncoding write SetEncoding; // normalized
     property MsgCount: integer read GetMsgCount;
@@ -610,6 +616,26 @@ end;
 
 procedure TPas2jsLogger.SetMsgNumberDisabled(MsgNumber: integer; AValue: boolean
   );
+  {$IF defined(FPC) and (FPC_FULLVERSION<30101)}
+  procedure Delete(var A: TIntegerDynArray; Index, Count: integer); overload;
+  var
+    i: Integer;
+  begin
+    for i:=Index+Count to length(A)-1 do
+      A[i-Count]:=A[i];
+    SetLength(A,length(A)-Count);
+  end;
+
+  procedure Insert(Item: integer; var A: TIntegerDynArray; Index: integer); overload;
+  var
+    i: Integer;
+  begin
+    SetLength(A,length(A)+1);
+    for i:=length(A)-1 downto Index+1 do
+      A[i]:=A[i-1];
+    A[Index]:=Item;
+  end;
+  {$ENDIF}
 var
   InsertPos, OldCount: Integer;
 begin
@@ -621,25 +647,13 @@ begin
     if (InsertPos<OldCount) and (FMsgNumberDisabled[InsertPos]=MsgNumber) then
       exit; // already disabled
     // insert into array
-    {$IF defined(FPC) and (FPC_FULLVERSION<30101)}
-    SetLength(FMsgNumberDisabled,OldCount+1);
-    FMsgNumberDisabled[InsertPos]:=MsgNumber;
-    {$ELSE}
     Insert(MsgNumber,FMsgNumberDisabled,InsertPos);
-    {$ENDIF}
   end else begin
     // disable
     InsertPos:=FindMsgNumberDisabled(MsgNumber,false);
     if InsertPos<0 then exit;
     // delete from array
-    {$IF defined(FPC) and (FPC_FULLVERSION<30101)}
-    if InsertPos+1<OldCount then
-      Move(FMsgNumberDisabled[InsertPos+1],FMsgNumberDisabled[InsertPos],
-           SizeOf(Integer)*(OldCount-InsertPos-1));
-    SetLength(FMsgNumberDisabled,OldCount-1);
-    {$ELSE}
     Delete(FMsgNumberDisabled,InsertPos,1);
-    {$ENDIF}
   end;
 end;
 
@@ -705,63 +719,6 @@ begin
   end;
 end;
 
-function TPas2jsLogger.Concatenate(
-  Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
-var
-  s: String;
-  i: Integer;
-  {$IFDEF Pas2JS}
-  V: JSValue;
-  {$ELSE}
-  V: TVarRec;
-  {$ENDIF}
-begin
-  s:='';
-  for i:=Low(Args) to High(Args) do
-  begin
-    V:=Args[i];
-    {$IFDEF Pas2JS}
-    case jsTypeOf(V) of
-    'boolean':
-      if V then s+='true' else s+='false';
-    'number':
-      if isInteger(V) then
-        s+=str(NativeInt(V))
-      else
-        s+=str(Double(V));
-    'string':
-      s+=String(V);
-    else continue;
-    end;
-    {$ELSE}
-    case V.VType of
-      vtInteger:      s += IntToStr(V.VInteger);
-      vtBoolean:      s += BoolToStr(V.VBoolean);
-      vtChar:         s += V.VChar;
-      {$ifndef FPUNONE}
-      vtExtended:     ; //  V.VExtended^;
-      {$ENDIF}
-      vtString:       s += V.VString^;
-      vtPointer:      ; //  V.VPointer;
-      vtPChar:        s += V.VPChar;
-      vtObject:       ; //  V.VObject;
-      vtClass:        ; //  V.VClass;
-      vtWideChar:     s += AnsiString(V.VWideChar);
-      vtPWideChar:    s += AnsiString(V.VPWideChar);
-      vtAnsiString:   s += AnsiString(V.VAnsiString);
-      vtCurrency:     ; //  V.VCurrency^);
-      vtVariant:      ; //  V.VVariant^);
-      vtInterface:    ; //  V.VInterface^);
-      vtWidestring:   s += AnsiString(WideString(V.VWideString));
-      vtInt64:        s += IntToStr(V.VInt64^);
-      vtQWord:        s += IntToStr(V.VQWord^);
-      vtUnicodeString:s += AnsiString(UnicodeString(V.VUnicodeString));
-    end;
-    {$ENDIF}
-  end;
-  Result:=s;
-end;
-
 constructor TPas2jsLogger.Create;
 begin
   FMsg:=TFPList.Create;
@@ -906,6 +863,63 @@ begin
     Result:='utf-8';
 end;
 
+class function TPas2jsLogger.Concatenate(
+  Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
+var
+  s: String;
+  i: Integer;
+  {$IFDEF Pas2JS}
+  V: JSValue;
+  {$ELSE}
+  V: TVarRec;
+  {$ENDIF}
+begin
+  s:='';
+  for i:=Low(Args) to High(Args) do
+  begin
+    V:=Args[i];
+    {$IFDEF Pas2JS}
+    case jsTypeOf(V) of
+    'boolean':
+      if V then s+='true' else s+='false';
+    'number':
+      if isInteger(V) then
+        s+=str(NativeInt(V))
+      else
+        s+=str(Double(V));
+    'string':
+      s+=String(V);
+    else continue;
+    end;
+    {$ELSE}
+    case V.VType of
+      vtInteger:      s += IntToStr(V.VInteger);
+      vtBoolean:      s += BoolToStr(V.VBoolean);
+      vtChar:         s += V.VChar;
+      {$ifndef FPUNONE}
+      vtExtended:     ; //  V.VExtended^;
+      {$ENDIF}
+      vtString:       s += V.VString^;
+      vtPointer:      ; //  V.VPointer;
+      vtPChar:        s += V.VPChar;
+      vtObject:       ; //  V.VObject;
+      vtClass:        ; //  V.VClass;
+      vtWideChar:     s += AnsiString(V.VWideChar);
+      vtPWideChar:    s += AnsiString(V.VPWideChar);
+      vtAnsiString:   s += AnsiString(V.VAnsiString);
+      vtCurrency:     ; //  V.VCurrency^);
+      vtVariant:      ; //  V.VVariant^);
+      vtInterface:    ; //  V.VInterface^);
+      vtWidestring:   s += AnsiString(WideString(V.VWideString));
+      vtInt64:        s += IntToStr(V.VInt64^);
+      vtQWord:        s += IntToStr(V.VQWord^);
+      vtUnicodeString:s += AnsiString(UnicodeString(V.VUnicodeString));
+    end;
+    {$ENDIF}
+  end;
+  Result:=s;
+end;
+
 procedure TPas2jsLogger.LogPlain(const Msg: string);
 var
   s: String;
@@ -1059,7 +1073,7 @@ begin
   end;
 end;
 
-Function TPas2jsLogger.CreateTextWriter(const aFileName : string) : TTextWriter;
+function TPas2jsLogger.CreateTextWriter(const aFileName: string): TTextWriter;
 
 begin
 {$IFDEF HASFILESYSTEM}
@@ -1069,6 +1083,16 @@ begin
 {$ENDIF}
 end;
 
+{$IFDEF EnableLogFile}
+procedure TPas2jsLogger.LogF(args: array of const);
+begin
+  if LogFile=nil then
+    LogFile:=TStringList.Create;
+  LogFile.Add(TPas2jsLogger.Concatenate(args));
+  LogFile.SaveToFile('c:\tmp\libpas2jsparams.txt');
+end;
+{$ENDIF}
+
 procedure TPas2jsLogger.OpenOutputFile;
 begin
 {$IFDEF HASFILESYSTEM}

packages/pastojs/src/pas2jspcucompiler.pp

@@ -81,7 +81,8 @@ Type
   Protected
     procedure WritePrecompiledFormats; override;
     function CreateCompilerFile(const PasFileName, PCUFilename: String): TPas2jsCompilerFile; override;
-    procedure HandleOptionPCUFormat(Value: string) ; override;
+    procedure HandleOptionPCUFormat(Value: string); override;
+    property PrecompileFormat: TPas2JSPrecompileFormat read FPrecompileFormat;
   end;
 
 implementation
@@ -402,11 +403,19 @@ Var
 begin
   if PrecompileFormats.Count>0 then
   begin
-    writeHelpLine('   -JU<x>: Create precompiled units in format x.');
-    for i:=0 to PrecompileFormats.Count-1 do
-      with PrecompileFormats[i] do
-        writeHelpLine('     -JU'+Ext+': '+Description);
-    writeHelpLine('     -JU-: Disable prior -JU<x> option. Do not create precompiled units.');
+    if PrecompileFormats.Count>1 then
+    begin
+      writeHelpLine('   -JU<x>: Create precompiled units in format x.');
+      for i:=0 to PrecompileFormats.Count-1 do
+        with PrecompileFormats[i] do
+          writeHelpLine('     -JU'+Ext+':  '+Description);
+      writeHelpLine('     -JU-: Disable prior -JU<x> option. Do not create precompiled units.');
+    end else
+    begin
+      with PrecompileFormats[0] do
+        writeHelpLine('   -JU'+Ext+': Create precompiled units using '+Description);
+      writeHelpLine('   -JU-  : Disable prior -JU<x> option. Do not create precompiled units.');
+    end;
   end;
 end;
 
@@ -428,6 +437,7 @@ begin
     PF:=PrecompileFormats[i];
     if not SameText(Value,PF.Ext) then continue;
     FPrecompileFormat:=PrecompileFormats[i];
+    Options:=Options+[coPrecompile];
     Found:=true;
   end;
   if not Found then
@@ -437,13 +447,13 @@ end;
 { TPas2jsPCUCompilerFile }
 
 function TPas2jsPCUCompilerFile.CreatePCUSupport: TPCUSupport;
-
 Var
   PF: TPas2JSPrecompileFormat;
-
 begin
   // Note that if no format was preset, no files will be written
   PF:=(Compiler as TPas2jsPCUCompiler).FPrecompileFormat;
+  if (PF=nil) and (PrecompileFormats.Count>0) then
+    PF:=PrecompileFormats[0];
   if PF<>Nil then
     Result:=TFilerPCUSupport.Create(Self,PF)
   else

packages/pastojs/tests/tcfiler.pas

@@ -161,6 +161,7 @@ type
     procedure TestPC_Class;
     procedure TestPC_ClassForward;
     procedure TestPC_ClassConstructor;
+    procedure TestPC_ClassDispatchMessage;
     procedure TestPC_Initialization;
     procedure TestPC_BoolSwitches;
     procedure TestPC_ClassInterface;
@@ -748,6 +749,8 @@ begin
 
   CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
   AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
+  AssertEquals(Path+'.DispatchField',Orig.DispatchField,Rest.DispatchField);
+  AssertEquals(Path+'.DispatchStrField',Orig.DispatchStrField,Rest.DispatchStrField);
 
   CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
   if Orig.Interfaces<>nil then
@@ -1646,6 +1649,7 @@ begin
   '  s = ''abc'';', // string lit
   '  c: char = s[1];', // array params
   '  a: array[1..2] of longint = (3,4);', // anonymous array, range, array values
+  '  PI: Double; external name ''Math.PI'';',
   'resourcestring',
   '  rs = ''rs'';',
   'implementation']);
@@ -1745,11 +1749,13 @@ procedure TTestPrecompile.TestPC_Record;
 begin
   StartUnit(false);
   Add([
+  '{$ModeSwitch externalclass}',
   'interface',
   'type',
   '  TRec = record',
   '    i: longint;',
   '    s: string;',
+  '    b: boolean external name ''ext'';',
   '  end;',
   '  P = pointer;', // alias type to built-in type
   '  TArrOfRec = array of TRec;',
@@ -2140,6 +2146,38 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_ClassDispatchMessage;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  {$DispatchField DispInt}',
+  '  {$DispatchStrField DispStr}',
+  '  TObject = class',
+  '  end;',
+  '  THopMsg = record',
+  '    DispInt: longint;',
+  '  end;',
+  '  TPutMsg = record',
+  '    DispStr: string;',
+  '  end;',
+  '  TBird = class',
+  '    procedure Fly(var Msg); virtual; abstract; message 2;',
+  '    procedure Run; overload; virtual; abstract;',
+  '    procedure Run(var Msg); overload; message ''Fast'';',
+  '    procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
+  '    procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
+  '  end;',
+  'implementation',
+  'procedure TBird.Run(var Msg);',
+  'begin',
+  'end;',
+  'end.',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_Initialization;
 begin
   StartUnit(false);
@@ -2359,5 +2397,6 @@ end;
 
 Initialization
   RegisterTests([TTestPrecompile]);
+  RegisterPCUFormat;
 end.
 

packages/pastojs/tests/tcmodules.pas

@@ -263,7 +263,8 @@ type
     Procedure TestInteger;
     Procedure TestIntegerRange;
     Procedure TestIntegerTypecasts;
-    Procedure TestBitwiseAndNativeIntWarn;
+    Procedure TestInteger_BitwiseShrNativeInt;
+    Procedure TestInteger_BitwiseShlNativeInt;
     Procedure TestCurrency;
     Procedure TestForBoolDo;
     Procedure TestForIntDo;
@@ -345,6 +346,7 @@ type
     Procedure TestAnonymousProc_ExceptOn;
     Procedure TestAnonymousProc_Nested;
     Procedure TestAnonymousProc_NestedAssignResult;
+    Procedure TestAnonymousProc_Class;
 
     // enums, sets
     Procedure TestEnum_Name;
@@ -453,7 +455,7 @@ type
     Procedure TestRecordElementFromFuncResult_AsParams;
     Procedure TestRecordElementFromWith_AsParams;
     Procedure TestRecord_Equal;
-    Procedure TestRecord_TypeCastJSValueToRecord;
+    Procedure TestRecord_JSValue;
     Procedure TestRecord_VariantFail;
     Procedure TestRecord_FieldArray;
     Procedure TestRecord_Const;
@@ -473,7 +475,8 @@ type
     Procedure TestAdvRecord_SubClass;
     Procedure TestAdvRecord_SubInterfaceFail;
     Procedure TestAdvRecord_Constructor;
-    Procedure TestAdvRecord_ClassConstructor;
+    Procedure TestAdvRecord_ClassConstructor_Program;
+    Procedure TestAdvRecord_ClassConstructor_Unit;
 
     // classes
     Procedure TestClass_TObjectDefaultConstructor;
@@ -530,6 +533,9 @@ type
     Procedure TestClass_TObjectFreeFunctionFail;
     Procedure TestClass_TObjectFreePropertyFail;
     Procedure TestClass_ForIn;
+    Procedure TestClass_DispatchMessage;
+    Procedure TestClass_Message_DuplicateIntFail;
+    Procedure TestClass_DispatchMessage_WrongFieldNameFail;
 
     // class of
     Procedure TestClassOf_Create;
@@ -587,6 +593,7 @@ type
     Procedure TestExternalClass_TypeCastToJSObject;
     Procedure TestExternalClass_TypeCastStringToExternalString;
     Procedure TestExternalClass_TypeCastToJSFunction;
+    Procedure TestExternalClass_TypeCastDelphiUnrelated;
     Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
     Procedure TestExternalClass_BracketAccessor;
     Procedure TestExternalClass_BracketAccessor_Call;
@@ -675,10 +682,12 @@ type
     Procedure TestTypeHelper_ClassMethod;
     Procedure TestTypeHelper_Constructor;
     Procedure TestTypeHelper_Word;
+    Procedure TestTypeHelper_Double;
     Procedure TestTypeHelper_StringChar;
     Procedure TestTypeHelper_Array;
     Procedure TestTypeHelper_EnumType;
     Procedure TestTypeHelper_SetType;
+    Procedure TestTypeHelper_InterfaceType;
 
     // proc types
     Procedure TestProcType;
@@ -1289,9 +1298,12 @@ begin
   aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
   aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
 
-  aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
-  aScanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
-  aScanner.CurrentBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
+  aScanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
+  aScanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
+  aScanner.CurrentBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
+
+  aScanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
+  aScanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
 
   aScanner.OnLog:=@OnScannerLog;
 
@@ -3079,24 +3091,36 @@ end;
 procedure TTestModule.TestBitwiseOperators;
 begin
   StartProgram(false);
-  Add('var');
-  Add('  vA,vB,vC:longint;');
-  Add('begin');
-  Add('  va:=vb and vc;');
-  Add('  va:=vb or vc;');
-  Add('  va:=vb xor vc;');
-  Add('  va:=vb shl vc;');
-  Add('  va:=vb shr vc;');
-  Add('  va:=3 and vc;');
-  Add('  va:=(vb and vc) or (va and vb);');
-  Add('  va:=not vb;');
+  Add([
+  'var',
+  '  vA,vB,vC:longint;',
+  '  X,Y,Z: nativeint;',
+  'begin',
+  '  va:=vb and vc;',
+  '  va:=vb or vc;',
+  '  va:=vb xor vc;',
+  '  va:=vb shl vc;',
+  '  va:=vb shr vc;',
+  '  va:=3 and vc;',
+  '  va:=(vb and vc) or (va and vb);',
+  '  va:=not vb;',
+  '  X:=Y and Z;',
+  '  X:=Y and va;',
+  '  X:=Y or Z;',
+  '  X:=Y or va;',
+  '  X:=Y xor Z;',
+  '  X:=Y xor va;',
+  '']);
   ConvertProgram;
   CheckSource('TestBitwiseOperators',
     LinesToStr([ // statements
     'this.vA = 0;',
     'this.vB = 0;',
-    'this.vC = 0;'
-    ]),
+    'this.vC = 0;',
+    'this.X = 0;',
+    'this.Y = 0;',
+    'this.Z = 0;',
+    '']),
     LinesToStr([ // this.$main
     '$mod.vA = $mod.vB & $mod.vC;',
     '$mod.vA = $mod.vB | $mod.vC;',
@@ -3105,8 +3129,14 @@ begin
     '$mod.vA = $mod.vB >>> $mod.vC;',
     '$mod.vA = 3 & $mod.vC;',
     '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
-    '$mod.vA = ~$mod.vB;'
-    ]));
+    '$mod.vA = ~$mod.vB;',
+    '$mod.X = rtl.and($mod.Y, $mod.Z);',
+    '$mod.X = $mod.Y & $mod.vA;',
+    '$mod.X = rtl.or($mod.Y, $mod.Z);',
+    '$mod.X = rtl.or($mod.Y, $mod.vA);',
+    '$mod.X = rtl.xor($mod.Y, $mod.Z);',
+    '$mod.X = rtl.xor($mod.Y, $mod.vA);',
+    '']));
 end;
 
 procedure TTestModule.TestPrgProcVar;
@@ -3676,6 +3706,7 @@ procedure TTestModule.TestProc_Asm;
 begin
   StartProgram(false);
   Add([
+  '{$mode delphi}',
   'function DoIt: longint;',
   'begin;',
   '  asm',
@@ -3691,6 +3722,10 @@ begin
   '    s = "end";',
   '  end;',
   'end;',
+  'procedure Fly;',
+  'asm',
+  '  return;',
+  'end;',
   'begin']);
   ConvertProgram;
   CheckSource('TestProc_Asm',
@@ -3706,8 +3741,11 @@ begin
     '  s = ''end'';',
     '  s = "end";',
     '  return Result;',
-    '};'
-    ]),
+    '};',
+    'this.Fly = function () {',
+    '  return;',
+    '};',
+    '']),
     LinesToStr([
     ''
     ]));
@@ -4710,6 +4748,47 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestAnonymousProc_Class;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure;',
+  '  TObject = class',
+  '    Size: word;',
+  '    function GetIt: TProc;',
+  '  end;',
+  'function TObject.GetIt: TProc;',
+  'begin',
+  '  Result:=procedure',
+  '    begin',
+  '      Size:=Size;',
+  '    end;',
+  'end;',
+  'begin']);
+  ConvertProgram;
+  CheckSource('TestAnonymousProc_Class',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '    this.Size = 0;',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.GetIt = function () {',
+    '    var $Self = this;',
+    '    var Result = null;',
+    '    Result = function () {',
+    '      $Self.Size = $Self.Size;',
+    '    };',
+    '    return Result;',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([
+    '']));
+end;
+
 procedure TTestModule.TestEnum_Name;
 begin
   StartProgram(false);
@@ -6413,25 +6492,59 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestBitwiseAndNativeIntWarn;
+procedure TTestModule.TestInteger_BitwiseShrNativeInt;
 begin
   StartProgram(false);
   Add([
   'var',
   '  i,j: nativeint;',
   'begin',
-  '  i:=i and j;',
+  '  i:=i shr 0;',
+  '  i:=i shr 1;',
+  '  i:=i shr 3;',
+  '  i:=i shr 54;',
+  '  i:=j shr i;',
   '']);
   ConvertProgram;
-  CheckSource('TestBitwiseAndNativeIntWarn',
+  CheckResolverUnexpectedHints;
+  CheckSource('TestInteger_BitwiseShrNativeInt',
     LinesToStr([
     'this.i = 0;',
     'this.j = 0;',
     '']),
     LinesToStr([
-    '$mod.i = $mod.i & $mod.j;',
+    '$mod.i = $mod.i;',
+    '$mod.i = Math.floor($mod.i / 2);',
+    '$mod.i = Math.floor($mod.i / 8);',
+    '$mod.i = 0;',
+    '$mod.i = rtl.shr($mod.j, $mod.i);',
+    '']));
+end;
+
+procedure TTestModule.TestInteger_BitwiseShlNativeInt;
+begin
+  StartProgram(false);
+  Add([
+  'var',
+  '  i: nativeint;',
+  'begin',
+  '  i:=i shl 0;',
+  '  i:=i shl 54;',
+  '  i:=123456789012 shl 1;',
+  '  i:=i shl 1;',
+  '']);
+  ConvertProgram;
+  CheckResolverUnexpectedHints;
+  CheckSource('TestInteger_BitwiseShrNativeInt',
+    LinesToStr([
+    'this.i = 0;',
+    '']),
+    LinesToStr([
+    '$mod.i = $mod.i;',
+    '$mod.i = 0;',
+    '$mod.i = 246913578024;',
+    '$mod.i = rtl.shl($mod.i, 1);',
     '']));
-  CheckHint(mtWarning,nBitWiseOperationsAre32Bit,sBitWiseOperationsAre32Bit);
 end;
 
 procedure TTestModule.TestCurrency;
@@ -9969,14 +10082,19 @@ begin
   '  U:=vd;',
   '  U:=vc;',
   '  U:=vv;',
+  '  vl:=TRecord(U);',
+  '  vd:=TRecord(U);',
+  '  vv:=TRecord(U);',
   '  doit(vd,vd,vd,vd);',
   '  doit(vc,vc,vl,vl);',
   '  doit(vv,vv,vv,vv);',
   '  doit(vl,vl,vl,vl);',
+  '  TRecord(U).i:=3;',
   'end;',
   'var i: TRecord;',
   'begin',
-  '  doit(i,i,i,i);']);
+  '  doit(i,i,i,i);',
+  '']);
   ConvertProgram;
   CheckSource('TestRecord_AsParams',
     LinesToStr([ // statements
@@ -9997,55 +10115,23 @@ begin
     '  vL.$assign(vC);',
     '  vV.$assign(vV);',
     '  vV.i = vV.i;',
-    '  U.set(vL);',
-    '  U.set(vD);',
-    '  U.set(vC);',
-    '  U.set(vV);',
-    '  $mod.DoIt($mod.TRecord.$clone(vD), vD, vD, {',
-    '    get: function () {',
-    '        return vD;',
-    '      },',
-    '    set: function (v) {',
-    '        vD.$assign(v);',
-    '      }',
-    '  });',
-    '  $mod.DoIt($mod.TRecord.$clone(vC), vC, vL, {',
-    '    get: function () {',
-    '        return vL;',
-    '      },',
-    '    set: function (v) {',
-    '        vL.$assign(v);',
-    '      }',
-    '  });',
-    '  $mod.DoIt($mod.TRecord.$clone(vV), vV, vV, {',
-    '    get: function () {',
-    '        return vV;',
-    '      },',
-    '    set: function (v) {',
-    '        vV.$assign(v);',
-    '      }',
-    '  });',
-    '  $mod.DoIt($mod.TRecord.$clone(vL), vL, vL, {',
-    '    get: function () {',
-    '        return vL;',
-    '      },',
-    '    set: function (v) {',
-    '        vL.$assign(v);',
-    '      }',
-    '  });',
+    '  U.$assign(vL);',
+    '  U.$assign(vD);',
+    '  U.$assign(vC);',
+    '  U.$assign(vV);',
+    '  vL.$assign(U);',
+    '  vD.$assign(U);',
+    '  vV.$assign(U);',
+    '  $mod.DoIt($mod.TRecord.$clone(vD), vD, vD, vD);',
+    '  $mod.DoIt($mod.TRecord.$clone(vC), vC, vL, vL);',
+    '  $mod.DoIt($mod.TRecord.$clone(vV), vV, vV, vV);',
+    '  $mod.DoIt($mod.TRecord.$clone(vL), vL, vL, vL);',
+    '  U.i = 3;',
     '};',
     'this.i = $mod.TRecord.$new();'
     ]),
     LinesToStr([
-    '$mod.DoIt($mod.TRecord.$clone($mod.i), $mod.i, $mod.i, {',
-    '  p: $mod,',
-    '  get: function () {',
-    '      return this.p.i;',
-    '    },',
-    '  set: function (v) {',
-    '      this.p.i.$assign(v);',
-    '    }',
-    '});',
+    '$mod.DoIt($mod.TRecord.$clone($mod.i), $mod.i, $mod.i, $mod.i);',
     '']));
 end;
 
@@ -10269,20 +10355,28 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
+procedure TTestModule.TestRecord_JSValue;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TRecord = record');
-  Add('    i: longint;');
-  Add('  end;');
-  Add('var');
-  Add('  Jv: jsvalue;');
-  Add('  Rec: trecord;');
-  Add('begin');
-  Add('  rec:=trecord(jv);');
+  Add([
+  'type',
+  '  TRecord = record',
+  '    i: longint;',
+  '  end;',
+  'procedure Fly(d: jsvalue; const c: jsvalue);',
+  'begin',
+  'end;',
+  'var',
+  '  Jv: jsvalue;',
+  '  Rec: trecord;',
+  'begin',
+  '  rec:=trecord(jv);',
+  '  jv:=rec;',
+  '  Fly(rec,rec);',
+  '  Fly(@rec,@rec);',
+  '']);
   ConvertProgram;
-  CheckSource('TestRecord_TypeCastJSValueToRecord',
+  CheckSource('TestRecord_JSValue',
     LinesToStr([ // statements
     'rtl.recNewT($mod, "TRecord", function () {',
     '  this.i = 0;',
@@ -10294,11 +10388,16 @@ begin
     '    return this;',
     '  };',
     '});',
+    'this.Fly = function (d, c) {',
+    '};',
     'this.Jv = undefined;',
     'this.Rec = $mod.TRecord.$new();',
     '']),
     LinesToStr([
     '$mod.Rec.$assign(rtl.getObject($mod.Jv));',
+    '$mod.Jv = $mod.Rec;',
+    '$mod.Fly($mod.TRecord.$clone($mod.Rec), $mod.Rec);',
+    '$mod.Fly($mod.Rec, $mod.Rec);',
     '']));
 end;
 
@@ -11140,7 +11239,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestAdvRecord_ClassConstructor;
+procedure TTestModule.TestAdvRecord_ClassConstructor_Program;
 begin
   StartProgram(false);
   Add([
@@ -11168,7 +11267,7 @@ begin
   '  r.x:=10;',
   '']);
   ConvertProgram;
-  CheckSource('TestAdvRecord_ClassConstructor',
+  CheckSource('TestAdvRecord_ClassConstructor_Program',
     LinesToStr([ // statements
     'rtl.recNewT($mod, "TPoint", function () {',
     '  this.x = 0;',
@@ -11196,6 +11295,62 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestAdvRecord_ClassConstructor_Unit;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  '{$modeswitch AdvancedRecords}',
+  'type',
+  '  TPoint = record',
+  '    class var x: longint;',
+  '    class procedure Fly; static;',
+  '    class constructor Init;',
+  '  end;',
+  'implementation',
+  'var count: word;',
+  'class procedure Tpoint.Fly;',
+  'begin',
+  'end;',
+  'class constructor tpoint.init;',
+  'begin',
+  '  count:=count+1;',
+  '  x:=3;',
+  '  tpoint.x:=4;',
+  '  fly;',
+  '  tpoint.fly;',
+  'end;',
+  '']);
+  ConvertUnit;
+  CheckSource('TestAdvRecord_ClassConstructor_Unit',
+    LinesToStr([ // statements
+    'var $impl = $mod.$impl;',
+    'rtl.recNewT($mod, "TPoint", function () {',
+    '  this.x = 0;',
+    '  this.$eq = function (b) {',
+    '    return true;',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    return this;',
+    '  };',
+    '  this.Fly = function () {',
+    '  };',
+    '}, true);',
+    '']),
+    LinesToStr([ // $mod.$init
+    '(function () {',
+    '  $impl.count = $impl.count + 1;',
+    '  $mod.TPoint.x = 3;',
+    '  $mod.TPoint.x = 4;',
+    '  $mod.TPoint.Fly();',
+    '  $mod.TPoint.Fly();',
+    '})();',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$impl.count = 0;',
+    '']));
+end;
+
 procedure TTestModule.TestClass_TObjectDefaultConstructor;
 begin
   StartProgram(false);
@@ -11893,7 +12048,7 @@ begin
   '    class var vI: longint;',
   '    class var Sub: TObject;',
   '    constructor Create;',
-  '    class function GetIt(Par: longint): tobject;',
+  '    class function GetIt(var Par: longint): tobject;',
   '  end;',
   'constructor tobject.create;',
   'begin',
@@ -11901,12 +12056,13 @@ begin
   '  Self.vi:=Self.vi+1;',
   '  inc(vi);',
   'end;',
-  'class function tobject.getit(par: longint): tobject;',
+  'class function tobject.getit(var par: longint): tobject;',
   'begin',
-  '  vi:=vi+par;',
-  '  Self.vi:=Self.vi+par;',
+  '  vi:=vi+3;',
+  '  Self.vi:=Self.vi+4;',
   '  inc(vi);',
   '  Result:=self.sub;',
+  '  GetIt(vi);',
   'end;',
   'var Obj: tobject;',
   'begin',
@@ -11934,10 +12090,19 @@ begin
     '  };',
     '  this.GetIt = function(Par){',
     '    var Result = null;',
-    '    $mod.TObject.vI = this.vI + Par;',
-    '    $mod.TObject.vI = this.vI + Par;',
+    '    $mod.TObject.vI = this.vI + 3;',
+    '    $mod.TObject.vI = this.vI + 4;',
     '    $mod.TObject.vI += 1;',
     '    Result = this.Sub;',
+    '    this.GetIt({',
+    '      p: $mod.TObject,',
+    '      get: function () {',
+    '          return this.p.vI;',
+    '        },',
+    '      set: function (v) {',
+    '          this.p.vI = v;',
+    '        }',
+    '    });',
     '    return Result;',
     '  };',
     '});',
@@ -14271,6 +14436,117 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClass_DispatchMessage;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    {$DispatchField DispInt}',
+  '    procedure Dispatch(var Msg); virtual; abstract;',
+  '    {$DispatchStrField DispStr}',
+  '    procedure DispatchStr(var Msg); virtual; abstract;',
+  '  end;',
+  '  THopMsg = record',
+  '    DispInt: longint;',
+  '  end;',
+  '  TPutMsg = record',
+  '    DispStr: string;',
+  '  end;',
+  '  TBird = class',
+  '    procedure Fly(var Msg); virtual; abstract; message 2;',
+  '    procedure Run; overload; virtual; abstract;',
+  '    procedure Run(var Msg); overload; message ''Fast'';',
+  '    procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
+  '    procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
+  '  end;',
+  'procedure TBird.Run(var Msg);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClass_Message',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.recNewT($mod, "THopMsg", function () {',
+    '  this.DispInt = 0;',
+    '  this.$eq = function (b) {',
+    '    return this.DispInt === b.DispInt;',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    this.DispInt = s.DispInt;',
+    '    return this;',
+    '  };',
+    '});',
+    'rtl.recNewT($mod, "TPutMsg", function () {',
+    '  this.DispStr = "";',
+    '  this.$eq = function (b) {',
+    '    return this.DispStr === b.DispStr;',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    this.DispStr = s.DispStr;',
+    '    return this;',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
+    '  this.Run$1 = function (Msg) {',
+    '  };',
+    '  this.$msgint = {',
+    '    "2": "Fly",',
+    '    "3": "Hop"',
+    '  };',
+    '  this.$msgstr = {',
+    '    Fast: "Run$1",',
+    '    foo: "Put"',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
+procedure TTestModule.TestClass_Message_DuplicateIntFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure Fly(var Msg); virtual; abstract; message 3;',
+  '    procedure Run(var Msg); virtual; abstract; message 1+2;',
+  '  end;',
+  'begin',
+  '']);
+  SetExpectedPasResolverError('Duplicate message id "3" at test1.pp(5,56)',nDuplicateMessageIdXAtY);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestClass_DispatchMessage_WrongFieldNameFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    {$dispatchfield Msg}',
+  '    procedure Dispatch(var Msg); virtual; abstract;',
+  '  end;',
+  '  TFlyMsg = record',
+  '    FlyId: longint;',
+  '  end;',
+  '  TBird = class',
+  '    procedure Fly(var Msg: TFlyMsg); virtual; abstract; message 3;',
+  '  end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckHint(mtWarning,nDispatchRequiresX,'Dispatch requires record field "Msg"');
+end;
+
 procedure TTestModule.TestClassOf_Create;
 begin
   StartProgram(false);
@@ -16416,6 +16692,43 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestExternalClass_TypeCastDelphiUnrelated;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSObject = class external name ''Object'' end;',
+  '  TJSWindow = class external name ''Window''(TJSObject)',
+  '    procedure Open;',
+  '  end;',
+  '  TJSEventTarget = class external name ''Event''(TJSObject)',
+  '    procedure Execute;',
+  '  end;',
+  'procedure Fly;',
+  'var',
+  '  w: TJSWindow;',
+  '  e: TJSEventTarget;',
+  'begin',
+  '  w:=TJSWindow(e);',
+  '  e:=TJSEventTarget(w);',
+  'end;',
+  'begin']);
+  ConvertProgram;
+  CheckSource('TestExternalClass_TypeCastDelphiUnrelated',
+    LinesToStr([ // statements
+    'this.Fly = function () {',
+    '  var w = null;',
+    '  var e = null;',
+    '  w = e;',
+    '  e = w;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
 begin
   StartProgram(false);
@@ -22819,6 +23132,84 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestTypeHelper_Double;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  Float = type double;',
+  '  THelper = type helper for double',
+  '    const NPI = 3.141592;',
+  '    function ToStr: String;',
+  '  end;',
+  'function THelper.ToStr: String;',
+  'begin',
+  'end;',
+  'procedure DoIt(s: string);',
+  'begin',
+  'end;',
+  'var f: Float;',
+  'begin',
+  '  DoIt(f.toStr);',
+  '  DoIt(f.toStr());',
+  '  (f*f).toStr;',
+  '  DoIt((f*f).toStr);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestTypeHelper_Double',
+    LinesToStr([ // statements
+    'rtl.createHelper($mod, "THelper", null, function () {',
+    '  this.NPI = 3.141592;',
+    '  this.ToStr = function () {',
+    '    var Result = "";',
+    '    return Result;',
+    '  };',
+    '});',
+    'this.DoIt = function (s) {',
+    '};',
+    'this.f = 0.0;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.DoIt($mod.THelper.ToStr.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.f;',
+    '    },',
+    '  set: function (v) {',
+    '      this.p.f = v;',
+    '    }',
+    '}));',
+    '$mod.DoIt($mod.THelper.ToStr.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.f;',
+    '    },',
+    '  set: function (v) {',
+    '      this.p.f = v;',
+    '    }',
+    '}));',
+    '$mod.THelper.ToStr.call({',
+    '  a: $mod.f * $mod.f,',
+    '  get: function () {',
+    '      return this.a;',
+    '    },',
+    '  set: function (v) {',
+    '      rtl.raiseE("EPropReadOnly");',
+    '    }',
+    '});',
+    '$mod.DoIt($mod.THelper.ToStr.call({',
+    '  a: $mod.f * $mod.f,',
+    '  get: function () {',
+    '      return this.a;',
+    '    },',
+    '  set: function (v) {',
+    '      rtl.raiseE("EPropReadOnly");',
+    '    }',
+    '}));',
+    '']));
+end;
+
 procedure TTestModule.TestTypeHelper_StringChar;
 begin
   StartProgram(false);
@@ -23134,6 +23525,134 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestTypeHelper_InterfaceType;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces com}',
+  '{$modeswitch typehelpers}',
+  'type',
+  '  IUnknown = interface',
+  '    function _AddRef: longint;',
+  '    function _Release: longint;',
+  '  end;',
+  '  TObject = class(IUnknown)',
+  '    function _AddRef: longint; virtual; abstract;',
+  '    function _Release: longint; virtual; abstract;',
+  '  end;',
+  '  THelper = type helper for IUnknown',
+  '    procedure Fly(e: byte = 123);',
+  '    class procedure Run; static;',
+  '  end;',
+  'var',
+  '  i: IUnknown;',
+  '  o: TObject;',
+  'procedure THelper.Fly(e: byte);',
+  'begin',
+  '  i:=Self;',
+  '  o:=Self as TObject;',
+  '  Self:=nil;',
+  '  Self:=i;',
+  '  Self:=o;',
+  '  with Self do begin',
+  '    Fly;',
+  '    Fly();',
+  '  end;',
+  'end;',
+  'class procedure THelper.Run;',
+  'var l: IUnknown;',
+  'begin',
+  '  l.Fly;',
+  '  l.Fly();',
+  'end;',
+  'begin',
+  '  i.Fly;',
+  '  i.Fly();',
+  '  i.Run;',
+  '  i.Run();',
+  '  IUnknown.Run;',
+  '  IUnknown.Run();',
+  '']);
+  ConvertProgram;
+  CheckSource('TestTypeHelper_InterfaceType',
+    LinesToStr([ // statements
+    'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  rtl.addIntf(this, $mod.IUnknown);',
+    '});',
+    'rtl.createHelper($mod, "THelper", null, function () {',
+    '  this.Fly = function (e) {',
+    '    var $ir = rtl.createIntfRefs();',
+    '    try {',
+    '      rtl.setIntfP($mod, "i", this.get());',
+    '      $mod.o = rtl.intfAsClass(this.get(), $mod.TObject);',
+    '      this.set(null);',
+    '      this.set($mod.i);',
+    '      this.set($ir.ref(1, rtl.queryIntfT($mod.o, $mod.IUnknown)));',
+    '      var $with1 = this.get();',
+    '      $mod.THelper.Fly.call(this, 123);',
+    '      $mod.THelper.Fly.call(this, 123);',
+    '    } finally {',
+    '      $ir.free();',
+    '    };',
+    '  };',
+    '  this.Run = function () {',
+    '    var l = null;',
+    '    try {',
+    '      $mod.THelper.Fly.call({',
+    '        get: function () {',
+    '            return l;',
+    '          },',
+    '        set: function (v) {',
+    '            l = rtl.setIntfL(l, v);',
+    '          }',
+    '      }, 123);',
+    '      $mod.THelper.Fly.call({',
+    '        get: function () {',
+    '            return l;',
+    '          },',
+    '        set: function (v) {',
+    '            l = rtl.setIntfL(l, v);',
+    '          }',
+    '      }, 123);',
+    '    } finally {',
+    '      rtl._Release(l);',
+    '    };',
+    '  };',
+    '});',
+    'this.i = null;',
+    'this.o = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.THelper.Fly.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.i;',
+    '    },',
+    '  set: function (v) {',
+    '      rtl.setIntfP(this.p, "i", v);',
+    '    }',
+    '}, 123);',
+    '$mod.THelper.Fly.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.i;',
+    '    },',
+    '  set: function (v) {',
+    '      rtl.setIntfP(this.p, "i", v);',
+    '    }',
+    '}, 123);',
+    '$mod.THelper.Run();',
+    '$mod.THelper.Run();',
+    '$mod.THelper.Run();',
+    '$mod.THelper.Run();',
+    '']));
+end;
+
 procedure TTestModule.TestProcType;
 begin
   StartProgram(false);

packages/pastojs/tests/tcprecompile.pas

@@ -137,6 +137,10 @@ begin
       if not CheckSrcDiff(OrigSrc,NewSrc,s) then
         begin
         WriteSources;
+        writeln('TCustomTestCLI_Precompile.CheckPrecompile OrigSrc==================');
+        writeln(OrigSrc);
+        writeln('TCustomTestCLI_Precompile.CheckPrecompile NewSrc==================');
+        writeln(NewSrc);
         Fail('test1.js: '+s);
         end;
       end;
@@ -392,11 +396,14 @@ begin
     '    constructor Create;',
     '  end;',
     '  TBird = class',
-    '    class constructor Init;',
+    '    class constructor InitBird;',
     '  end;',
     ''],[
     'constructor TObject.Create; begin end;',
-    'class constructor TBird.Init; begin end;',
+    'class constructor TBird.InitBird;',
+    'begin',
+    '  exit;',
+    'end;',
     '']);
   AddUnit('src/unit2.pp',[
     'uses unit1;',
@@ -598,5 +605,6 @@ end;
 
 Initialization
   RegisterTests([TTestCLI_Precompile]);
+  RegisterPCUFormat;
 end.
 

packages/pastojs/tests/tcunitsearch.pas

@@ -143,6 +143,7 @@ type
     procedure TestUS_Program_FU;
     procedure TestUS_Program_FU_o;
     procedure TestUS_Program_FE_o;
+    procedure TestUS_IncludeSameDir;
 
     procedure TestUS_UsesInFile;
     procedure TestUS_UsesInFile_Duplicate;
@@ -695,6 +696,27 @@ begin
   AssertNotNull('foo.js not found',FindFile('foo.js'));
 end;
 
+procedure TTestCLI_UnitSearch.TestUS_IncludeSameDir;
+begin
+  AddUnit('system.pp',[''],['']);
+  AddFile('sub/defines.inc',[
+    '{$Define foo}',
+    '']);
+  AddUnit('sub/unit1.pas',
+  ['{$I defines.inc}',
+   '{$ifdef foo}',
+   'var a: longint;',
+   '{$endif}'],
+  ['']);
+  AddFile('test1.pas',[
+    'uses unit1;',
+    'begin',
+    '  a:=3;',
+    'end.']);
+  AddDir('lib');
+  Compile(['test1.pas','-Fusub','-FElib','-ofoo.js']);
+end;
+
 procedure TTestCLI_UnitSearch.TestUS_UsesInFile;
 begin
   AddUnit('system.pp',[''],['']);

utils/pas2js/compileserver.pp

@@ -6,7 +6,6 @@ program compileserver;
 uses
   {$IFDEF UNIX}cthreads,{$ENDIF} httpcompiler;
 
-
 Var
   Application : THTTPCompilerApplication;
 

utils/pas2js/dist/rtl.js

@@ -26,6 +26,8 @@ var rtl = {
     if (rtl.version != v) throw "expected rtl version "+v+", but found "+rtl.version;
   },
 
+  hiInt: Math.pow(2,53),
+
   hasString: function(s){
     return rtl.isString(s) && (s.length>0);
   },
@@ -1065,6 +1067,47 @@ var rtl = {
     return 0;
   },
 
+  and: function(a,b){
+    var hi = 0x80000000;
+    var low = 0x7fffffff;
+    var h = (a / hi) & (b / hi);
+    var l = (a & low) & (b & low);
+    return h*hi + l;
+  },
+
+  or: function(a,b){
+    var hi = 0x80000000;
+    var low = 0x7fffffff;
+    var h = (a / hi) | (b / hi);
+    var l = (a & low) | (b & low);
+    return h*hi + l;
+  },
+
+  xor: function(a,b){
+    var hi = 0x80000000;
+    var low = 0x7fffffff;
+    var h = (a / hi) ^ (b / hi);
+    var l = (a & low) ^ (b & low);
+    return h*hi + l;
+  },
+
+  shr: function(a,b){
+    if (a<0) a += rtl.hiInt;
+    if (a<0x80000000) return a >> b;
+    if (b<=0) return a;
+    if (b>54) return 0;
+    return Math.floor(a / Math.pow(2,b));
+  },
+
+  shl: function(a,b){
+    if (a<0) a += rtl.hiInt;
+    if (b<=0) return a;
+    if (b>54) return 0;
+    var r = a * (2**b);
+    if (r <= rtl.hiInt) return r;
+    return r % rtl.hiInt;
+  },
+
   initRTTI: function(){
     if (rtl.debug_rtti) rtl.debug('initRTTI');
 

utils/pas2js/docs/translation.html

@@ -65,6 +65,7 @@
     <a href="#functiontype">Translating function types</a><br>
     <a href="#absolute">Translating var modifier absolute</a><br>
     <a href="#assert">Translating assert()</a><br>
+    <a href="#dispatch">Dispatch messages</a><br>
     <a href="#calljavascript">Calling JavaScript from Pascal</a><br>
     <a href="#asm">The asm block</a><br>
     <a href="#assembler">The procedure modifier assembler</a><br>
@@ -630,8 +631,8 @@ End.
       <tbody>
         <tr>
           <th>Pascal</th>
-          <th>JS Pas2js 1.2</th>
           <th>JS Pas2js 1.3</th>
+          <th>JS Pas2js 1.2</th>
         </tr>
         <tr>
           <td>
@@ -658,26 +659,26 @@ End.
 ["System"],
 function(){
   var $mod = this;
-  this.TMyRecord = function(s) {
-    if (s){
+  rtl.recNewT($mod, "TMyRecord", function() {
+    this.i = 0;
+    this.s = "";
+    this.d = 0.0;
+    this.$eq = function (b) {
+      return (this.i == b.i) &&
+         (this.s == b.i) && (this.d == b.d);
+    };
+    this.$assign = function (s) {
       this.i = s.i;
       this.s = s.s;
       this.d = s.d;
-    } else {
-      this.i = 0;
-      this.s = "";
-      this.d = 0.0;
-    };
-    this.$equal = function (b) {
-      return (this.i == b.i) &&
-        (this.s == b.i) && (this.d == b.d);
+      return this;
     };
   };
-  this.r = new this.TMyRecord();
+  this.r = this.TMyRecord.$new();
   $mod.$init = function() {
     $mod.r.i=123;
-    $mod.r = new $mod.TMyRecord($mod.s);
-    if ($mod.r.$equal($mod.s)) ;
+    $mod.r.$assign($mod.s);
+    if ($mod.r.$eq($mod.s)) ;
   },
 },
 []);
@@ -688,26 +689,26 @@ function(){
 ["System"],
 function(){
   var $mod = this;
-  rtl.recNewT($mod, "TMyRecord", function() {
-    this.i = 0;
-    this.s = "";
-    this.d = 0.0;
-    this.$eq = function (b) {
-      return (this.i == b.i) &&
-         (this.s == b.i) && (this.d == b.d);
-    };
-    this.$assign = function (s) {
+  this.TMyRecord = function(s) {
+    if (s){
       this.i = s.i;
       this.s = s.s;
       this.d = s.d;
-      return this;
+    } else {
+      this.i = 0;
+      this.s = "";
+      this.d = 0.0;
+    };
+    this.$equal = function (b) {
+      return (this.i == b.i) &&
+        (this.s == b.i) && (this.d == b.d);
     };
   };
-  this.r = this.TMyRecord.$new();
+  this.r = new this.TMyRecord();
   $mod.$init = function() {
     $mod.r.i=123;
-    $mod.r.$assign($mod.s);
-    if ($mod.r.$eq($mod.s)) ;
+    $mod.r = new $mod.TMyRecord($mod.s);
+    if ($mod.r.$equal($mod.s)) ;
   },
 },
 []);
@@ -745,7 +746,9 @@ function(){
         JS object. Since Pas2js 1.3 only values are copied,
         keeping the object, so pointer of record is compatible.</li>
       <li>Since record types are JS objects it is possible to typecast a record type
-      to the JS Object, e.g. TJSObject(TPoint)</li>
+      to the JS Object, e.g. <i>TJSObject(TPoint)</i>.
+      Note that you cannot typecast directly to a <i>TJSObject</i> descendant.
+      You can use <i>TJSWindow(TJSObject(aRecord))</i>.</li>
       <li>A pointer of record is simply a reference.
         <ul>
           <li><i>p:=@r</i> translates to <i>p=r</i></li>
@@ -754,6 +757,9 @@ function(){
           <li><i>Dispose(PointerOfRecord)</i> Sets the variable to null if possible.</li>
         </ul>
       </li>
+      <li>Passing a record to an untyped arguments (e.g. ''TObject.Dispatch(var Msg)'')
+        passes the record JS object directly, not creating a temporary reference object.</li>
+      <li>Typecasting RecordType(UntypedArgument) returns the argument, i.e. no conversion.</li>
     </ul>
     </div>
 
@@ -798,9 +804,9 @@ function(){
     <ul>
       <li>Local variables become local JavaScript variables: <i>var l = 0;</i>.</li>
       <li>Local constants become JavaScript variables in the unit/program implementation section.</li>
-      <li>Overloaded functions are given an unique name by appending $1, $2, ...<br>
-      Overloading is always on. You don't need to add the <i>overload</i> modifier.</li>
-      <li>Supported: default values, local types, FuncName:=</li>
+      <li>Local types are elevated to module.</li>
+      <li>Overloaded functions are given an unique name by appending $1, $2, ...</li>
+      <li>Supported: default values, const/var/out/default, FuncName:=</li>
     </ul>
     </div>
 
@@ -1612,7 +1618,8 @@ function(){
       <li>private, protected, public, strict private, strict protected</li>
       <li>class vars, const, nested types</li>
       <li>methods, class methods, class constructor, external methods</li>
-      <li>method modifiers overload, reintroduce, virtual, override, abstract, static, external name</li>
+      <li>method modifiers overload, reintroduce, virtual, override, abstract,
+      static, external name, message integer, message string</li>
       <li>call inherited</li>
       <li>assigned()</li>
       <li>type cast</li>
@@ -1817,7 +1824,8 @@ function(){
         <li>ClassType(IntfVar) - can be unrelated, nil if invalid</li>
         <li>IntfType(ObjVar) - nil if not found,
           COM: if ObjVar has delegate uses _AddRef</li>
-        <li>TJSObject(IntfTypeOrVar)</li>
+        <li>TJSObject(IntfTypeOrVar). Note that you cannot typecast directly
+        to a <i>TJSObject</i> descendant. You can use <i>TJSWindow(TJSObject(IntfType))</i>.</li>
         <li>jsvalue(intfvar)</li>
       </ul>
     <li>Assign operator:</li>
@@ -1868,7 +1876,7 @@ function(){
         If there are multiple helpers for the same type, the last helper in scope wins.<br>
         A class with ancestors can have one active helper per ancestor type, so
         multiple helpers can be active, same as FPC/Delphi.<br>
-        Using <b>{$modeswitch multiplescopehelpers}</b> you can activate all helpers
+        Using <b>{$modeswitch multihelpers}</b> you can activate all helpers
         within scope.
         </li>
       <li>Nested helpers (e.g. <i>TDemo.TSub.THelper</i>) are elevated.
@@ -2262,6 +2270,46 @@ End.
     </ul>
     </div>
 
+    <div class="section">
+    <h2 id="dispatch">Dispatch messages</h2>
+    The procedure modifier <b>message</b> and the <b>Dispatch</b> works
+    similar to FPC/Delphi, as it expects a record of a specific format and
+    <b><i>TObject.Dispatch</i></b> calls the corresponding method with that
+    message number or string.<br>
+    The procedure modifier <i>message &lt;integer&gt;</i> adds an entry to
+    hidden <i>YourClass.$msgint</i> object, while the modifier
+    <i>message &lt;string&gt;</i> adds an entry to the hidden
+    <i>YourClass.$msgstr</i> object.<br>
+    Two new directives <b><i>{$DispatchField fieldname}</i></b> and
+    <b><i>{$DispatchStrField fieldname}</i></b> were added. Insert these
+    directives in front of your class declaration to let the compiler check all
+    methods with message modifiers of this class and its descendants whether they
+    pass a record with the required field. For example:
+<pre>
+  {$DispatchField Msg} // enable checking message methods for record field name "Msg"
+  {$DispatchStrField MsgStr}
+  TObject = class
+    procedure Dispatch(var aMessage); virtual;
+    procedure DispatchStr(var aMessage); virtual;
+  end;
+  TMouseDownMsg = record
+    Id: integer; // Id instead of Msg, works in FPC, but not in pas2js
+    x,y: integer;
+  end;
+  TMouseUpMsg = record
+    MsgStr: string;
+    X,Y: integer;
+  end;
+  TWinControl = class
+    procedure MouseDownMsg(var Msg: TMouseDownMsg); message 3; // warning: Dispatch requires record field Msg
+    procedure MouseUpMsg(var Msg: TMouseUpMsg); message 'up'; // ok, record with string field name MsgStr
+  end;
+</pre>
+    Note that descendant classes can override the <i>$DispatchField</i> or
+    disable the check using <i>{$DispatchField -}</i>.
+    </div>
+
+
     <div class="section">
     <h2 id="calljavascript">Calling JavaScript from Pascal</h2>
     Pas2js allows to write low level functions and/or access a JavaScript library
@@ -2702,7 +2750,9 @@ End.
       call <i>aJSString.fromCharCode()</i>.</li>
       <li>An external class can descend from another external class.</li>
       <li>Since class types are JS objects it is possible to typecast a class type
-      to the JS Object, e.g. TJSObject(TObject)</li>
+      to the JS Object, e.g. <i>TJSObject(TObject)</i>.
+      Note that you cannot typecast directly to a <i>TJSObject</i> descendant
+      in $mode objfpc. You can use <i>TJSWindow(TJSObject(ExtClassInstance))</i>.</li>
       <li>You can typecast function addresses and function references to JS
       function, e.g. <i>TJSFunction(@SomeProc)</i>, <i>TJSFunction(OnClick)</i>.
       Keep in mind that typecasting a method address creates a function wrapper

utils/pas2js/httpcompiler.pp

@@ -6,9 +6,8 @@ unit httpcompiler;
 interface
 
 uses
-  sysutils, classes, fpjson, contnrs, syncobjs, custhttpapp, fpwebfile, httproute,
-  httpdefs, dirwatch,
-  Pas2JSFSCompiler, Pas2JSCompilerCfg;
+  sysutils, classes, fpjson, contnrs, syncobjs, fpmimetypes, custhttpapp,
+  fpwebfile, httproute, httpdefs, dirwatch, Pas2JSFSCompiler, Pas2JSCompilerCfg;
 
 Const
   nErrTooManyThreads = -1;
@@ -101,8 +100,10 @@ Type
     procedure DoRecompile(ARequest: TRequest; AResponse: TResponse);
     function ScheduleCompile(const aProjectFile: String; Options : TStrings = Nil): Integer;
     procedure StartWatch(ADir: String);
-    procedure Usage(Msg: String);
-    function GetDefaultMimetypes: string;
+  protected
+    procedure Usage(Msg: String); virtual;
+    function GetDefaultMimeTypesFile: string; virtual;
+    procedure LoadDefaultMimeTypes; virtual;
   public
     Constructor Create(AOWner : TComponent); override;
     Destructor Destroy; override;
@@ -262,13 +263,13 @@ begin
   Writeln('-q --quiet          Do not write diagnostic messages');
   Writeln('-w --watch          Watch directory for changes');
   Writeln('-c --compile[=proj] Recompile project if pascal files change. Default project is app.lpr');
-  Writeln('-m --mimetypes=file filename of mimetypes. Default is ',GetDefaultMimetypes);
+  Writeln('-m --mimetypes=file filename of mimetypes. Default is ',GetDefaultMimeTypesFile);
   Writeln('-s --simpleserver   Only serve files, do not enable compilation.');
   Halt(Ord(Msg<>''));
   {AllowWriteln-}
 end;
 
-function THTTPCompilerApplication.GetDefaultMimetypes: string;
+function THTTPCompilerApplication.GetDefaultMimeTypesFile: string;
 begin
   {$ifdef unix}
   Result:='/etc/mime.types';
@@ -281,6 +282,22 @@ begin
   {$endif}
 end;
 
+procedure THTTPCompilerApplication.LoadDefaultMimeTypes;
+begin
+  MimeTypes.AddType('application/xhtml+xml','xhtml;xht');
+  MimeTypes.AddType('text/html','html;htm');
+  MimeTypes.AddType('text/plain','txt');
+  MimeTypes.AddType('application/javascript','js');
+  MimeTypes.AddType('text/plain','map');
+  MimeTypes.AddType('application/json','json');
+  MimeTypes.AddType('image/png','png');
+  MimeTypes.AddType('image/jpeg','jpeg;jpg');
+  MimeTypes.AddType('image/gif','gif');
+  MimeTypes.AddType('image/jp2','jp2');
+  MimeTypes.AddType('image/tiff','tiff;tif');
+  MimeTypes.AddType('application/pdf','pdf');
+end;
+
 constructor THTTPCompilerApplication.Create(AOWner: TComponent);
 begin
   inherited Create(AOWner);
@@ -547,8 +564,15 @@ begin
   if HasOption('m','mimetypes') then
     MimeTypesFile:=GetOptionValue('m','mimetypes');
   if MimeTypesFile='' then
-    MimeTypesFile:=GetDefaultMimetypes;
-  if (MimeTypesFile<>'') and not FileExists(MimeTypesFile) then
+    begin
+    MimeTypesFile:=GetDefaultMimeTypesFile;
+    if not FileExists(MimeTypesFile) then
+      begin
+      MimeTypesFile:='';
+      LoadDefaultMimeTypes;
+      end;
+    end
+  else if not FileExists(MimeTypesFile) then
     Log(etWarning,'mimetypes file not found: '+MimeTypesFile);
   FBaseDir:=D;
   if not ServeOnly then