# revisions: 41707,41713,41714,41715,41719,41720,41732,41786,41787,41788,41792,41805,41806,41808,41809,41823,41824,41825,41840,41850,41851,41856,41862,41863,41864,41872,41876,41897,41931

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

packages/fcl-json/tests/testjson.lpi

@@ -1,26 +1,25 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
-  <ProjectOptions>
-    <Version Value="11"/>
+  <ProjectOptions BuildModesCount="1">
+    <Version Value="12"/>
     <General>
       <Flags>
         <SaveOnlyProjectUnits Value="True"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
         <LRSInOutputDirectory Value="False"/>
+        <CompatibilityMode Value="True"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
-      <MainUnit Value="0"/>
     </General>
-    <BuildModes Count="1">
+    <BuildModes>
       <Item1 Name="default" Default="True"/>
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
     </PublishOptions>
     <RunParams>
-      <local>
-        <CommandLineParams Value="--suite=TTestJSONString.TestJSONStringToString"/>
-        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
-      </local>
       <FormatVersion Value="2"/>
       <Modes Count="1">
         <Mode0 Name="default">

packages/fcl-passrc/src/pasresolveeval.pas

@@ -188,6 +188,7 @@ const
   nAttributeIgnoredBecauseAbstractX = 3122;
   nCreatingAnInstanceOfAbstractClassY = 3123;
   nIllegalExpressionAfterX = 3124;
+  nMethodHidesNonVirtualMethodExactly = 3125;
 
   // using same IDs as FPC
   nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@@ -323,6 +324,7 @@ resourcestring
   sAttributeIgnoredBecauseAbstractX = 'attribute ignored because abstract %s';
   sCreatingAnInstanceOfAbstractClassY = 'Creating an instance of abstract class "%s"';
   sIllegalExpressionAfterX = 'illegal expression after %s';
+  sMethodHidesNonVirtualMethodExactly = 'method hides identifier at "%s". Use reintroduce';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }

packages/fcl-passrc/src/pasresolver.pp

@@ -2,7 +2,7 @@
     This file is part of the Free Component Library
 
     Pascal resolver
-    Copyright (c) 2018  Mattias Gaertner  [email protected]
+    Copyright (c) 2019  Mattias Gaertner  [email protected]
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -1443,7 +1443,7 @@ type
       FindProcData: Pointer; var Abort: boolean); virtual;
     function IsSameProcContext(ProcParentA, ProcParentB: TPasElement): boolean;
     function FindProcSameSignature(const ProcName: string; Proc: TPasProcedure;
-      Scope: TPasScope): TPasProcedure;
+      Scope: TPasIdentifierScope; OnlyLocal: boolean): TPasProcedure;
   protected
     procedure SetCurrentParser(AValue: TPasParser); override;
     procedure ScannerWarnDirective(Sender: TObject; Identifier: string;
@@ -2024,7 +2024,7 @@ type
     function GetFunctionType(El: TPasElement): TPasFunctionType;
     function MethodIsStatic(El: TPasProcedure): boolean;
     function IsMethod(El: TPasProcedure): boolean;
-    function IsHelperMethod(El: TPasElement): boolean;
+    function IsHelperMethod(El: TPasElement): boolean; virtual;
     function IsHelper(El: TPasElement): boolean;
     function IsExternalClass_Name(aClass: TPasClassType; const ExtName: string): boolean;
     function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
@@ -4820,6 +4820,13 @@ begin
               else if (Proc is TPasConstructor)
                   and (Data^.Proc.ClassType=Proc.ClassType) then
                 // do not give a hint for hiding a constructor
+              else if Store then
+                begin
+                // method hides ancestor method with same signature
+                LogMsg(20190316152656,mtHint,
+                  nMethodHidesNonVirtualMethodExactly,sMethodHidesNonVirtualMethodExactly,
+                  [GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
+                end
               else
                 begin
                 //writeln('TPasResolver.OnFindProc Proc=',Proc.PathName,' Data^.Proc=',Data^.Proc.PathName,' ',Proc.Visibility);
@@ -4864,7 +4871,8 @@ begin
 end;
 
 function TPasResolver.FindProcSameSignature(const ProcName: string;
-  Proc: TPasProcedure; Scope: TPasScope): TPasProcedure;
+  Proc: TPasProcedure; Scope: TPasIdentifierScope; OnlyLocal: boolean
+  ): TPasProcedure;
 var
   FindData: TFindProcData;
   Abort: boolean;
@@ -4874,7 +4882,10 @@ begin
   FindData.Args:=Proc.ProcType.Args;
   FindData.Kind:=fpkSameSignature;
   Abort:=false;
-  Scope.IterateElements(ProcName,Scope,@OnFindProc,@FindData,Abort);
+  if OnlyLocal then
+    Scope.IterateLocalElements(ProcName,Scope,@OnFindProc,@FindData,Abort)
+  else
+    Scope.IterateElements(ProcName,Scope,@OnFindProc,@FindData,Abort);
   Result:=FindData.Found;
 end;
 
@@ -5853,7 +5864,7 @@ var
   DeclProc, Proc, ParentProc: TPasProcedure;
   Abort, HasDots, IsClassConDestructor: boolean;
   DeclProcScope, ProcScope: TPasProcedureScope;
-  ParentScope: TPasScope;
+  ParentScope: TPasIdentifierScope;
   pm: TProcedureModifier;
   ptm: TProcTypeModifier;
   ObjKind: TPasObjKind;
@@ -6093,13 +6104,15 @@ begin
     if (ProcName<>'') and ProcNeedsBody(Proc) then
       begin
       // check if there is a forward declaration
-      ParentScope:=GetParentLocalScope;
+      //writeln('TPasResolver.FinishProcedureType ',GetObjName(TopScope),' ',GetObjName(Scopes[ScopeCount-2]));
+      ParentScope:=GetParentLocalScope as TPasIdentifierScope;
       //writeln('TPasResolver.FinishProcedureType FindForward2 ParentScope=',GetObjName(ParentScope),'=',GetObjName(ParentScope.Element),' Proc=',GetObjName(Proc),' at ',GetElementSourcePosStr(Proc));
-      DeclProc:=FindProcSameSignature(ProcName,Proc,ParentScope);
+      DeclProc:=FindProcSameSignature(ProcName,Proc,ParentScope,true);
       //writeln('TPasResolver.FinishProcedureType FindForward3 DeclProc=',GetObjName(DeclProc),' Proc.Parent=',GetObjName(Proc.Parent));
+      //if DeclProc<>nil then writeln('TPasResolver.FinishProcedureType DeclProc at ',GetElementSourcePosStr(DeclProc));
       if (DeclProc=nil) and (Proc.Parent.ClassType=TImplementationSection) then
         DeclProc:=FindProcSameSignature(ProcName,Proc,
-          (Proc.GetModule.InterfaceSection.CustomData) as TPasScope);
+          (Proc.GetModule.InterfaceSection.CustomData) as TPasIdentifierScope,true);
       //writeln('TPasResolver.FinishProcedureType FindForward4 ',GetObjName(DeclProc),' at ',GetElementSourcePosStr(DeclProc));
       if (DeclProc<>nil) then
         begin
@@ -6326,7 +6339,7 @@ begin
   else if ImplProc.ClassType=TPasClassDestructor then
     DeclProc:=ClassOrRecScope.ClassDestructor
   else
-    DeclProc:=FindProcSameSignature(ProcName,ImplProc,ClassOrRecScope);
+    DeclProc:=FindProcSameSignature(ProcName,ImplProc,ClassOrRecScope,false);
   if DeclProc=nil then
     RaiseIdentifierNotFound(20170216151720,ImplProc.Name,ImplProc.ProcType);
   DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
@@ -8997,7 +9010,7 @@ begin
       exit;
     InhScope:=PushInheritedScope(TPasMembersType(AncestorScope.Element),true,nil);
     end;
-  AncestorProc:=FindProcSameSignature(DeclProc.Name,DeclProc,InhScope);
+  AncestorProc:=FindProcSameSignature(DeclProc.Name,DeclProc,InhScope,false);
   PopScope;
   if AncestorProc=nil then
     // 'inherited;' without ancestor DeclProc is silently ignored
@@ -9689,7 +9702,8 @@ begin
   if DeclEl is TPasProcedure then
     begin
     Proc:=TPasProcedure(DeclEl);
-    if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
+    if (Access=rraAssign)
+        and (Proc.ProcType is TPasFunctionType)
         and (Params.Parent.ClassType=TPasImplAssign)
         and (TPasImplAssign(Params.Parent).left=Params) then
       begin
@@ -9705,6 +9719,7 @@ begin
         end;
       end;
     end;
+
   ComputeElement(NameExpr,ResolvedEl,[rcSetReferenceFlags]);
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.ResolveArrayParamsExprName NameExp=',GetObjName(NameExpr),' ',GetResolverResultDbg(ResolvedEl));
@@ -9715,11 +9730,33 @@ end;
 procedure TPasResolver.ResolveArrayParamsArgs(Params: TParamsExpr;
   const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess);
 
+  procedure ReadAccessParamValue;
+  var
+    Left: TPasExpr;
+    Ref: TResolvedReference;
+  begin
+    if Access=rraAssign then
+      begin
+      // ArrayStringPointer[]:=
+      // -> writing the element needs reading the value
+      Left:=Params.Value;
+      if (Left is TBinaryExpr) and (TBinaryExpr(Left).OpCode=eopSubIdent) then
+        Left:=TBinaryExpr(Left).right;
+      if Left.CustomData is TResolvedReference then
+        begin
+        Ref:=TResolvedReference(Left.CustomData);
+        if Ref.Access=rraAssign then
+          Ref.Access:=rraReadAndAssign;
+        end;
+      end;
+  end;
+
   function CheckStringOrPointerIndex(IsStringIndex: boolean): boolean;
   var
     ArgExp: TPasExpr;
     ResolvedArg: TPasResolverResult;
   begin
+    ReadAccessParamValue;
     if not IsStringIndex then
       begin
       // pointer
@@ -9788,6 +9825,7 @@ begin
       if ResolvedValue.IdentEl is TPasType then
         RaiseMsg(20170216152215,nIllegalQualifierAfter,sIllegalQualifierAfter,
           ['[',ResolvedValue.IdentEl.ElementTypeName],Params);
+      ReadAccessParamValue;
       CheckCallArrayCompatibility(TPasArrayType(TypeEl),Params,true,true);
       for i:=0 to length(Params.Params)-1 do
         AccessExpr(Params.Params[i],rraRead);
@@ -10097,9 +10135,10 @@ begin
     pekArrayParams:
       begin
       ComputeElement(Params.Value,ValueResolved,[]);
-      if IsDynArray(ValueResolved.LoTypeEl,false) then
-        // an element of a dynamic array is independent of the array variable
-        // an element of an open array depends on the argument
+      if IsDynArray(ValueResolved.LoTypeEl,false)
+          or (ValueResolved.BaseType=btPointer) then
+        // when accessing an element of a dynamic array the array is read
+        AccessExpr(Params.Value,rraRead)
       else
         AccessExpr(Params.Value,Access);
       // Note: an element of an open or static array or a string is connected to the variable

packages/fcl-passrc/tests/tcresolver.pas

@@ -410,6 +410,7 @@ type
     Procedure TestProcOverloadBaseTypeOtherUnit;
     Procedure TestProcOverloadBaseProcNoHint;
     Procedure TestProcOverload_UnitOrderFail;
+    Procedure TestProcOverload_UnitSameSignature;
     Procedure TestProcOverloadDelphiMissingNextOverload;
     Procedure TestProcOverloadDelphiMissingPrevOverload;
     Procedure TestProcOverloadDelphiUnit;
@@ -639,6 +640,7 @@ type
     // external class
     Procedure TestExternalClass;
     Procedure TestExternalClass_Descendant;
+    Procedure TestExternalClass_HintMethodHidesNonVirtualMethodExact;
 
     // class of
     Procedure TestClassOf;
@@ -4649,7 +4651,6 @@ procedure TTestResolver.TestCAssignments;
 begin
   StartProgram(false);
   Parser.Options:=Parser.Options+[po_cassignments];
-  Scanner.Options:=Scanner.Options+[po_cassignments];
   Add('Type');
   Add('  TFlag = (Flag1,Flag2);');
   Add('  TFlags = set of TFlag;');
@@ -4830,7 +4831,6 @@ procedure TTestResolver.TestAssign_Access;
 begin
   StartProgram(false);
   Parser.Options:=Parser.Options+[po_cassignments];
-  Scanner.Options:=Scanner.Options+[po_cassignments];
   Add('var i: longint;');
   Add('begin');
   Add('  {#a1_assign}i:={#a2_read}i;');
@@ -6625,6 +6625,28 @@ begin
   CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
 end;
 
+procedure TTestResolver.TestProcOverload_UnitSameSignature;
+begin
+  AddModuleWithIntfImplSrc('unit1.pp',
+    LinesToStr([
+    'procedure Val(d: string);',
+    '']),
+    LinesToStr([
+    'procedure Val(d: string); begin end;',
+    '']));
+  StartProgram(true);
+  Add([
+  'uses unit1;',
+  'procedure Val(d: string);',
+  'begin',
+  'end;',
+  'var',
+  '  s: string;',
+  'begin',
+  '  Val(s);']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestProcOverloadDelphiMissingNextOverload;
 begin
   StartProgram(false);
@@ -11396,6 +11418,31 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestExternalClass_HintMethodHidesNonVirtualMethodExact;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSObject = class external name ''JSObject''',
+  '    procedure DoIt(p: pointer);',
+  '  end;',
+  '  TBird = class external name ''Bird''(TJSObject)',
+  '    procedure DoIt(p: pointer);',
+  '  end;',
+  'procedure TJSObject.DoIt(p: pointer);',
+  'begin',
+  '  if p=nil then ;',
+  'end;',
+  'procedure TBird.DoIt(p: pointer); begin end;',
+  'var b: TBird;',
+  'begin',
+  '  b.DoIt(nil);']);
+  ParseProgram;
+  CheckResolverHint(mtHint,nMethodHidesNonVirtualMethodExactly,
+   'method hides identifier at "afile.pp(5,19)". Use reintroduce');
+end;
+
 procedure TTestResolver.TestClassOf;
 begin
   StartProgram(false);
@@ -12967,7 +13014,8 @@ begin
   '  end;',
   'begin']);
   ParseProgram;
-  CheckResolverHint(mtHint,nFunctionHidesIdentifier_NonVirtualMethod,'function hides identifier at "afile.pp(4,19)". Use overload or reintroduce');
+  CheckResolverHint(mtHint,nMethodHidesNonVirtualMethodExactly,
+    'method hides identifier at "afile.pp(4,19)". Use reintroduce');
 end;
 
 procedure TTestResolver.TestClassInterface_OverloadNoHint;
@@ -14058,7 +14106,6 @@ end;
 procedure TTestResolver.TestArray_DynArrayConstObjFPC;
 begin
   Parser.Options:=Parser.Options+[po_cassignments];
-  Scanner.Options:=Scanner.Options+[po_cassignments];
   StartProgram(false);
   Add([
   '{$modeswitch arrayoperators}',

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -101,6 +101,8 @@ type
     procedure TestM_Hint_ParameterNotUsedTypecast;
     procedure TestM_Hint_OutParam_No_AssignedButNeverUsed;
     procedure TestM_Hint_ArgPassed_No_ParameterNotUsed;
+    procedure TestM_Hint_ArrayArg_No_ParameterNotUsed;
+    procedure TestM_Hint_ArrayArg_No_ParameterNotUsed2;
     procedure TestM_Hint_InheritedWithoutParams;
     procedure TestM_Hint_LocalVariableNotUsed;
     procedure TestM_HintsOff_LocalVariableNotUsed;
@@ -1607,6 +1609,42 @@ begin
   CheckUseAnalyzerUnexpectedHints;
 end;
 
+procedure TTestUseAnalyzer.TestM_Hint_ArrayArg_No_ParameterNotUsed;
+begin
+  StartProgram(false);
+  Add([
+  'type TArr = array of boolean;',
+  'procedure Fly(a: TArr);',
+  'begin',
+  '  a[1]:=true;',
+  'end;',
+  'begin',
+  '  Fly(nil);',
+  '']);
+  AnalyzeProgram;
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
+procedure TTestUseAnalyzer.TestM_Hint_ArrayArg_No_ParameterNotUsed2;
+begin
+  StartProgram(false);
+  Add([
+  'type {#Tarr_used}TArr = array of boolean;',
+  'procedure {#Run_used}Run({#b_used}b: boolean);',
+  'begin',
+  '  if b then ;',
+  'end;',
+  'procedure {#Fly_used}Fly({#a_used}a: TArr);',
+  'begin',
+  '  Run(a[1]);',
+  'end;',
+  'begin',
+  '  Fly(nil);',
+  '']);
+  AnalyzeProgram;
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 procedure TTestUseAnalyzer.TestM_Hint_InheritedWithoutParams;
 begin
   StartProgram(false);

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

@@ -717,7 +717,7 @@ begin
         TStringArray(AP)[I]:=AValue.Strings[i];
         end;
     else
-      Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
+      Raise ERESTAPI.CreateFmt('%s: unsupported array element type : %s',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
     end;
     end;
 end;
@@ -1041,7 +1041,7 @@ begin
     For I:=0 to Length(TStringArray(AP))-1 do
       A.Add(TJSONString.Create(TStringArray(AP)[I]));
   else
-    Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
+    Raise ERESTAPI.CreateFmt('%s: unsupported array element type : %s',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
   end;
 end;
 

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

@@ -65,6 +65,7 @@ Type
     Constructor Create(AOwner :TComponent); override;
     Destructor Destroy; override;
     class function ExtractUserNamePassword(Req: TRequest; out UN, PW: UTF8String): Boolean;
+    class function ExtractUserName(Req: TRequest) : UTF8String;
     Function NeedConnection : Boolean; override;
     function DoAuthenticateRequest(IO : TRestIO) : Boolean; override;
   Published
@@ -133,13 +134,14 @@ begin
   Result:=HaveAuthSQL and (AuthConnection=Nil);
 end;
 
-Function TRestBasicAuthenticator.HaveAuthSQL : Boolean;
+function TRestBasicAuthenticator.HaveAuthSQL: Boolean;
 
 begin
   Result:=(FAuthSQL.Count>0) and (Trim(FAuthSQL.Text)<>'');
 end;
 
-function TRestBasicAuthenticator.AuthenticateUserUsingSQl(IO : TRestIO; Const UN,PW : UTF8String; Out UID : UTF8String) : Boolean;
+function TRestBasicAuthenticator.AuthenticateUserUsingSQl(IO: TRestIO;
+  const UN, PW: UTF8String; out UID: UTF8String): Boolean;
 
 Var
   Conn : TSQLConnection;
@@ -179,7 +181,8 @@ begin
   end;
 end;
 
-Class Function TRestBasicAuthenticator.ExtractUserNamePassword(Req : TRequest; Out UN,PW : UTF8String) : Boolean;
+class function TRestBasicAuthenticator.ExtractUserNamePassword(Req: TRequest;
+  out UN, PW: UTF8String): Boolean;
 
 Var
   S,A : String;
@@ -204,7 +207,17 @@ begin
     end;
 end;
 
-function TRestBasicAuthenticator.DoAuthenticateRequest(io: TRestIO): Boolean;
+class function TRestBasicAuthenticator.ExtractUserName(Req: TRequest): UTF8String;
+
+Var
+  PW : UTF8String;
+
+begin
+  if not ExtractUserNamePassword(Req,Result,PW) then
+    Result:='?';
+end;
+
+function TRestBasicAuthenticator.DoAuthenticateRequest(IO: TRestIO): Boolean;
 
 Var
   UID,UN,PW : UTF8String;

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

@@ -19,14 +19,34 @@ unit sqldbrestbridge;
 interface
 
 uses
-  Classes, SysUtils, DB, SQLDB, httpdefs, httproute, fpjson, sqldbrestschema, sqldbrestio, sqldbrestdata, sqldbrestauth;
+  Classes, SysUtils, DB, SqlTypes, SQLDB, httpdefs, httproute, fpjson, sqldbrestschema, sqldbrestio, sqldbrestdata, sqldbrestauth;
 
 Type
-  TRestDispatcherOption = (rdoConnectionInURL,rdoExposeMetadata,rdoCustomView,rdoHandleCORS,rdoAccessCheckNeedsDB);
+  TRestDispatcherOption = (rdoConnectionInURL,     // Route includes connection :Connection/:Resource[/:ID]
+                           rdoExposeMetadata,      // expose metadata resource /metadata[/:Resource]
+                           rdoCustomView,          // Expose custom view /customview
+                           rdoHandleCORS,          // Handle CORS requests
+                           rdoAccessCheckNeedsDB,  // Authenticate after connection to database was made.
+                           rdoConnectionResource   // Enable connection managament through /_connection[/:Conn] resource
+                           // rdoServerInfo        // Enable querying server info through /_serverinfo  resource
+                           );
+
   TRestDispatcherOptions = set of TRestDispatcherOption;
+  TRestDispatcherLogOption = (rloUser,           // Include username in log messages, when available
+                              rtloHTTP,          // Log HTTP request (remote, URL)
+                              rloResource,       // Log resource requests (operation, resource)
+                              rloConnection,     // Log database connections (connect to database)
+                              rloAuthentication, // Log authentication attempt
+                              rloSQL,            // Log SQL statements. (not on user-supplied connection)
+                              rloResultStatus    // Log result status.
+                             );
+  TRestDispatcherLogOptions = Set of TRestDispatcherLogOption;
 
 Const
   DefaultDispatcherOptions = [rdoExposeMetadata];
+  AllDispatcherLogOptions = [Low(TRestDispatcherLogOption)..High(TRestDispatcherLogOption)];
+  DefaultDispatcherLogOptions = AllDispatcherLogOptions-[rloSQL];
+  DefaultLogSQLOptions = LogAllEvents;
 
 Type
 
@@ -45,6 +65,7 @@ Type
     FPassword: UTF8String;
     FPort: Word;
     FRole: UTF8String;
+    FSchemaName: UTF8String;
     FUserName: UTF8String;
     FNotifier : TComponent;
     function GetName: UTF8String;
@@ -52,6 +73,8 @@ Type
     procedure SetParams(AValue: TStrings);
   Protected
     Function GetDisplayName: string; override;
+    // For use in the REST Connection resource
+    Property SchemaName : UTF8String Read FSchemaName Write FSchemaName;
   Public
     constructor Create(ACollection: TCollection); override;
     Destructor Destroy; override;
@@ -92,9 +115,9 @@ Type
     procedure SetConn(aIndex : integer; AValue: TSQLDBRestConnection);
   Public
     // Index of connection by name (case insensitive)
-    Function IndexOfConnection(const aName : string) : Integer;
+    Function IndexOfConnection(const aName : UTF8string) : Integer;
     // Find connection by name (case insensitive), nil if none found
-    Function FindConnection(const aName : string) :  TSQLDBRestConnection;
+    Function FindConnection(const aName : UTF8string) :  TSQLDBRestConnection;
     // Add new instance, setting basic properties. Return new instance
     Function AddConnection(Const AType,aHostName,aDatabaseName,aUserName,aPassword : UTF8String) : TSQLDBRestConnection;
     // Save connection definitions to JSON file.
@@ -142,6 +165,7 @@ Type
     procedure SetSchema(aIndex : Integer; AValue: TSQLDBRestSchemaRef);
   Public
     Function AddSchema (aSchema : TSQLDBRestSchema) : TSQLDBRestSchemaRef;
+    Function IndexOfSchema(aSchemaName : String) : Integer;
     Property Schemas[aIndex :Integer] : TSQLDBRestSchemaRef Read GetSchema Write SetSchema;default;
   end;
 
@@ -155,20 +179,25 @@ Type
   TRestExceptionEvent = Procedure(Sender : TObject; aRequest : TRequest; Const AResource : string; E : Exception) of object;
   TRestOperationEvent = Procedure(Sender : TObject; aConn: TSQLConnection; aResource : TSQLDBRestResource) of object;
   TRestGetFormatEvent = Procedure(Sender : TObject; aRest : TRequest; var aFormat : String) of object;
+  TRestLogEvent = Procedure(Sender : TObject; aType : TRestDispatcherLogOption; Const aMessage : UTF8String) of object;
 
   TSQLDBRestDispatcher = Class(TComponent)
   Private
     Class Var FIOClass : TRestIOClass;
     Class Var FDBHandlerClass : TSQLDBRestDBHandlerClass;
   private
+    FAdminUserIDs: TStrings;
     FCORSAllowCredentials: Boolean;
     FCORSAllowedOrigins: String;
     FCORSMaxAge: Integer;
+    FDBLogOptions: TDBEventTypes;
     FDispatchOptions: TRestDispatcherOptions;
     FInputFormat: String;
     FCustomViewResource : TSQLDBRestResource;
+    FLogOptions: TRestDispatcherLogOptions;
     FMetadataResource : TSQLDBRestResource;
     FMetadataDetailResource : TSQLDBRestResource;
+    FConnectionResource : TSQLDBRestResource;
     FActive: Boolean;
     FAfterDelete: TRestOperationEvent;
     FAfterGet: TRestOperationEvent;
@@ -190,21 +219,35 @@ Type
     FOnGetConnectionName: TGetConnectionNameEvent;
     FOnGetInputFormat: TRestGetFormatEvent;
     FOnGetOutputFormat: TRestGetFormatEvent;
+    FOnLog: TRestLogEvent;
     FOutputFormat: String;
     FOutputOptions: TRestOutputoptions;
     FSchemas: TSQLDBRestSchemaList;
     FListRoute: THTTPRoute;
     FItemRoute: THTTPRoute;
+    FConnectionsRoute: THTTPRoute;
+    FConnectionItemRoute: THTTPRoute;
+    FMetadataRoute: THTTPRoute;
+    FMetadataItemRoute: THTTPRoute;
     FStatus: TRestStatusConfig;
     FStrings: TRestStringsConfig;
     procedure SetActive(AValue: Boolean);
+    procedure SetAdminUserIDS(AValue: TStrings);
     procedure SetAuthenticator(AValue: TRestAuthenticator);
     procedure SetConnections(AValue: TSQLDBRestConnectionList);
+    procedure SetDispatchOptions(AValue: TRestDispatcherOptions);
     procedure SetSchemas(AValue: TSQLDBRestSchemaList);
     procedure SetStatus(AValue: TRestStatusConfig);
     procedure SetStrings(AValue: TRestStringsConfig);
   Protected
+    // Logging
+    Function MustLog(aLog : TRestDispatcherLogOption) : Boolean; inline;
+    procedure DoSQLLog(Sender: TObject; EventType: TDBEventType;  const Msg: String); virtual;
+    procedure DoLog(aLog: TRestDispatcherLogOption; IO : TRestIO; const aMessage: UTF8String);  virtual;
+    procedure DoLog(aLog: TRestDispatcherLogOption; IO : TRestIO; const Fmt: UTF8String;
+      Args: array of const);
     // Auxiliary methods.
+    Procedure Loaded; override;
     Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
     function FindConnection(IO: TRestIO): TSQLDBRestConnection;
     // Factory methods. Override these to customize various helper classes.
@@ -222,6 +265,13 @@ Type
     function GetConnectionName(IO: TRestIO): UTF8String;
     function GetSQLConnection(aConnection: TSQLDBRestConnection; Out aTransaction : TSQLTransaction): TSQLConnection; virtual;
     procedure DoneSQLConnection(aConnection: TSQLDBRestConnection; AConn: TSQLConnection; aTransaction : TSQLTransaction); virtual;
+    // Connections dataset API
+    procedure ConnectionsToDataset(D: TDataset); virtual;
+    procedure DoConnectionDelete(DataSet: TDataSet); virtual;
+    procedure DoConnectionPost(DataSet: TDataSet);virtual;
+    procedure DatasetToConnection(D: TDataset; C: TSQLDBRestConnection); virtual;
+    procedure ConnectionToDataset(C: TSQLDBRestConnection; D: TDataset); virtual;
+    procedure DoConnectionResourceAllowed(aSender: TObject; aContext: TBaseRestContext; var allowResource: Boolean);
     // Error handling
     procedure CreateErrorContent(IO: TRestIO; aCode: Integer; AExtraMessage: UTF8String); virtual;
     procedure HandleException(E: Exception; IO: TRestIO); virtual;
@@ -245,8 +295,10 @@ Type
     // Special resources for Metadata handling
     function CreateMetadataDataset(IO: TRestIO; AOwner: TComponent): TDataset; virtual;
     function CreateMetadataDetailDataset(IO: TRestIO; Const aResourceName : String; AOwner: TComponent): TDataset; virtual;
+    function CreateConnectionDataset(IO: TRestIO; AOwner: TComponent): TDataset; virtual;
     function CreateMetadataDetailResource: TSQLDBRestResource;  virtual;
     function CreateMetadataResource: TSQLDBRestResource; virtual;
+    Function CreateConnectionResource : TSQLDBRestResource; virtual;
     // Custom view handling
     function CreateCustomViewResource: TSQLDBRestResource; virtual;
     function CreateCustomViewDataset(IO: TRestIO; const aSQL: String; AOwner: TComponent): TDataset;
@@ -266,6 +318,8 @@ Type
     Destructor Destroy; override;
     procedure RegisterRoutes;
     procedure UnRegisterRoutes;
+    procedure HandleMetadataRequest(aRequest : TRequest; aResponse : TResponse);
+    procedure HandleConnRequest(aRequest : TRequest; aResponse : TResponse);
     procedure HandleRequest(aRequest : TRequest; aResponse : TResponse);
     Function ExposeDatabase(Const aType,aHostName,aDatabaseName,aUserName,aPassword : String; aTables : Array of String; aMinFieldOpts : TRestFieldOptions = []) : TSQLDBRestConnection;
     Function ExposeDatabase(Const aType,aHostName,aDatabaseName,aUserName,aPassword : String; aTables : TStrings = nil; aMinFieldOpts : TRestFieldOptions = []) : TSQLDBRestConnection;
@@ -281,6 +335,8 @@ Type
     // Base URL
     property BasePath : UTF8String Read FBaseURL Write FBaseURL;
     // Default connection to use if none is detected from request/schema
+    // This connection will also be used to authenticate the user for connection API,
+    // so it must be set if you use SQL to authenticate the user.
     Property DefaultConnection : UTF8String Read FDefaultConnection Write FDefaultConnection;
     // Input/Output strings configuration
     Property Strings : TRestStringsConfig Read FStrings Write SetStrings;
@@ -293,7 +349,7 @@ Type
     // Set this to allow only this output format.
     Property OutputFormat : String Read FOutputFormat Write FOutputFormat;
     // Dispatcher options
-    Property DispatchOptions : TRestDispatcherOptions Read FDispatchOptions Write FDispatchOptions default DefaultDispatcherOptions;
+    Property DispatchOptions : TRestDispatcherOptions Read FDispatchOptions Write SetDispatchOptions default DefaultDispatcherOptions;
     // Authenticator for requests
     Property Authenticator : TRestAuthenticator Read FAuthenticator Write SetAuthenticator;
     // If >0, Enforce a limit on output results.
@@ -304,6 +360,12 @@ Type
     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;
+    // UserIDs of the user(s) that are allowed to see and modify the connection resource.
+    Property AdminUserIDs : TStrings Read FAdminUserIDs Write SetAdminUserIDS;
+    // Logging options
+    Property LogOptions : TRestDispatcherLogOptions Read FLogOptions write FLogOptions default DefaultDispatcherLogOptions;
+    // SQL Log options. Only for connections managed by RestDispatcher
+    Property LogSQLOptions : TDBEventTypes Read FDBLogOptions write FDBLogOptions default DefaultLogSQLOptions;
     // Called when Basic authentication is sufficient.
     Property OnBasicAuthentication : TBasicAuthenticationEvent Read FOnBasicAuthentication Write FOnBasicAuthentication;
     // Allow a particular resource or not.
@@ -334,9 +396,14 @@ Type
     Property BeforeDelete : TRestOperationEvent Read FBeforeDelete Write FBeforeDelete;
     // Called After a DELETE request.
     Property AfterDelete : TRestOperationEvent Read FAfterDelete Write FAfterDelete;
+    // Called when logging
+    Property OnLog : TRestLogEvent Read FOnLog Write FOnLog;
   end;
 
-
+Const
+  LogNames : Array[TRestDispatcherLogOption] of string = (
+    'User','HTTP','Resource','Connection','Authentication','SQL','Result'
+  );
 
 implementation
 
@@ -406,6 +473,13 @@ begin
   Result.Enabled:=True;
 end;
 
+function TSQLDBRestSchemaList.IndexOfSchema(aSchemaName: String): Integer;
+begin
+  Result:=Count-1;
+  While (Result>=0) and Not (Assigned(GetSchema(Result).Schema) and SameText(GetSchema(Result).Schema.Name,aSchemaName)) do
+    Dec(Result);
+end;
+
 { TSQLDBRestDispatcher }
 
 procedure TSQLDBRestDispatcher.SetConnections(AValue: TSQLDBRestConnectionList);
@@ -414,15 +488,40 @@ begin
   FConnections.Assign(AValue);
 end;
 
+procedure TSQLDBRestDispatcher.SetDispatchOptions(AValue: TRestDispatcherOptions);
+
+begin
+  if (rdoConnectionResource in aValue) then
+    Include(aValue,rdoConnectionInURL);
+  if FDispatchOptions=AValue then Exit;
+  FDispatchOptions:=AValue;
+end;
+
+procedure TSQLDBRestDispatcher.DoConnectionResourceAllowed(aSender: TObject;
+  aContext: TBaseRestContext; var allowResource: Boolean);
+begin
+  AllowResource:=(AdminUserIDs.Count=0) or  (AdminUserIDs.IndexOf(aContext.UserID)<>-1);
+end;
+
+
 procedure TSQLDBRestDispatcher.SetActive(AValue: Boolean);
 begin
-  if FActive=AValue then Exit;
-  if AValue then
-    DoRegisterRoutes
-  else
-    UnRegisterRoutes;
+  if FActive=AValue then
+    Exit;
+  if Not (csLoading in ComponentState) then
+    begin
+    if AValue then
+      DoRegisterRoutes
+    else
+      UnRegisterRoutes;
+    end;
   FActive:=AValue;
+end;
 
+procedure TSQLDBRestDispatcher.SetAdminUserIDS(AValue: TStrings);
+begin
+  if FAdminUserIDs=AValue then Exit;
+  FAdminUserIDs.Assign(AValue);
 end;
 
 procedure TSQLDBRestDispatcher.SetAuthenticator(AValue: TRestAuthenticator);
@@ -453,18 +552,133 @@ begin
   FStrings.Assign(AValue);
 end;
 
+function TSQLDBRestDispatcher.MustLog(aLog: TRestDispatcherLogOption): Boolean;
+begin
+  Result:=aLog in FLogOptions;
+end;
+
+procedure TSQLDBRestDispatcher.DoSQLLog(Sender: TObject;  EventType: TDBEventType; const Msg: String);
+
+Const
+  EventNames : Array [TDBEventType] of string =
+    ('Custom','Prepare', 'Execute', 'Fetch', 'Commit', 'RollBack', 'ParamValue', 'ActualSQL');
+
+Var
+  aMsg : UTF8String;
+
+begin
+  if not MustLog(rloSQl) then // avoid string ops
+    exit;
+  aMsg:=EventNames[EventType]+': '+Msg;
+  if Sender is TRestIO then
+    DoLog(rloSQL,TRestIO(Sender),aMsg)
+  else
+    DoLog(rloSQL,Nil,aMsg)
+end;
+
+procedure TSQLDBRestDispatcher.DoLog(aLog: TRestDispatcherLogOption; IO: TRestIO; const aMessage: UTF8String);
+
+Var
+  aMsg : UTF8String;
+
+begin
+  aMsg:='';
+  if MustLog(aLog) and Assigned(FOnLog) then
+     begin
+     if MustLog(rloUser) and Assigned(IO) then
+       begin
+       if IO.UserID='' then
+         aMsg:='(User: ?) '
+       else
+         aMsg:=Format('(User: %s) ',[IO.UserID]);
+       end;
+     aMsg:=aMsg+aMessage;
+     FOnLog(Self,aLog,aMsg);
+     end;
+end;
+
+procedure TSQLDBRestDispatcher.DoLog(aLog: TRestDispatcherLogOption;IO: TRestIO;
+  const Fmt: UTF8String; Args: array of const);
+
+Var
+  S : UTF8string;
+
+begin
+  if not MustLog(aLog) then exit; // avoid expensive format
+  try
+    S:=Format(fmt,Args); // Encode ?
+  except
+    on E : exception do
+      S:=Format('Error "%s" formatting "%s" with %d arguments: %s',[E.ClassName,Fmt,Length(Args),E.Message])
+  end;
+  DoLog(aLog,IO,S);
+end;
+
+procedure TSQLDBRestDispatcher.Loaded;
+begin
+  inherited Loaded;
+  if FActive then
+    RegisterRoutes;
+end;
+
+procedure TSQLDBRestDispatcher.HandleConnRequest(aRequest : TRequest; aResponse : TResponse);
+
+begin
+  aRequest.RouteParams['resource']:=Strings.ConnectionResourceName;
+  HandleRequest(aRequest,aResponse);
+end;
+
+procedure TSQLDBRestDispatcher.HandleMetadataRequest(aRequest: TRequest;aResponse: TResponse);
+
+Var
+  LogMsg,UN : UTF8String;
+
+begin
+  if MustLog(rtloHTTP) then
+    begin
+    LogMsg:='';
+    With aRequest do
+      begin
+      UN:=RemoteHost;
+      if (UN='') then
+        UN:=RemoteAddr;
+      if (UN<>'') then
+        LogMsg:='From: '+UN+'; ';
+      LogMsg:=LogMsg+'URL: '+URL;
+      end;
+    UN:=TRestBasicAuthenticator.ExtractUserName(aRequest);
+    if (UN<>'?') then
+      LogMsg:='User: '+UN+LogMsg;
+    DoLog(rtloHTTP,Nil,LogMsg);
+    end;
+  aRequest.RouteParams['resource']:=Strings.MetadataResourceName;
+  HandleRequest(aRequest,aResponse);
+end;
+
 procedure TSQLDBRestDispatcher.DoRegisterRoutes;
 
 Var
-  Res : String;
+  Res,C : UTF8String;
 
 begin
   Res:=IncludeHTTPPathDelimiter(BasePath);
-  if rdoConnectionInURL in DispatchOptions then
+  if (rdoConnectionResource in DispatchOptions) then
+    begin
+    C:=Strings.GetRestString(rpConnectionResourceName);
+    FConnectionsRoute:=HTTPRouter.RegisterRoute(res+C,@HandleConnRequest);
+    FConnectionItemRoute:=HTTPRouter.RegisterRoute(res+C+'/:id',@HandleConnRequest);
+    end;
+  if (rdoConnectionInURL in DispatchOptions) then
+    begin
+    C:=Strings.GetRestString(rpMetadataResourceName);
+    FMetadataRoute:=HTTPRouter.RegisterRoute(res+C,@HandleMetaDataRequest);
+    FMetadataItemRoute:=HTTPRouter.RegisterRoute(res+C+'/:id',@HandleMetaDataRequest);
     Res:=Res+':connection/';
+    end;
   Res:=Res+':resource';
   FListRoute:=HTTPRouter.RegisterRoute(res,@HandleRequest);
   FItemRoute:=HTTPRouter.RegisterRoute(Res+'/:id',@HandleRequest);
+
 end;
 
 function TSQLDBRestDispatcher.GetInputFormat(IO : TRestIO) : String;
@@ -630,17 +844,22 @@ begin
   FSchemas:=CreateSchemaList;
   FOutputOptions:=allOutputOptions;
   FDispatchOptions:=DefaultDispatcherOptions;
+  FLogOptions:=DefaultDispatcherLogOptions;
+  FDBLogOptions:=DefaultLogSQLOptions;
   FStatus:=CreateRestStatusConfig;
   FCORSMaxAge:=SecsPerDay;
   FCORSAllowCredentials:=True;
+  FAdminUserIDs:=TStringList.Create;
 end;
 
 destructor TSQLDBRestDispatcher.Destroy;
 begin
   Authenticator:=Nil;
+  FreeAndNil(FAdminUserIDs);
   FreeAndNil(FCustomViewResource);
   FreeAndNil(FMetadataResource);
   FreeAndNil(FMetadataDetailResource);
+  FreeAndNil(FConnectionResource);
   FreeAndNil(FSchemas);
   FreeAndNil(FConnections);
   FreeAndNil(FStrings);
@@ -681,7 +900,10 @@ function TSQLDBRestDispatcher.CreateCustomViewResource: TSQLDBRestResource;
 begin
   Result:=TCustomViewResource.Create(Nil);
   Result.ResourceName:=FStrings.GetRestString(rpCustomViewResourceName);
-  Result.AllowedOperations:=[roGet];
+  if rdoHandleCORS in DispatchOptions then
+    Result.AllowedOperations:=[roGet,roOptions,roHead]
+  else
+    Result.AllowedOperations:=[roGet,roHead];
 end;
 
 function TSQLDBRestDispatcher.CreateMetadataResource: TSQLDBRestResource;
@@ -692,13 +914,13 @@ Var
 
 begin
   Result:=TSQLDBRestResource.Create(Nil);
-  Result.ResourceName:='metaData';
+  Result.ResourceName:=Strings.GetRestString(rpMetadataResourceName);
   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]);
+  Result.Fields.AddField('name',rftString,[foRequired]).MaxLen:=255;
+  Result.Fields.AddField('schemaName',rftString,[foRequired]).MaxLen:=255;
   for O in TRestOperation do
     if O<>roUnknown then
       begin
@@ -708,6 +930,32 @@ begin
       end;
 end;
 
+function TSQLDBRestDispatcher.CreateConnectionResource: TSQLDBRestResource;
+Var
+  Def : TRestFieldOptions;
+
+begin
+  Def:=[foInInsert,foInUpdate,foFilter];
+  Result:=TSQLDBRestResource.Create(Nil);
+  Result.ResourceName:=Strings.GetRestString(rpConnectionResourceName);
+  Result.AllowedOperations:=[roGet,roPut,roPost,roDelete];
+  if rdoHandleCORS in DispatchOptions then
+    Result.AllowedOperations:=Result.AllowedOperations+[roOptions,roHead];
+  Result.Fields.AddField('name',rftString,Def+[foInKey,foRequired]);
+  Result.Fields.AddField('dbType',rftString,Def+[foRequired]);
+  Result.Fields.AddField('dbName',rftString,Def+[foRequired]);
+  Result.Fields.AddField('dbHostName',rftString,Def);
+  Result.Fields.AddField('dbUserName',rftString,Def);
+  Result.Fields.AddField('dbPassword',rftString,Def);
+  Result.Fields.AddField('dbCharSet',rftString,Def);
+  Result.Fields.AddField('dbRole',rftString,Def);
+  Result.Fields.AddField('dbPort',rftInteger,Def);
+  Result.Fields.AddField('enabled',rftBoolean,Def);
+  Result.Fields.AddField('expose',rftBoolean,Def);
+  Result.Fields.AddField('exposeSchemaName',rftString,Def);
+  Result.OnResourceAllowed:=@DoConnectionResourceAllowed;
+end;
+
 function TSQLDBRestDispatcher.CreateMetadataDetailResource: TSQLDBRestResource;
 
 Var
@@ -721,10 +969,10 @@ begin
     Result.AllowedOperations:=[roGet,roOptions,roHead]
   else
     Result.AllowedOperations:=[roGet,roHead];
-  Result.Fields.AddField('name',rftString,[]);
-  Result.Fields.AddField('type',rftString,[]);
+  Result.Fields.AddField('name',rftString,[]).MaxLen:=255;
+  Result.Fields.AddField('type',rftString,[]).MaxLen:=20;
   Result.Fields.AddField('maxlen',rftInteger,[]);
-  Result.Fields.AddField('format',rftString,[]);
+  Result.Fields.AddField('format',rftString,[]).MaxLen:=50;
   for O in TRestFieldOption do
     begin
     Str(O,S);
@@ -741,6 +989,7 @@ function TSQLDBRestDispatcher.FindSpecialResource(IO : TRestIO; aResource: UTF8S
     Result:=(rdoCustomView in DispatchOptions)
             and SameText(aResource,Strings.GetRestString(rpCustomViewResourceName));
   end;
+
   Function IsMetadata : Boolean;inline;
 
   begin
@@ -748,6 +997,13 @@ function TSQLDBRestDispatcher.FindSpecialResource(IO : TRestIO; aResource: UTF8S
             and SameText(aResource,Strings.GetRestString(rpMetaDataResourceName));
   end;
 
+  Function IsConnection : Boolean;inline;
+
+  begin
+    Result:=(rdoConnectionResource in DispatchOptions)
+            and SameText(aResource,Strings.GetRestString(rpConnectionResourceName));
+  end;
+
 Var
   N : UTF8String;
 
@@ -759,6 +1015,12 @@ begin
       FCustomViewResource:=CreateCustomViewResource;
     Result:=FCustomViewResource;
     end
+  else if IsConnection then
+    begin
+    if FConnectionResource=Nil then
+      FConnectionResource:=CreateConnectionResource;
+    Result:=FConnectionResource;
+    end
   else If isMetadata then
     if (IO.GetVariable('ID',N,[vsRoute,vsQuery])=vsNone) then
       begin
@@ -775,7 +1037,6 @@ begin
         Result:=FMetadataDetailResource;
         end;
       end
-
 end;
 
 function TSQLDBRestDispatcher.FindRestResource(aResource: UTF8String): TSQLDBRestResource;
@@ -872,6 +1133,10 @@ function TSQLDBRestDispatcher.GetSQLConnection(
   ): TSQLConnection;
 
 begin
+  Result:=Nil;
+  aTransaction:=Nil;
+  if aConnection=Nil then
+    exit;
   Result:=aConnection.SingleConnection;
   if (Result=Nil) then
     begin
@@ -973,6 +1238,7 @@ begin
   if not Result then exit;
   Result:=(aResource=FMetadataResource) or
           (aResource=FMetadataDetailResource) or
+          (aResource=FConnectionResource) or
           (aResource=FCustomViewResource);
 end;
 
@@ -1124,6 +1390,165 @@ begin
   end;
 end;
 
+procedure TSQLDBRestDispatcher.DatasetToConnection(D: TDataset; C : TSQLDBRestConnection);
+
+begin
+  C.Name:=UTF8Encode(D.FieldByName('name').AsWideString);
+  C.ConnectionType:=D.FieldByName('dbType').AsString;
+  C.DatabaseName:=UTF8Encode(D.FieldByName('dbName').AsWideString);
+  C.HostName:=D.FieldByName('dbHostName').AsString;
+  C.UserName:=UTF8Encode(D.FieldByName('dbUserName').AsWideString);
+  C.Password:=UTF8Encode(D.FieldByName('dbPassword').AsWideString);
+  C.CharSet:=D.FieldByName('dbCharSet').AsString;
+  C.Role:=D.FieldByName('dbRole').AsString;
+  C.Port:=D.FieldByName('dbPort').AsInteger;
+  C.Enabled:=D.FieldByName('enabled').AsBoolean;
+  if D.FieldByName('expose').AsBoolean then
+    C.SchemaName:=D.FieldByName('exposeSchemaName').AsString;
+end;
+
+procedure TSQLDBRestDispatcher.ConnectionToDataset(C : TSQLDBRestConnection;D: TDataset);
+
+begin
+  D.FieldByName('key').AsWideString:=UTF8Decode(C.Name);
+  D.FieldByName('name').AsWideString:=UTF8Decode(C.Name);
+  D.FieldByName('dbType').AsString:=C.ConnectionType;
+  D.FieldByName('dbName').AsWideString:=UTF8Decode(C.DatabaseName);
+  D.FieldByName('dbHostName').AsString:=C.HostName;
+  D.FieldByName('dbUserName').AsWideString:=UTF8Decode(C.UserName);
+  D.FieldByName('dbPassword').AsWideString:=UTF8Decode(C.Password);
+  D.FieldByName('dbCharSet').AsString:=C.CharSet;
+  D.FieldByName('dbRole').AsString:=C.Role;
+  D.FieldByName('dbPort').AsInteger:=C.Port;
+  D.FieldByName('enabled').AsBoolean:=C.Enabled;
+  D.FieldByName('expose').AsBoolean:=(C.SchemaName<>'');
+  D.FieldByName('exposeSchemaName').AsString:=C.SchemaName;
+end;
+
+procedure TSQLDBRestDispatcher.ConnectionsToDataset(D: TDataset);
+
+Var
+  C : TSQLDBRestConnection;
+  I : Integer;
+
+begin
+  For I:=0 to Connections.Count-1 do
+    begin
+    C:=Connections[i];
+    D.Append;
+    ConnectionToDataset(C,D);
+    D.Post;
+    end;
+end;
+
+procedure TSQLDBRestDispatcher.DoConnectionDelete(DataSet: TDataSet);
+
+Var
+  I,J : Integer;
+  C : TSQLDBRestConnection;
+
+
+begin
+  I:=Connections.IndexOfConnection(UTF8Encode(Dataset.FieldByName('name').AsWideString));
+  if I<>-1 then
+    begin
+    C:=Connections[i];
+    if C.SingleConnection<>Nil then
+      DoneSQLConnection(C,C.SingleConnection,Nil);
+    if C.SchemaName<>'' then
+      begin
+      J:=Schemas.IndexOfSchema(C.SchemaName);
+      if J<>-1 then
+        begin
+        Schemas[J].Schema.Free;
+        Schemas[J].Schema:=Nil;
+        end;
+      Schemas.Delete(J);
+      end;
+    Connections.Delete(I);
+    end
+  else
+    Raise ESQLDBRest.Create(404,'NOT FOUND');
+end;
+
+procedure TSQLDBRestDispatcher.DoConnectionPost(DataSet: TDataSet);
+
+Var
+  isNew : Boolean;
+  C : TSQLDBRestConnection;
+  N : UTF8String;
+  UN : UnicodeString;
+  S : TSQLDBRestSchema;
+
+begin
+  IsNew:=Dataset.State=dsInsert;
+  if IsNew then
+    C:=Connections.Add as TSQLDBRestConnection
+  else
+    begin
+    UN:=UTF8Decode(Dataset.FieldByName('key').AsString);
+//    C:=Connections[Dataset.RecNo-1];
+    C:=Connections.FindConnection(Utf8Encode(UN));
+    if (C=Nil) then
+      Raise ESQLDBRest.Create(404,'NOT FOUND');
+    end;
+  if Assigned(C.SingleConnection) then
+    DoneSQLConnection(C,C.SingleConnection,Nil);
+  DatasetToConnection(Dataset,C);
+  if (Dataset.FieldByName('expose').AsBoolean) and isNew then
+    begin
+    N:=C.SchemaName;
+    if N='' then
+      N:=C.Name+'schema';
+    if (Schemas.IndexOfSchema(N)<>-1) then
+      Raise ESQLDBRest.Create(400,'DUPLICATE SCHEMA');
+    try
+      S:=ExposeConnection(C,Nil);
+    except
+      if IsNew then
+        C.Free;
+      Raise;
+    end;
+    S.Name:=N;
+    end;
+end;
+
+function TSQLDBRestDispatcher.CreateConnectionDataset(IO: TRestIO; AOwner: TComponent): TDataset;
+Var
+  BD :  TRestBufDataset;
+
+begin
+  if IO=Nil then exit;
+  BD:=TRestBufDataset.Create(aOwner);
+  try
+    Result:=BD;
+    // Key field is not exposed
+    Result.FieldDefs.add('key',ftWidestring,255);
+    Result.FieldDefs.add('name',ftWidestring,255);
+    Result.FieldDefs.add('dbType',ftString,20);
+    Result.FieldDefs.add('dbName',ftWideString,255);
+    Result.FieldDefs.add('dbHostName',ftString,255);
+    Result.FieldDefs.add('dbUserName',ftWideString,255);
+    Result.FieldDefs.add('dbPassword',ftWideString,255);
+    Result.FieldDefs.add('dbCharSet',ftString,50);
+    Result.FieldDefs.add('dbRole',ftString,255);
+    Result.FieldDefs.add('dbPort',ftInteger,0);
+    Result.FieldDefs.add('enabled',ftBoolean,0);
+    Result.FieldDefs.add('expose',ftBoolean,0);
+    Result.FieldDefs.add('exposeSchemaName',ftWideString,255);
+    BD.CreateDataset;
+    ConnectionsToDataset(BD);
+    BD.IndexDefs.Add('uName','name',[ixUnique]);
+    BD.IndexName:='uName';
+    BD.First;
+    BD.BeforePost:=@DoConnectionPost;
+    BD.BeforeDelete:=@DoConnectionDelete;
+  except
+    BD.Free;
+    Raise;
+  end;
+end;
+
 function TSQLDBRestDispatcher.CreateCustomViewDataset(IO: TRestIO;
   const aSQL: String; AOwner: TComponent): TDataset;
 
@@ -1159,6 +1584,8 @@ begin
   Result:=Nil;
   if (IO.Resource=FMetadataResource) then
     Result:=CreateMetadataDataset(IO,AOwner)
+  else if (IO.Resource=FConnectionResource) then
+    Result:=CreateConnectionDataset(IO,AOwner)
   else if (IO.Resource=FMetadataDetailResource) then
     begin
     if IO.GetVariable('ID',RN,[vsRoute,vsQuery])=vsNone then
@@ -1220,12 +1647,25 @@ Var
   H : TSQLDBRestDBHandler;
   l,o : Int64;
 
+
 begin
+  if MustLog(rloResource) then
+    DoLog(rloResource,IO,'Resource: %s; Operation: %s',[IO.ResourceName,RestMethods[IO.Operation]]);
   H:=Nil;
   Conn:=GetSQLConnection(aConnection,Tr);
   try
     IO.SetConn(Conn,TR);
     Try
+      if MustLog(rloConnection) then
+         if Assigned(Conn)  then
+           DoLog(rloConnection,IO,'Using connection to Host: %s; Database: %s',[Conn.HostName,Conn.DatabaseName])
+         else
+           DoLog(rloConnection,IO,'Resource %s does not require connection',[IO.ResourceName]);
+      if assigned(Conn) and MustLog(rloSQL) then
+        begin
+        Conn.LogEvents:=LogSQLOptions;
+        Conn.OnLog:[email protected];
+        end;
       if (rdoHandleCORS in DispatchOptions) then
         IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins);
       if not AuthenticateRequest(IO,True) then
@@ -1243,7 +1683,8 @@ begin
         end;
       H.ExecuteOperation;
       DoHandleEvent(False,IO);
-      tr.Commit;
+      if Assigned(TR) then
+        TR.Commit;
       SetDefaultResponseCode(IO);
     except
       TR.RollBack;
@@ -1365,7 +1806,7 @@ begin
         begin
         IO.SetResource(Resource);
         Connection:=FindConnection(IO);
-        if Connection=Nil then
+        if (Connection=Nil) and not IsSpecialResource(Resource) then
           begin
           if (rdoConnectionInURL in DispatchOptions) then
             CreateErrorContent(IO,FStatus.GetStatusCode(rsNoConnectionSpecified),Format(SErrNoconnection,[GetConnectionName(IO)]))
@@ -1396,8 +1837,13 @@ procedure TSQLDBRestDispatcher.UnRegisterRoutes;
 begin
   Un(FListRoute);
   Un(FItemRoute);
+  Un(FConnectionItemRoute);
+  Un(FConnectionsRoute);
+  Un(FMetadataItemRoute);
+  Un(FMetadataRoute);
 end;
 
+
 procedure TSQLDBRestDispatcher.RegisterRoutes;
 begin
   if (FListRoute<>Nil) then
@@ -1456,6 +1902,7 @@ Var
   B : TRestBasicAuthenticator;
   A : TRestAuthenticator;
 
+
 begin
   A:=Nil;
   B:=Nil;
@@ -1473,7 +1920,14 @@ begin
       begin
       Result:=(A.NeedConnection<>Delayed);
       If Not Result then
-        Result:=A.AuthenticateRequest(IO)
+        begin
+        Result:=A.AuthenticateRequest(IO);
+        if MustLog(rloAuthentication) then
+          if Result then
+            DoLog(rloAuthentication,IO,'Authenticated user: %s',[IO.UserID])
+          else
+            DoLog(rloAuthentication,IO,'Authentication failed for user: %s',[TRestBasicAuthenticator.ExtractUserName(IO.Request)]);
+        end;
       end;
   finally
     if Assigned(B) then
@@ -1506,6 +1960,7 @@ begin
       // First output, then input
       IO.RestOutput.InitStreaming;
       IO.RestInput.InitStreaming;
+      IO.OnSQLLog:[email protected];
       if AuthenticateRequest(IO,False) then
         DoHandleRequest(IO)
     except
@@ -1513,12 +1968,19 @@ begin
         HandleException(E,IO);
     end;
   Finally
+    // Make sure there is a document in case of error
+    if (aResponse.ContentStream.Size=0) and Not ((aResponse.Code div 100)=2) then
+      IO.RESTOutput.CreateErrorContent(aResponse.Code,aResponse.CodeText);
     if Not (IO.Operation in [roOptions,roHEAD]) then
       IO.RestOutput.FinalizeOutput;
     aResponse.ContentStream.Position:=0;
     aResponse.ContentLength:=aResponse.ContentStream.Size;
+
     if not aResponse.ContentSent then
       aResponse.SendContent;
+    if MustLog(rloResultStatus) then
+        DoLog(rloResultStatus,IO,'Resource: %s; Operation: %s; Status: %d; Text: %s',[IO.ResourceName,RestMethods[IO.Operation],aResponse.Code,aResponse.CodeText]);
+
     IO.Free;
   end;
 end;
@@ -1651,7 +2113,7 @@ begin
   Items[aIndex]:=aValue;
 end;
 
-function TSQLDBRestConnectionList.IndexOfConnection(const aName: string
+function TSQLDBRestConnectionList.IndexOfConnection(const aName: UTF8string
   ): Integer;
 begin
   Result:=Count-1;
@@ -1659,7 +2121,7 @@ begin
     Dec(Result);
 end;
 
-function TSQLDBRestConnectionList.FindConnection(const aName: string): TSQLDBRestConnection;
+function TSQLDBRestConnectionList.FindConnection(const aName: UTF8string): TSQLDBRestConnection;
 Var
   Idx : Integer;
 
@@ -1849,6 +2311,8 @@ begin
     Role:=C.Role;
     DatabaseName:=C.DatabaseName;
     ConnectionType:=C.ConnectionType;
+    Port:=C.Port;
+    SchemaName:=C.SchemaName;
     Params.Assign(C.Params);
     end
   else

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

@@ -47,11 +47,14 @@ Type
     FResource : TSQLDBRestResource;
     FOwnsResource : Boolean;
     procedure SetExternalDataset(AValue: TDataset);
-    function StreamRecord(O: TRestOutputStreamer; D: TDataset; FieldList: TRestFieldPairArray): Boolean;
   Protected
+    function StreamRecord(O: TRestOutputStreamer; D: TDataset; FieldList: TRestFieldPairArray): Boolean; virtual;
+    function FindExistingRecord(D: TDataset): Boolean;
     procedure CreateResourceFromDataset(D: TDataset); virtual;
     procedure DoNotFound; virtual;
     procedure SetPostParams(aParams: TParams; Old : TFields = Nil);virtual;
+    procedure SetPostFields(aFields: TFields);virtual;
+    procedure SetFieldFromData(DataField: TField; ResField: TSQLDBRestField; D: TJSONData); virtual;
     procedure InsertNewRecord; virtual;
     procedure UpdateExistingRecord(OldData: TDataset); virtual;
     Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
@@ -81,7 +84,7 @@ Type
     Function GetLimitOffset(out aLimit, aOffset: Int64) : Boolean; virtual;
     Procedure Init(aIO: TRestIO; aStrings : TRestStringsConfig;AQueryClass : TSQLQueryClass); virtual;
     Procedure ExecuteOperation;
-    Function StreamDataset(O: TRestOutputStreamer; D: TDataset; FieldList: TRestFieldPairArray) : Int64;
+    Function StreamDataset(O: TRestOutputStreamer; D: TDataset; FieldList: TRestFieldPairArray; CurrentOnly : Boolean = False) : Int64;
     procedure SetParamFromData(P: TParam; F: TSQLDBRestField; D: TJSONData); virtual;
     function GetDataForParam(P: TParam; F: TSQLDBRestField; Sources : TVariableSources = AllVariableSources): TJSONData; virtual;
     Function GetString(aString : TRestStringProperty) : UTF8String;
@@ -98,7 +101,7 @@ Type
 
 implementation
 
-uses strutils, dateutils, base64, sqldbrestconst;
+uses strutils, variants, dateutils, base64, sqldbrestconst;
 
 
 Const
@@ -170,7 +173,8 @@ begin
     end;
 end;
 
-function TSQLDBRestDBHandler.GetWhere(Out FilteredFields : TRestFilterPairArray): UTF8String;
+function TSQLDBRestDBHandler.GetWhere(out FilteredFields: TRestFilterPairArray
+  ): UTF8String;
 
 Const
   MaxFilterCount = 1+ Ord(High(TRestFieldFilter)) - Ord(Low(TRestFieldFilter));
@@ -350,7 +354,8 @@ begin
   end;
 end;
 
-Function TSQLDBRestDBHandler.GetDataForParam(P : TParam; F : TSQLDBRestField; Sources : TVariableSources = AllVariableSources) : TJSONData;
+function TSQLDBRestDBHandler.GetDataForParam(P: TParam; F: TSQLDBRestField;
+  Sources: TVariableSources): TJSONData;
 
 Var
   vs : TVariableSource;
@@ -380,7 +385,8 @@ begin
     end;
 end;
 
-Procedure TSQLDBRestDBHandler.SetParamFromData(P : TParam; F : TSQLDBRestField; D : TJSONData);
+procedure TSQLDBRestDBHandler.SetParamFromData(P: TParam; F: TSQLDBRestField;
+  D: TJSONData);
 
 begin
   if not Assigned(D) then
@@ -408,7 +414,8 @@ begin
     P.AsString:=D.AsString;
 end;
 
-Function TSQLDBRestDBHandler.FindFieldForParam(aOperation : TRestOperation; P : TParam) : TSQLDBRestField;
+function TSQLDBRestDBHandler.FindFieldForParam(aOperation: TRestOperation;
+  P: TParam): TSQLDBRestField;
 
 Var
   N : UTF8String;
@@ -490,13 +497,14 @@ begin
     end;
 end;
 
-Function TSQLDBRestDBHandler.GetLimitOffset(Out aLimit,aOffset : Int64) : Boolean;
+function TSQLDBRestDBHandler.GetLimitOffset(out aLimit, aOffset: Int64
+  ): Boolean;
 
 begin
   Result:=IO.GetLimitOffset(EnforceLimit,aLimit,aoffset);
 end;
 
-Function TSQLDBRestDBHandler.GetLimit : UTF8String;
+function TSQLDBRestDBHandler.GetLimit: UTF8String;
 
 var
   aOffset, aLimit : Int64;
@@ -526,7 +534,8 @@ begin
 end;
 
 
-Function TSQLDBRestDBHandler.StreamRecord(O : TRestOutputStreamer; D : TDataset; FieldList : TRestFieldPairArray) : Boolean;
+function TSQLDBRestDBHandler.StreamRecord(O: TRestOutputStreamer; D: TDataset;
+  FieldList: TRestFieldPairArray): Boolean;
 
 Var
   i : Integer;
@@ -541,7 +550,8 @@ begin
   O.EndRow;
 end;
 
-Function TSQLDBRestDBHandler.StreamDataset(O : TRestOutputStreamer; D : TDataset; FieldList : TRestFieldPairArray) : Int64;
+function TSQLDBRestDBHandler.StreamDataset(O: TRestOutputStreamer; D: TDataset;
+  FieldList: TRestFieldPairArray; CurrentOnly : Boolean = False): Int64;
 
 Var
   aLimit,aOffset : Int64;
@@ -569,25 +579,31 @@ begin
   if O.HasOption(ooMetadata) then
     O.WriteMetadata(FieldList);
   O.StartData;
-  if EmulateOffsetLimit then
-    While (aOffset>0) and not D.EOF do
-      begin
-      D.Next;
-      Dec(aOffset);
-      end;
-  While not (D.EOF or LimitReached) do
+  if CurrentOnly then
+    StreamRecord(O,D,FieldList)
+  else
     begin
-    If StreamRecord(O,D,FieldList) then
+    if EmulateOffsetLimit then
+      While (aOffset>0) and not D.EOF do
+        begin
+        D.Next;
+        Dec(aOffset);
+        end;
+    While not (D.EOF or LimitReached) do
       begin
-      Dec(aLimit);
-      inc(Result);
+      If StreamRecord(O,D,FieldList) then
+        begin
+        Dec(aLimit);
+        inc(Result);
+        end;
+      D.Next;
       end;
-    D.Next;
     end;
   O.EndData;
 end;
 
-Function TSQLDBRestDBHandler.GetSpecialDatasetForResource(aFieldList : TRestFieldPairArray) :  TDataset;
+function TSQLDBRestDBHandler.GetSpecialDatasetForResource(
+  aFieldList: TRestFieldPairArray): TDataset;
 
 
 Var
@@ -612,7 +628,7 @@ begin
     FExternalDataset.FreeNotification(Self);
 end;
 
-Function TSQLDBRestDBHandler.SpecialResource : Boolean;
+function TSQLDBRestDBHandler.SpecialResource: Boolean;
 
 begin
   Result:=(ExternalDataset<>Nil) or Assigned(FResource.OnGetDataset);
@@ -637,6 +653,7 @@ begin
   SQL:=FResource.GetResolvedSQl(skSelect,aWhere,aOrderBy,aLimit);
   Q:=CreateQuery(SQL);
   Try
+    Q.UsePrimaryKeyAsKey:=False;
     FillParams(roGet,Q,WhereFilterList);
     Result:=Q;
   except
@@ -689,12 +706,76 @@ begin
   end;
 end;
 
-Function TSQLDBRestDBHandler.GetGeneratorValue(Const aGeneratorName : String) : Int64;
+function TSQLDBRestDBHandler.GetGeneratorValue(const aGeneratorName: String
+  ): Int64;
 
 begin
   Result:=IO.Connection.GetNextValue(aGeneratorName,1);
 end;
 
+procedure TSQLDBRestDBHandler.SetPostFields(aFields : TFields);
+
+Var
+  I : Integer;
+  FData : TField;
+  D : TJSONData;
+  RF : TSQLDBRestField;
+  V : UTF8string;
+
+begin
+  // Another approach would be to create params for all fields,
+  // call setPostParams, and copy field data from all set params
+  // That would allow the use of checkparams...
+  For I:=0 to aFields.Count-1 do
+    try
+      D:=Nil;
+      FData:=aFields[i];
+      RF:=FResource.Fields.FindByFieldName(FData.FieldName);
+      if (RF<>Nil) then
+        begin
+        if (RF.GeneratorName<>'')  then // Only when doing POST
+          D:=TJSONInt64Number.Create(GetGeneratorValue(RF.GeneratorName))
+        else
+          D:=IO.RESTInput.GetContentField(RF.PublicName);
+        end
+      else if IO.GetVariable(FData.Name,V,[vsContent,vsQuery])<>vsNone then
+        D:=TJSONString.Create(V);
+      if (D<>Nil) then
+        SetFieldFromData(FData,RF,D); // Use new value, if any
+    finally
+      D.Free;
+    end;
+end;
+
+procedure TSQLDBRestDBHandler.SetFieldFromData(DataField: TField; ResField: TSQLDBRestField; D: TJSONData);
+
+begin
+  if not Assigned(D) then
+    DataField.Clear
+  else if Assigned(ResField) then
+    Case ResField.FieldType of
+      rftInteger : DataField.AsInteger:=D.AsInteger;
+      rftLargeInt : DataField.AsLargeInt:=D.AsInt64;
+      rftFloat : DataField.AsFloat:=D.AsFloat;
+      rftDate : DataField.AsDateTime:=ScanDateTime(GetString(rpDateFormat),D.AsString);
+      rftTime : DataField.AsDateTime:=ScanDateTime(GetString(rpTimeFormat),D.AsString);
+      rftDateTime : DataField.AsDateTime:=ScanDateTime(GetString(rpDateTimeFormat),D.AsString);
+      rftString : DataField.AsString:=D.AsString;
+      rftBoolean : DataField.AsBoolean:=D.AsBoolean;
+      rftBlob :
+{$IFNDEF VER3_0}
+         DataField.AsBytes:=BytesOf(DecodeStringBase64(D.AsString));
+{$ELSE}
+         DataField.AsString:=DecodeStringBase64(D.AsString);
+{$ENDIF}
+    else
+      DataField.AsString:=D.AsString;
+    end
+  else
+    DataField.AsString:=D.AsString;
+end;
+
+
 procedure TSQLDBRestDBHandler.SetPostParams(aParams : TParams; Old : TFields = Nil);
 
 Var
@@ -712,7 +793,7 @@ begin
       FOld:=Nil;
       P:=aParams[i];
       F:=FResource.Fields.FindByFieldName(P.Name);
-      If Assigned(Fold) then
+      If Assigned(Old) then
         Fold:=Old.FindField(P.Name);
       if (F<>Nil) then
         begin
@@ -744,19 +825,33 @@ Var
   SQL : UTF8String;
 
 begin
-  SQL:=FResource.GetResolvedSQl(skInsert,'','','');
-  S:=TSQLStatement.Create(Self);
-  try
-    S.Database:=IO.Connection;
-    S.Transaction:=IO.Transaction;
-    S.SQL.Text:=SQL;
-    SetPostParams(S.Params);
-    S.Execute;
-    PostParams.Assign(S.Params);
-    S.Transaction.Commit;
-  Finally
-    S.Free;
-  end;
+  if Assigned(ExternalDataset) then
+    begin
+    ExternalDataset.Append;
+    SetPostFields(ExternalDataset.Fields);
+    try
+      ExternalDataset.Post;
+    except
+      ExternalDataset.Cancel;
+      Raise;
+    end
+    end
+  else
+    begin
+    SQL:=FResource.GetResolvedSQl(skInsert,'','','');
+    S:=TSQLStatement.Create(Self);
+    try
+      S.Database:=IO.Connection;
+      S.Transaction:=IO.Transaction;
+      S.SQL.Text:=SQL;
+      SetPostParams(S.Params);
+      S.Execute;
+      PostParams.Assign(S.Params);
+      S.Transaction.Commit;
+    Finally
+      S.Free;
+    end;
+    end;
 end;
 
 procedure TSQLDBRestDBHandler.DoHandlePost;
@@ -789,20 +884,68 @@ Var
   SQl : String;
 
 begin
-  SQL:=FResource.GetResolvedSQl(skUpdate,'','','');
-  S:=TSQLStatement.Create(Self);
-  try
-    S.Database:=IO.Connection;
-    S.Transaction:=IO.Transaction;
-    S.SQL.Text:=SQL;
-    SetPostParams(S.Params,OldData.Fields);
-    // Give user a chance to look at it.
-    FResource.CheckParams(io.RestContext,roPut,S.Params);
-    S.Execute;
-    S.Transaction.Commit;
-  finally
-    S.Free;
-  end;
+  if (OldData=ExternalDataset) then
+    begin
+    ExternalDataset.Edit;
+    try
+      SetPostFields(ExternalDataset.Fields);
+      ExternalDataset.Post;
+    except
+      ExternalDataset.Cancel;
+      Raise;
+    end
+    end
+  else
+    begin
+    SQL:=FResource.GetResolvedSQl(skUpdate,'','','');
+    S:=TSQLStatement.Create(Self);
+    try
+      S.Database:=IO.Connection;
+      S.Transaction:=IO.Transaction;
+      S.SQL.Text:=SQL;
+      SetPostParams(S.Params,OldData.Fields);
+      // Give user a chance to look at it.
+      FResource.CheckParams(io.RestContext,roPut,S.Params);
+      S.Execute;
+      S.Transaction.Commit;
+    finally
+      S.Free;
+    end;
+    end;
+end;
+
+Function TSQLDBRestDBHandler.FindExistingRecord(D : TDataset) : Boolean;
+
+Var
+  KeyFields : String;
+  FieldList : TRestFilterPairArray;
+  FP : TRestFilterPair;
+  V : Variant;
+  I : Integer;
+
+begin
+  D.Open;
+  if D<>ExternalDataset then
+    Result:=Not (D.BOF and D.EOF)
+  else
+    begin
+    GetIDWhere(FieldList);
+    V:=VarArrayCreate([0,Length(FieldList)-1],varVariant);
+    KeyFields:='';
+    I:=0;
+    For FP in FieldList do
+      begin
+      if KeyFields<>'' then
+        KeyFields:=KeyFields+';';
+      KeyFields:=KeyFields+FP.Field.FieldName;
+      if Assigned(FP.ValueParam) then
+        V[i]:=FP.ValueParam.Value
+      else
+        V[i]:=FP.Value;
+      Inc(i);
+      end;
+    Result:=D.Locate(KeyFields,V,[loCaseInsensitive]);
+    end;
 end;
 
 procedure TSQLDBRestDBHandler.DoHandlePut;
@@ -819,18 +962,20 @@ begin
   FieldList:=BuildFieldList(True);
   D:=GetDatasetForResource(FieldList,True);
   try
-    D.Open;
-    if (D.BOF and D.EOF) then
+    if not FindExistingRecord(D) then
       begin
       DoNotFound;
       exit;
       end;
     UpdateExistingRecord(D);
     // Now build response
-    FreeAndNil(D);
-    FieldList:=BuildFieldList(False);
-    D:=GetDatasetForResource(FieldList,True);
-    D.Open;
+    if D<>ExternalDataset then
+      begin;
+      FreeAndNil(D);
+      D:=GetDatasetForResource(FieldList,True);
+      FieldList:=BuildFieldList(False);
+      D.Open;
+      end;
     IO.RESTOutput.OutputOptions:=IO.RESTOutput.OutputOptions-[ooMetadata];
     StreamDataset(IO.RESTOutput,D,FieldList);
   finally
@@ -863,17 +1008,27 @@ Var
   FilteredFields : TRestFilterPairArray;
 
 begin
-  aWhere:=GetIDWhere(FilteredFields);
-  SQL:=FResource.GetResolvedSQl(skDelete,aWhere,'');
-  Q:=CreateQuery(SQL);
-  try
-    FillParams(roDelete,Q,FilteredFields);
-    Q.ExecSQL;
-    if Q.RowsAffected<>1 then
+  if Assigned(ExternalDataset) then
+    begin
+    If FindExistingRecord(ExternalDataset) then
+      ExternalDataset.Delete
+    else
       DoNotFound;
-  finally
-    Q.Free;
-  end;
+    end
+  else
+    begin
+    aWhere:=GetIDWhere(FilteredFields);
+    SQL:=FResource.GetResolvedSQl(skDelete,aWhere,'');
+    Q:=CreateQuery(SQL);
+    try
+      FillParams(roDelete,Q,FilteredFields);
+      Q.ExecSQL;
+      if Q.RowsAffected<>1 then
+        DoNotFound;
+    finally
+      Q.Free;
+    end;
+    end;
 end;
 
 end.

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

@@ -73,7 +73,8 @@ Type
                          rpOutputFormat,
                          rpCustomViewResourceName,
                          rpCustomViewSQLParam,
-                         rpXMLDocumentRoot
+                         rpXMLDocumentRoot,
+                         rpConnectionResourceName
                          );
   TRestStringProperties = Set of TRestStringProperty;
 
@@ -131,6 +132,7 @@ Type
     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;
+    Property ConnectionResourceName : UTF8string Index ord(rpConnectionResourceName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
   end;
 
   TRestStatus = (rsError,                   // Internal logic/unexpected error (500)
@@ -275,17 +277,18 @@ Type
   end;
 
   { TRestIO }
+  TSQLLogNotifyEvent = Procedure (Sender : TObject; EventType : TDBEventType; Const Msg : String) of object;
 
   TRestIO = Class
   private
     FConn: TSQLConnection;
     FCOnnection: UTF8String;
     FInput: TRestInputStreamer;
+    FOnSQLLog: TSQLLogNotifyEvent;
     FOperation: TRestOperation;
     FOutput: TRestOutputStreamer;
     FRequest: TRequest;
     FResource: TSQLDBRestResource;
-    FResourceName: UTF8String;
     FResponse: TResponse;
     FRestContext: TRestContext;
     FRestStatuses: TRestStatusConfig;
@@ -293,12 +296,15 @@ Type
     FSchema: UTF8String;
     FTrans: TSQLTransaction;
     FContentStream : TStream;
+    function GetResourceName: UTF8String;
     function GetUserID: String;
     procedure SetUserID(AValue: String);
   Protected
   Public
     Constructor Create(aRequest : TRequest; aResponse : TResponse); virtual;
     Destructor Destroy; override;
+    // Log callback for SQL. Rerouted here, because we need IO
+    procedure DoSQLLog(Sender: TSQLConnection;  EventType: TDBEventType; const Msg: String);
     // Set things.
     Procedure SetIO(aInput : TRestInputStreamer;aOutput : TRestOutputStreamer);
     Procedure SetConn(aConn : TSQLConnection; ATrans : TSQLTransaction);
@@ -332,10 +338,12 @@ Type
     Property RequestContentStream : TStream Read FContentStream;
     Property RestContext : TRestContext Read FRestContext;
     // For informative purposes
-    Property ResourceName : UTF8String Read FResourceName;
+    Property ResourceName : UTF8String Read GetResourceName;
     Property Schema : UTF8String Read FSchema;
     Property ConnectionName : UTF8String Read FCOnnection;
     Property UserID : String Read GetUserID Write SetUserID;
+    // For logging
+    Property OnSQLLog :TSQLLogNotifyEvent Read FOnSQLLog Write FOnSQLLog;
   end;
   TRestIOClass = Class of TRestIO;
 
@@ -430,7 +438,8 @@ Const
     'fmt',             { rpOutputFormat }
     'customview',      { rpCustomViewResourceName }
     'sql',             { rpCustomViewSQLParam }
-    'datapacket'       { rpXMLDocumentRoot}
+    'datapacket',      { rpXMLDocumentRoot}
+    '_connection'      { rpConnectionResourceName }
   );
   DefaultStatuses : Array[TRestStatus] of Word = (
     500, { rsError }
@@ -895,6 +904,14 @@ begin
   Result:=FRestContext.UserID;
 end;
 
+function TRestIO.GetResourceName: UTF8String;
+begin
+  if Assigned(FResource) then
+    Result:=FResource.ResourceName
+  else
+    Result:='?';
+end;
+
 constructor TRestIO.Create(aRequest: TRequest; aResponse: TResponse);
 begin
   FRequest:=aRequest;
@@ -917,6 +934,13 @@ begin
   inherited Destroy;
 end;
 
+procedure TRestIO.DoSQLLog(Sender: TSQLConnection; EventType: TDBEventType;  const Msg: String);
+
+begin
+  If Assigned(OnSQLLog) then
+    FOnSQLLog(Self,EventType,Msg);
+end;
+
 function TRestIO.CreateRestContext : TRestContext;
 
 begin

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

@@ -192,7 +192,7 @@ begin
   if FRow=Nil then
     Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]);
   D:=FieldToJSON(aPair);
-  if (D=Nil) and ((not HasOption(ooSparse)) or (FRow is TJSONArray)) then
+  if (D=Nil) and ((FRow is TJSONArray) or not HasOption(ooSparse)) then
     D:=TJSONNull.Create;
   if D<>Nil then
     If FRow is TJSONArray then

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

@@ -197,7 +197,7 @@ Type
     Function AllowResource(aContext : TBaseRestContext) : Boolean;
     Function GetAllowedOperations(aContext : TBaseRestContext) : TRestOperations;
     Function GetHTTPAllow : String; virtual;
-    function GetFieldList(aListKind: TFieldListKind): UTF8String;
+    function GetFieldList(aListKind: TFieldListKind; ASep : String = ''): 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);
@@ -332,6 +332,7 @@ Type
 
 Const
   TypeNames : Array[TRestFieldType] of string = ('?','int','bigint','float','date','time','datetime','string','bool','blob');
+  RestMethods : Array[TRestOperation] of string = ('','GET','POST','PUT','DELETE','OPTIONS','HEAD');
 
 implementation
 
@@ -1051,8 +1052,6 @@ function TSQLDBRestResource.GetHTTPAllow: String;
     Result:=Result+S;
   end;
 
-Const
-  Methods : Array[TRestOperation] of string = ('','GET','POST','PUT','DELETE','OPTIONS','HEAD');
 
 Var
   O : TRestOperation;
@@ -1061,10 +1060,10 @@ begin
   Result:='';
   For O in TRestOperation do
     if (O<>roUnknown) and (O in AllowedOperations) then
-      AddR(Methods[O]);
+      AddR(RestMethods[O]);
 end;
 
-function TSQLDBRestResource.GetFieldList(aListKind : TFieldListKind) : UTF8String;
+function TSQLDBRestResource.GetFieldList(aListKind : TFieldListKind; ASep : String = '') : UTF8String;
 
 Const
   SepComma = ', ';
@@ -1072,7 +1071,7 @@ Const
   SepSpace = ' ';
 
 Const
-  Seps : Array[TFieldListKind] of string = (sepComma,sepComma,sepComma,sepComma,sepAnd,sepSpace,sepComma);
+  DefaultSeps : Array[TFieldListKind] of string = (sepComma,sepComma,sepComma,sepComma,sepAnd,sepSpace,sepComma);
 
 Const
   Wheres = [flWhereKey];
@@ -1080,15 +1079,20 @@ Const
   UseEqual = Wheres+[flUpdate];
 
 Var
-  Term,Res,Prefix : UTF8String;
+  Sep,Term,Res,Prefix : UTF8String;
   I : Integer;
   F : TSQLDBRestField;
 
 begin
   Prefix:='';
+  Sep:=aSep;
+  if Sep='' then
+    begin
+    Sep:=DefaultSeps[aListKind];
+    If aListKind in Colons then
+      Prefix:=':';
+    end;
   Res:='';
-  If aListKind in Colons then
-    Prefix:=':';
   For I:=0 to Fields.Count-1 do
     begin
     Term:='';
@@ -1096,7 +1100,7 @@ begin
     if F.UseInFieldList(aListKind) then
       begin
       Term:=Prefix+F.FieldName;
-      if aListKind in UseEqual then
+      if (aSep='') and (aListKind in UseEqual) then
         begin
         Term := F.FieldName+' = '+Term;
         if (aListKind in Wheres) then
@@ -1106,7 +1110,7 @@ begin
     if (Term<>'') then
       begin
       If (Res<>'') then
-        Res:=Res+Seps[aListKind];
+        Res:=Res+Sep;
       Res:=Res+Term;
       end;
     end;

packages/pastojs/src/fppas2js.pp

@@ -1,6 +1,6 @@
 {
     This file is part of the Free Component Library (FCL)
-    Copyright (c) 2018 by Michael Van Canneyt
+    Copyright (c) 2019 by Michael Van Canneyt
 
     Pascal to Javascript converter class.
 
@@ -1455,6 +1455,8 @@ type
     function IsForInExtArray(Loop: TPasImplForLoop; const VarResolved,
       InResolved: TPasResolverResult; out ArgResolved, LengthResolved,
       PropResultResolved: TPasResolverResult): boolean;
+    function IsHelperMethod(El: TPasElement): boolean; override;
+    function IsHelperForMember(El: TPasElement): boolean;
   end;
 
 //------------------------------------------------------------------------------
@@ -2554,6 +2556,13 @@ var
     Result:=false;
   end;
 
+  procedure HandleEscape;
+  begin
+    inc(MyTokenPos);
+    if (MyTokenPos<=l) and (s[MyTokenPos]>#31) then
+      inc(MyTokenPos);
+  end;
+
 begin
   SetCurTokenString('');
   s:=CurLine;
@@ -2572,6 +2581,8 @@ begin
     if MyTokenPos>l then
       if DoEndOfLine then exit;
     case s[MyTokenPos] of
+    '\':
+      HandleEscape;
     '''':
       begin
       inc(MyTokenPos);
@@ -2579,6 +2590,8 @@ begin
         if MyTokenPos>l then
           Error(nErrOpenString,SErrOpenString);
         case s[MyTokenPos] of
+        '\':
+          HandleEscape;
         '''':
           begin
           inc(MyTokenPos);
@@ -2601,6 +2614,8 @@ begin
         if MyTokenPos>l then
           Error(nErrOpenString,SErrOpenString);
         case s[MyTokenPos] of
+        '\':
+          HandleEscape;
         '"':
           begin
           inc(MyTokenPos);
@@ -2616,6 +2631,32 @@ begin
         end;
       until false;
       end;
+    '`': // template literal
+      begin
+      inc(MyTokenPos);
+      repeat
+        while MyTokenPos>l do
+          if DoEndOfLine then
+            begin
+              writeln('AAA1 TPas2jsPasScanner.ReadNonPascalTillEndToken ',StopAtLineEnd);
+            if not StopAtLineEnd then
+              Error(nErrOpenString,SErrOpenString);
+            exit;
+            end;
+        case s[MyTokenPos] of
+        '\':
+          HandleEscape;
+        '`':
+          begin
+          inc(MyTokenPos);
+          break;
+          end;
+        // Note: template literals can span multiple lines
+        else
+          inc(MyTokenPos);
+        end;
+      until false;
+      end;
     '/':
       begin
       inc(MyTokenPos);
@@ -3189,6 +3230,13 @@ end;
 procedure TPas2JSResolver.AddRecordType(El: TPasRecordType);
 begin
   inherited;
+  if (El.Name='') and (El.Parent.ClassType<>TPasVariant) then
+    begin
+    {$IFDEF VerbosePas2JS}
+    writeln('TPas2JSResolver.AddRecordType ',GetObjName(El.Parent));
+    {$ENDIF}
+    RaiseNotYetImplemented(20190408224556,El,'anonymous record type');
+    end;
   if El.Parent is TProcedureBody then
     // local record
     AddElevatedLocal(El);
@@ -3987,19 +4035,25 @@ begin
                 RaiseMsg(20180329141108,nInvalidXModifierY,
                   sInvalidXModifierY,[Proc.ElementTypeName,ModifierNames[pm]],Proc);
             end;
-          okClassHelper:
+          okClassHelper,okRecordHelper,okTypeHelper:
             begin
             HelperForType:=ResolveAliasType(AClass.HelperForType);
-            if HelperForType.ClassType<>TPasClassType then
-              RaiseNotYetImplemented(20190201165157,El);
-            if TPasClassType(HelperForType).IsExternal then
+            if HelperForType.ClassType=TPasClassType then
               begin
-              // method of a class helper for external class
-              if IsClassMethod(El) and not (ptmStatic in El.Modifiers) then
-                RaiseMsg(20190201165259,nHelperClassMethodForExtClassMustBeStatic,
-                  sHelperClassMethodForExtClassMustBeStatic,[],El);
-              if El.ClassType=TPasConstructor then
-                RaiseNotYetImplemented(20190206153655,El);
+              if TPasClassType(HelperForType).IsExternal then
+                begin
+                // method of a class helper for external class
+                if IsClassMethod(El) and not (ptmStatic in El.Modifiers) then
+                  RaiseMsg(20190201165259,nHelperClassMethodForExtClassMustBeStatic,
+                    sHelperClassMethodForExtClassMustBeStatic,[],El);
+                if El.ClassType=TPasConstructor then
+                  RaiseNotYetImplemented(20190206153655,El);
+                end;
+              end;
+            if Proc.IsExternal then
+              begin
+              if not (HelperForType is TPasMembersType) then
+                RaiseMsg(20190314225457,nNotSupportedX,sNotSupportedX,['external method in type helper'],El);
               end;
             end;
           end;
@@ -5886,6 +5940,26 @@ begin
   CheckAssignResCompatibility(VarResolved,PropResultResolved,Loop.VariableName,true);
 end;
 
+function TPas2JSResolver.IsHelperMethod(El: TPasElement): boolean;
+begin
+  Result:=inherited IsHelperMethod(El);
+  if not Result then exit;
+  Result:=not TPasProcedure(El).IsExternal;
+end;
+
+function TPas2JSResolver.IsHelperForMember(El: TPasElement): boolean;
+begin
+  if (El=nil) or (El.Parent=nil) or (El.Parent.ClassType<>TPasClassType)
+      or (TPasClassType(El.Parent).HelperForType=nil) then
+    exit(false);
+  if El is TPasProcedure then
+    Result:=TPasProcedure(El).IsExternal
+  else if El is TPasVariable then
+    Result:=vmExternal in TPasVariable(El).VarModifiers
+  else
+    Result:=true;
+end;
+
 { TParamContext }
 
 constructor TParamContext.Create(PasEl: TPasElement; JSEl: TJSElement;
@@ -6555,15 +6629,17 @@ end;
 
 function TPasToJSConverter.CreateFreeOrNewInstanceExpr(Ref: TResolvedReference;
   AContext: TConvertContext): TJSCallExpression;
-// create "$create("funcname");"
+// class: create "$create("ProcName")"
+// record: create "$new().ProcName()"
 var
-  C: TJSCallExpression;
+  C, SubCall: TJSCallExpression;
   Proc: TPasProcedure;
   ProcScope: TPasProcedureScope;
   ClassRecScope: TPasClassOrRecordScope;
   ClassOrRec: TPasElement;
   ArgEx: TJSLiteral;
-  FunName: String;
+  FunName, ProcName: String;
+  DotExpr: TJSDotMemberExpression;
 begin
   Result:=nil;
   //writeln('TPasToJSConverter.CreateFreeOrNewInstanceExpr Ref.Declaration=',GetObjName(Ref.Declaration));
@@ -6579,16 +6655,33 @@ begin
     RaiseInconsistency(20170125191923,ClassOrRec);
   C:=CreateCallExpression(Ref.Element);
   try
-    // add "$create()"
-    if rrfNewInstance in Ref.Flags then
-      FunName:=GetBIName(pbifnClassInstanceNew)
+    ProcName:=TransformVariableName(Proc,AContext);
+    if ClassOrRec.ClassType=TPasRecordType then
+      begin
+      // create "path.$new()"
+      FunName:=CreateReferencePath(Proc,AContext,rpkPathWithDot,false,Ref)+GetBIName(pbifnRecordNew);
+      SubCall:=CreateCallExpression(Ref.Element);
+      SubCall.Expr:=CreatePrimitiveDotExpr(FunName,Ref.Element);
+      // append ".ProcName"
+      DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,Ref.Element));
+      DotExpr.MExpr:=SubCall;
+      DotExpr.Name:=TJSString(ProcName);
+      // as call: "path.$new().ProcName()"
+      C.Expr:=DotExpr;
+      end
     else
-      FunName:=GetBIName(pbifnClassInstanceFree);
-    FunName:=CreateReferencePath(Proc,AContext,rpkPathWithDot,false,Ref)+FunName;
-    C.Expr:=CreatePrimitiveDotExpr(FunName,Ref.Element);
-    // parameter: "funcname"
-    ArgEx := CreateLiteralString(Ref.Element,TransformVariableName(Proc,AContext));
-    C.AddArg(ArgEx);
+      begin
+      // add "$create()"
+      if rrfNewInstance in Ref.Flags then
+        FunName:=GetBIName(pbifnClassInstanceNew)
+      else
+        FunName:=GetBIName(pbifnClassInstanceFree);
+      FunName:=CreateReferencePath(Proc,AContext,rpkPathWithDot,false,Ref)+FunName;
+      C.Expr:=CreatePrimitiveDotExpr(FunName,Ref.Element);
+      // parameter: "ProcName"
+      ArgEx := CreateLiteralString(Ref.Element,ProcName);
+      C.AddArg(ArgEx);
+      end;
     Result:=C;
   finally
     if Result=nil then
@@ -7821,7 +7914,7 @@ begin
   else if aResolver.IsExternalClassConstructor(RightRefDecl) then
     begin
     // e.g. mod.ExtClass.new;
-    if El.Parent is TParamsExpr then
+    if (El.Parent is TParamsExpr) and (TParamsExpr(El.Parent).Value=El) then
       // Note: ExtClass.new() is handled in ConvertFuncParams
       RaiseNotSupported(El,AContext,20190116135818);
     Result:=ConvertExternalConstructor(El.left,RightRef,nil,AContext);
@@ -7896,7 +7989,8 @@ begin
   if aResolver.IsHelper(RightRefDecl.Parent) then
     begin
     // LeftJS.HelperMember
-    if RightRefDecl is TPasVariable then
+    if (RightRefDecl is TPasVariable)
+        and not (vmExternal in TPasVariable(RightRefDecl).VarModifiers) then
       begin
       // LeftJS.HelperField  -> HelperType.HelperField
       if Assigned(OnConvertRight) then
@@ -7907,7 +8001,10 @@ begin
       end
     else if RightRefDecl is TPasProcedure then
       begin
-      if rrfNoImplicitCallWithoutParams in RightRef.Flags then
+      Proc:=TPasProcedure(RightRefDecl);
+      if Proc.IsExternal then
+        // normal call
+      else if rrfNoImplicitCallWithoutParams in RightRef.Flags then
         begin
         Result:=CreateReferencePathExpr(RightRefDecl,AContext);
         exit;
@@ -7915,7 +8012,6 @@ begin
       else
         begin
         // call helper method
-        Proc:=TPasProcedure(RightRefDecl);
         Result:=CreateCallHelperMethod(Proc,El,AContext);
         exit;
         end;
@@ -8255,10 +8351,16 @@ begin
     if TargetProcType.Args.Count>0 then
       begin
       // add default parameters:
-      // insert array parameter [], e.g. this.TObject.$create("create",[])
-      ArrLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
-      CreateProcedureCallArgs(ArrLit.Elements,nil,TargetProcType,AContext);
-      Call.AddArg(ArrLit);
+      if Decl.Parent.ClassType=TPasRecordType then
+        // insert default parameters, e.g. TRecord.$new().create(1,2,3)
+        CreateProcedureCallArgs(Call.Args.Elements,nil,TargetProcType,AContext)
+      else
+        begin
+        // insert array parameter [], e.g. TObject.$create("create",[])
+        ArrLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
+        CreateProcedureCallArgs(ArrLit.Elements,nil,TargetProcType,AContext);
+        Call.AddArg(ArrLit);
+        end;
       end;
     exit;
     end;
@@ -8295,7 +8397,7 @@ begin
         Decl:=aResolver.GetPasPropertySetter(Prop);
         if Decl is TPasProcedure then
           begin
-          if aResolver.IsHelper(Decl.Parent) then
+          if aResolver.IsHelperMethod(Decl) then
             begin
             Result:=CreateCallHelperMethod(TPasProcedure(Decl),El,AContext);
             exit;
@@ -9620,7 +9722,8 @@ var
       end;
     if Call=nil then
       Call:=CreateFreeOrNewInstanceExpr(Ref,AContext);
-    if rrfNewInstance in Ref.Flags then
+    if (rrfNewInstance in Ref.Flags)
+        and (Ref.Declaration.Parent.ClassType=TPasClassType) then
       begin
       // insert array parameter [], e.g. this.TObject.$create("create",[])
       JsArrLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
@@ -9768,7 +9871,7 @@ begin
       end
     else if C.InheritsFrom(TPasProcedure) then
       begin
-      if aResolver.IsHelper(Decl.Parent) then
+      if aResolver.IsHelperMethod(Decl) then
         begin
         // calling a helper method
         Result:=CreateCallHelperMethod(TPasProcedure(Decl),El.Value,AContext);
@@ -16187,7 +16290,7 @@ begin
     Result:=CreateReferencePathExpr(Proc,AContext);
     exit;
     end;
-  IsHelper:=aResolver.IsHelper(Proc.Parent);
+  IsHelper:=aResolver.IsHelperMethod(Proc);
   NeedClass:=aResolver.IsClassMethod(Proc) and not aResolver.MethodIsStatic(Proc);
 
   // an of-object method -> create "rtl.createCallback(Target,func)"
@@ -16599,7 +16702,7 @@ begin
   if Decl is TPasFunction then
     begin
     // call function
-    if aResolver.IsHelper(Decl.Parent) then
+    if aResolver.IsHelperMethod(Decl) then
       begin
       if (Expr=nil) then
         // implicit property read, e.g. enumerator property Current
@@ -21304,9 +21407,16 @@ var
   begin
     if (Ref=nil) or (Ref.WithExprScope=nil) then exit(false);
     Parent:=El.Parent;
-    if (Parent<>nil) and (Parent.ClassType=TPasClassType)
+    if (Parent.ClassType=TPasClassType)
         and (TPasClassType(Parent).HelperForType<>nil) then
-      exit(false);
+      begin
+      // e.g. with Obj do HelperMethod
+      if aResolver.IsHelperForMember(El) then
+        // e.g. with Obj do HelperExternalMethod  -> Obj.HelperCall
+      else
+        // e.g. with Obj do HelperMethod  -> THelper.HelperCall
+        exit(false);
+      end;
     Result:=true;
   end;
 
@@ -21493,38 +21603,25 @@ begin
       begin
       ParentEl:=ImplToDecl(ParentEl);
 
+      IsClassRec:=(ParentEl.ClassType=TPasClassType)
+               or (ParentEl.ClassType=TPasRecordType);
+
       // check if ParentEl has a JS var
       ShortName:=AContext.GetLocalName(ParentEl);
       //writeln('TPasToJSConverter.CreateReferencePath El=',GetObjName(El),' ParentEl=',GetObjName(ParentEl),' ShortName=',ShortName);
 
-      IsClassRec:=(ParentEl.ClassType=TPasClassType)
-               or (ParentEl.ClassType=TPasRecordType);
-
-      if (ShortName<>'') and not IsClassRec then
-        begin
-        Prepend(Result,ShortName);
-        break;
-        end
-      else if ParentEl.ClassType=TImplementationSection then
-        begin
-        // element is in an implementation section (not program/library section)
-        // in other unit -> use pas.unitname.$impl
-        FoundModule:=El.GetModule;
-        if FoundModule=nil then
-          RaiseInconsistency(20161024192755,El);
-        Prepend(Result,TransformModuleName(FoundModule,true,AContext)
-           +'.'+GetBIName(pbivnImplementation));
-        break;
-        end
-      else if ParentEl is TPasModule then
-        begin
-        // element is in an unit interface or program/library section
-        Prepend(Result,TransformModuleName(TPasModule(ParentEl),true,AContext));
-        break;
-        end
-      else if IsClassRec then
+      if IsClassRec then
         begin
         // parent is a class or record declaration
+        if (ParentEl.ClassType=TPasClassType)
+            and (TPasClassType(ParentEl).HelperForType<>nil)
+            and aResolver.IsHelperForMember(El) then
+          begin
+          // redirect to helper-for-type
+          ParentEl:=aResolver.ResolveAliasType(TPasClassType(ParentEl).HelperForType);
+          ShortName:=AContext.GetLocalName(ParentEl);
+          end;
+
         if Full then
           Prepend(Result,ParentEl.Name)
         else
@@ -21541,8 +21638,10 @@ begin
             Prepend(Result,ParentEl.Name)
           else if (ParentEl.ClassType=TPasClassType)
               and (TPasClassType(ParentEl).HelperForType<>nil) then
+            begin
             // helpers have no self
-            Prepend(Result,ParentEl.Name)
+            Prepend(Result,ParentEl.Name);
+            end
           else if (SelfContext<>nil)
               and IsA(TPasType(SelfContext.ThisPas),TPasMembersType(ParentEl)) then
             begin
@@ -21575,6 +21674,28 @@ begin
             break;
           end;
         end
+      else if (ShortName<>'') then
+        begin
+        Prepend(Result,ShortName);
+        break;
+        end
+      else if ParentEl.ClassType=TImplementationSection then
+        begin
+        // element is in an implementation section (not program/library section)
+        // in other unit -> use pas.unitname.$impl
+        FoundModule:=El.GetModule;
+        if FoundModule=nil then
+          RaiseInconsistency(20161024192755,El);
+        Prepend(Result,TransformModuleName(FoundModule,true,AContext)
+           +'.'+GetBIName(pbivnImplementation));
+        break;
+        end
+      else if ParentEl is TPasModule then
+        begin
+        // element is in an unit interface or program/library section
+        Prepend(Result,TransformModuleName(TPasModule(ParentEl),true,AContext));
+        break;
+        end
       else if ParentEl.ClassType=TPasEnumType then
         begin
         if (ShortName<>'') and not Full then

packages/pastojs/src/pas2jscompiler.pp

@@ -1,4 +1,4 @@
-{ Author: Mattias Gaertner  2018  [email protected]
+{ Author: Mattias Gaertner  2019  [email protected]
 
 Abstract:
   TPas2jsCompiler is the wheel boss of the pas2js compiler.
@@ -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';
-  // was nMacroXSetToY = 138
+  nHandlingEnvOpts = 138; sHandlingEnvOpts = 'handling environment options %s';
   nPostProcessorInfoX = 139; sPostProcessorInfoX = 'Post processor: %s';
   nPostProcessorRunX = 140; sPostProcessorRunX = 'Run post processor: %s';
   nPostProcessorFailX = 141; sPostProcessorFailX = 'Post processor failed: %s';
@@ -549,6 +549,7 @@ type
     // params, cfg files
     FCurParam: string;
     procedure LoadConfig(CfgFilename: string);
+    procedure ReadEnvironment;
     procedure ReadParam(Param: string; Quick, FromCmdLine: boolean);
     procedure ReadSingleLetterOptions(const Param: string; p: integer;
       const Allowed: string; out Enabled, Disabled: string);
@@ -1673,30 +1674,211 @@ begin
   // if Result=nil resolver will give a nice error position, so don't do it here
 end;
 
-{ TPas2jsCompiler }
+{ TPas2JSConfigSupport }
 
-procedure TPas2jsCompiler.SetFS(AValue: TPas2jsFS);
+procedure TPas2JSConfigSupport.CfgSyntaxError(const Msg: string);
 begin
-  if FFS=AValue then Exit;
-  FOwnsFS:=false;
-  FFS:=AValue;
+  Compiler.Log.Log(mtError,Msg,0,CurrentCfgFilename,CurrentCfgLineNumber,0);
+  Compiler.Terminate(ExitCodeErrorInConfig);
 end;
 
-function TPas2jsCompiler.GetFileCount: integer;
+procedure TPas2JSConfigSupport.LoadConfig(Const aFileName: String);
+type
+  TSkip = (
+    skipNone,
+    skipIf,
+    skipElse
+  );
+const
+  IdentChars = ['a'..'z','A'..'Z','_','0'..'9'];
+var
+  Line: String;
+  l, p, StartP: integer;
+
+  function GetWord: String;
+  begin
+    StartP:=p;
+    while (p<=l) and ((Line[p] in IdentChars) or (Line[p]>#127)) do inc(p);
+    Result:=copy(Line,StartP,p-StartP);
+    while (p<=l) and (Line[p] in [' ',#9]) do inc(p);
+  end;
+
+  procedure DebugCfgDirective(const s: string);
+  begin
+    Compiler.Log.LogMsg(nCfgDirective,[QuoteStr(Line),s],CurrentCfgFilename,CurrentCfgLineNumber,1,false);
+  end;
+
+var
+  OldCfgFilename, Directive, aName, Expr: String;
+  aFile: TSourceLineReader;
+  IfLvl, SkipLvl, OldCfgLineNumber: Integer;
+  Skip: TSkip;
 begin
-  Result:=FFiles.Count;
+  if Compiler.ShowDebug or Compiler.ShowTriedUsedFiles then
+    Compiler.Log.LogMsgIgnoreFilter(nReadingOptionsFromFile,[QuoteStr(aFilename)]);
+  IfLvl:=0;
+  SkipLvl:=0;
+  Skip:=skipNone;
+  aFile:=nil;
+  try
+    OldCfgFilename:=FCurrentCfgFilename;
+    FCurrentCfgFilename:=aFilename;
+    OldCfgLineNumber:=FCurrentCfgLineNumber;
+    aFile:=GetReader(aFileName);
+    while not aFile.IsEOF do begin
+      Line:=aFile.ReadLine;
+      FCurrentCfgLineNumber:=aFile.LineNumber;
+      if Compiler.ShowDebug then
+        Compiler.Log.LogMsgIgnoreFilter(nInterpretingFileOption,[QuoteStr(Line)]);
+      if Line='' then continue;
+      l:=length(Line);
+      p:=1;
+      while (p<=l) and (Line[p] in [' ',#9]) do inc(p);
+      if p>l then continue; // empty line
+
+      if (p<=l) and (Line[p]='#') then
+      begin
+        // cfg directive
+        inc(p);
+        if (p>l) or (Line[p] in [#0,#9,' ','-']) then continue; // comment
+        Directive:=lowercase(GetWord);
+        case Directive of
+        'ifdef','ifndef':
+          begin
+            inc(IfLvl);
+            if Skip=skipNone then
+            begin
+              aName:=GetWord;
+              if Compiler.IsDefined(aName)=(Directive='ifdef') then
+              begin
+                // execute block
+                if Compiler.ShowDebug then
+                  DebugCfgDirective('true -> execute');
+              end else begin
+                // skip block
+                if Compiler.ShowDebug then
+                  DebugCfgDirective('false -> skip');
+                SkipLvl:=IfLvl;
+                Skip:=skipIf;
+              end;
+            end;
+          end;
+        'if':
+          begin
+            inc(IfLvl);
+            if Skip=skipNone then
+            begin
+              Expr:=copy(Line,p,length(Line));
+              if ConditionEvaluator.Eval(Expr) then
+              begin
+                // execute block
+                if Compiler.ShowDebug then
+                  DebugCfgDirective('true -> execute');
+              end else begin
+                // skip block
+                if Compiler.ShowDebug then
+                  DebugCfgDirective('false -> skip');
+                SkipLvl:=IfLvl;
+                Skip:=skipIf;
+              end;
+            end;
+          end;
+        'else':
+          begin
+            if IfLvl=0 then
+              CfgSyntaxError('"'+Directive+'" without #ifdef');
+            if (Skip=skipElse) and (IfLvl=SkipLvl) then
+              CfgSyntaxError('"there was already an #else');
+            if (Skip=skipIf) and (IfLvl=SkipLvl) then
+            begin
+              // if-block was skipped -> execute else block
+              if Compiler.ShowDebug then
+                DebugCfgDirective('execute');
+              SkipLvl:=0;
+              Skip:=skipNone;
+            end else if Skip=skipNone then
+            begin
+              // if-block was executed -> skip else block
+              if Compiler.ShowDebug then
+                DebugCfgDirective('skip');
+              Skip:=skipElse;
+              SkipLvl:=IfLvl;
+            end;
+          end;
+        'elseif':
+          begin
+            if IfLvl=0 then
+              CfgSyntaxError('"'+Directive+'" without #ifdef');
+            if (Skip=skipIf) and (IfLvl=SkipLvl) then
+            begin
+              // if-block was skipped -> try this elseif
+              Expr:=copy(Line,p,length(Line));
+              if ConditionEvaluator.Eval(Expr) then
+              begin
+                // execute elseif block
+                if Compiler.ShowDebug then
+                  DebugCfgDirective('true -> execute');
+                SkipLvl:=0;
+                Skip:=skipNone;
+              end else begin
+                // skip elseif block
+                if Compiler.ShowDebug then
+                  DebugCfgDirective('false -> skip');
+              end;
+            end else if Skip=skipNone then
+            begin
+              // if-block was executed -> skip without test
+              if Compiler.ShowDebug then
+                DebugCfgDirective('no test -> skip');
+              Skip:=skipIf;
+            end;
+          end;
+        'endif':
+          begin
+            if IfLvl=0 then
+              CfgSyntaxError('"'+Directive+'" without #ifdef');
+            dec(IfLvl);
+            if IfLvl<SkipLvl then
+            begin
+              // end block
+              if Compiler.ShowDebug then
+                DebugCfgDirective('end block');
+              SkipLvl:=0;
+              Skip:=skipNone;
+            end;
+          end;
+        'error':
+          Compiler.ParamFatal('user defined: '+copy(Line,p,length(Line)))
+        else
+          if Skip=skipNone then
+            CfgSyntaxError('unknown directive "#'+Directive+'"')
+          else
+            DebugCfgDirective('skipping unknown directive');
+        end;
+      end else if Skip=skipNone then
+      begin
+        // option line
+        Line:=copy(Line,p,length(Line));
+        Compiler.ReadParam(Line,false,false);
+      end;
+    end;
+  finally
+    FCurrentCfgFilename:=OldCfgFilename;
+    FCurrentCfgLineNumber:=OldCfgLineNumber;
+    aFile.Free;
+  end;
+  if Compiler.ShowDebug or Compiler.ShowTriedUsedFiles then
+    Compiler.Log.LogMsgIgnoreFilter(nEndOfReadingConfigFile,[QuoteStr(aFilename)]);
 end;
 
-function TPas2jsCompiler.GetDefaultNamespace: String;
+procedure TPas2JSConfigSupport.LoadDefaultConfig;
 var
-  C: TClass;
+  aFileName: string;
+
 begin
-  Result:='';
-  if FMainFile=nil then exit;
-  if FMainFile.PasModule=nil then exit;
-  C:=FMainFile.PasModule.ClassType;
-  if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
-    Result:=FMainFile.PascalResolver.DefaultNameSpace;
+  aFileName:=FindDefaultConfig;
+  if aFileName<>'' then
+    LoadConfig(aFilename);
 end;
 
 procedure TPas2JSConfigSupport.ConditionEvalLog(Sender: TCondDirectiveEvaluator;
@@ -1736,6 +1918,32 @@ begin
   Result:=false;
 end;
 
+{ TPas2jsCompiler }
+
+procedure TPas2jsCompiler.SetFS(AValue: TPas2jsFS);
+begin
+  if FFS=AValue then Exit;
+  FOwnsFS:=false;
+  FFS:=AValue;
+end;
+
+function TPas2jsCompiler.GetFileCount: integer;
+begin
+  Result:=FFiles.Count;
+end;
+
+function TPas2jsCompiler.GetDefaultNamespace: String;
+var
+  C: TClass;
+begin
+  Result:='';
+  if FMainFile=nil then exit;
+  if FMainFile.PasModule=nil then exit;
+  C:=FMainFile.PasModule.ClassType;
+  if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
+    Result:=FMainFile.PascalResolver.DefaultNameSpace;
+end;
+
 procedure TPas2jsCompiler.Compile(StartTime: TDateTime);
 var
   Checked: TPasAnalyzerKeySet;
@@ -2752,7 +2960,7 @@ begin
   r(mtInfo,nSrcMapBaseDirIs,sSrcMapBaseDirIs);
   r(mtFatal,nUnitFileNotFound,sUnitFileNotFound);
   r(mtInfo,nClassInterfaceStyleIs,sClassInterfaceStyleIs);
-  LastMsgNumber:=-1; ;// was nMacroXSetToY 138
+  r(mtInfo,nHandlingEnvOpts,sHandlingEnvOpts);
   r(mtInfo,nPostProcessorInfoX,sPostProcessorInfoX);
   r(mtInfo,nPostProcessorRunX,sPostProcessorRunX);
   r(mtError,nPostProcessorFailX,sPostProcessorFailX);
@@ -2762,215 +2970,29 @@ begin
   Pas2jsPParser.RegisterMessages(Log);
 end;
 
-procedure TPas2JSConfigSupport.CfgSyntaxError(const Msg: string);
-begin
-  Compiler.Log.Log(mtError,Msg,0,CurrentCfgFilename,CurrentCfgLineNumber,0);
-  Compiler.Terminate(ExitCodeErrorInConfig);
-end;
-
 procedure TPas2jsCompiler.LoadConfig(CfgFilename: string);
 begin
   ConfigSupport.LoadConfig(CfgFileName);
 end;
 
-procedure TPas2JSConfigSupport.LoadConfig(Const aFileName: String);
-type
-  TSkip = (
-    skipNone,
-    skipIf,
-    skipElse
-  );
-const
-  IdentChars = ['a'..'z','A'..'Z','_','0'..'9'];
+procedure TPas2jsCompiler.ReadEnvironment;
 var
-  Line: String;
-  l, p, StartP: integer;
-
-  function GetWord: String;
-  begin
-    StartP:=p;
-    while (p<=l) and ((Line[p] in IdentChars) or (Line[p]>#127)) do inc(p);
-    Result:=copy(Line,StartP,p-StartP);
-    while (p<=l) and (Line[p] in [' ',#9]) do inc(p);
-  end;
-
-  procedure DebugCfgDirective(const s: string);
-  begin
-    Compiler.Log.LogMsg(nCfgDirective,[QuoteStr(Line),s],CurrentCfgFilename,CurrentCfgLineNumber,1,false);
-  end;
-
-var
-  OldCfgFilename, Directive, aName, Expr: String;
-  aFile: TSourceLineReader;
-  IfLvl, SkipLvl, OldCfgLineNumber: Integer;
-  Skip: TSkip;
+  s: String;
+  List: TStrings;
 begin
-  if Compiler.ShowDebug or Compiler.ShowTriedUsedFiles then
-    Compiler.Log.LogMsgIgnoreFilter(nReadingOptionsFromFile,[QuoteStr(aFilename)]);
-  IfLvl:=0;
-  SkipLvl:=0;
-  Skip:=skipNone;
-  aFile:=nil;
+  s:=GetEnvironmentVariable('PAS2JS_OPTS');
+  if s='' then exit;
+  if ShowDebug then
+    Log.LogMsgIgnoreFilter(nHandlingEnvOpts,['PAS2JS_OPTS=['+s+']']);
+  List:=TStringList.Create;
   try
-    OldCfgFilename:=FCurrentCfgFilename;
-    FCurrentCfgFilename:=aFilename;
-    OldCfgLineNumber:=FCurrentCfgLineNumber;
-    aFile:=GetReader(aFileName);
-    while not aFile.IsEOF do begin
-      Line:=aFile.ReadLine;
-      FCurrentCfgLineNumber:=aFile.LineNumber;
-      if Compiler.ShowDebug then
-        Compiler.Log.LogMsgIgnoreFilter(nInterpretingFileOption,[QuoteStr(Line)]);
-      if Line='' then continue;
-      l:=length(Line);
-      p:=1;
-      while (p<=l) and (Line[p] in [' ',#9]) do inc(p);
-      if p>l then continue; // empty line
-
-      if (p<=l) and (Line[p]='#') then
-      begin
-        // cfg directive
-        inc(p);
-        if (p>l) or (Line[p] in [#0,#9,' ','-']) then continue; // comment
-        Directive:=lowercase(GetWord);
-        case Directive of
-        'ifdef','ifndef':
-          begin
-            inc(IfLvl);
-            if Skip=skipNone then
-            begin
-              aName:=GetWord;
-              if Compiler.IsDefined(aName)=(Directive='ifdef') then
-              begin
-                // execute block
-                if Compiler.ShowDebug then
-                  DebugCfgDirective('true -> execute');
-              end else begin
-                // skip block
-                if Compiler.ShowDebug then
-                  DebugCfgDirective('false -> skip');
-                SkipLvl:=IfLvl;
-                Skip:=skipIf;
-              end;
-            end;
-          end;
-        'if':
-          begin
-            inc(IfLvl);
-            if Skip=skipNone then
-            begin
-              Expr:=copy(Line,p,length(Line));
-              if ConditionEvaluator.Eval(Expr) then
-              begin
-                // execute block
-                if Compiler.ShowDebug then
-                  DebugCfgDirective('true -> execute');
-              end else begin
-                // skip block
-                if Compiler.ShowDebug then
-                  DebugCfgDirective('false -> skip');
-                SkipLvl:=IfLvl;
-                Skip:=skipIf;
-              end;
-            end;
-          end;
-        'else':
-          begin
-            if IfLvl=0 then
-              CfgSyntaxError('"'+Directive+'" without #ifdef');
-            if (Skip=skipElse) and (IfLvl=SkipLvl) then
-              CfgSyntaxError('"there was already an #else');
-            if (Skip=skipIf) and (IfLvl=SkipLvl) then
-            begin
-              // if-block was skipped -> execute else block
-              if Compiler.ShowDebug then
-                DebugCfgDirective('execute');
-              SkipLvl:=0;
-              Skip:=skipNone;
-            end else if Skip=skipNone then
-            begin
-              // if-block was executed -> skip else block
-              if Compiler.ShowDebug then
-                DebugCfgDirective('skip');
-              Skip:=skipElse;
-              SkipLvl:=IfLvl;
-            end;
-          end;
-        'elseif':
-          begin
-            if IfLvl=0 then
-              CfgSyntaxError('"'+Directive+'" without #ifdef');
-            if (Skip=skipIf) and (IfLvl=SkipLvl) then
-            begin
-              // if-block was skipped -> try this elseif
-              Expr:=copy(Line,p,length(Line));
-              if ConditionEvaluator.Eval(Expr) then
-              begin
-                // execute elseif block
-                if Compiler.ShowDebug then
-                  DebugCfgDirective('true -> execute');
-                SkipLvl:=0;
-                Skip:=skipNone;
-              end else begin
-                // skip elseif block
-                if Compiler.ShowDebug then
-                  DebugCfgDirective('false -> skip');
-              end;
-            end else if Skip=skipNone then
-            begin
-              // if-block was executed -> skip without test
-              if Compiler.ShowDebug then
-                DebugCfgDirective('no test -> skip');
-              Skip:=skipIf;
-            end;
-          end;
-        'endif':
-          begin
-            if IfLvl=0 then
-              CfgSyntaxError('"'+Directive+'" without #ifdef');
-            dec(IfLvl);
-            if IfLvl<SkipLvl then
-            begin
-              // end block
-              if Compiler.ShowDebug then
-                DebugCfgDirective('end block');
-              SkipLvl:=0;
-              Skip:=skipNone;
-            end;
-          end;
-        'error':
-          Compiler.ParamFatal('user defined: '+copy(Line,p,length(Line)))
-        else
-          if Skip=skipNone then
-            CfgSyntaxError('unknown directive "#'+Directive+'"')
-          else
-            DebugCfgDirective('skipping unknown directive');
-        end;
-      end else if Skip=skipNone then
-      begin
-        // option line
-        Line:=copy(Line,p,length(Line));
-        Compiler.ReadParam(Line,false,false);
-      end;
-    end;
+    SplitCmdLineParams(s,List);
+    for s in List do
+      if s<>'' then
+        ReadParam(s,false,false);
   finally
-    FCurrentCfgFilename:=OldCfgFilename;
-    FCurrentCfgLineNumber:=OldCfgLineNumber;
-    aFile.Free;
+    List.Free;
   end;
-  if Compiler.ShowDebug or Compiler.ShowTriedUsedFiles then
-    Compiler.Log.LogMsgIgnoreFilter(nEndOfReadingConfigFile,[QuoteStr(aFilename)]);
-end;
-
-procedure TPas2JSConfigSupport.LoadDefaultConfig;
-
-var
-  aFileName: string;
-
-begin
-  aFileName:=FindDefaultConfig;
-  if aFileName<>'' then
-    LoadConfig(aFilename);
 end;
 
 procedure TPas2jsCompiler.ParamFatal(Msg: string);
@@ -4068,6 +4090,9 @@ begin
     if Assigned(ConfigSupport) and not SkipDefaultConfig then
       ConfigSupport.LoadDefaultConfig;
 
+    // read env PAS2JS_OPTS
+    ReadEnvironment;
+
     // read command line parameters
     for i:=0 to ParamList.Count-1 do
       ReadParam(ParamList[i],false,true);
@@ -4313,6 +4338,8 @@ begin
   w('  -?     : Show this help');
   w('  -h     : Show this help');
   Log.LogLn;
+  w('Environment variable PAS2JS_OPTS is parsed after default config and before command line parameters.');
+  Log.LogLn;
   w('Macros: Format is $Name, $Name$ or $Name()');
   for i:=0 to ParamMacros.Count-1 do begin
     ParamMacro:=ParamMacros[i];

packages/pastojs/src/pas2jsfilecache.pp

@@ -1494,7 +1494,7 @@ procedure TPas2jsFilesCache.WriteFoldersAndSearchPaths;
 var
   i: Integer;
 begin
-  WriteFolder('working directory',GetCurrentDirPJ);
+  WriteFolder('working directory',BaseDirectory);
   for i:=0 to ForeignUnitPaths.Count-1 do
     WriteFolder('foreign unit path',ForeignUnitPaths[i]);
   for i:=0 to UnitPaths.Count-1 do
@@ -1915,6 +1915,7 @@ var
   i: Integer;
   aFilename: String;
 begin
+  //writeln('TPas2jsFilesCache.FindUnitFileName "',aUnitname,'" ModuleDir="',ModuleDir,'"');
   Result:='';
   IsForeign:=false;
   SearchedDirs:=TStringList.Create;

packages/pastojs/src/pas2jsfiler.pp

@@ -3465,7 +3465,7 @@ begin
   // AncestorScope can be derived from DirectAncestor
   // CanonicalClassOf is autogenerated
   CanonicalClassOf:=Scope.CanonicalClassOf;
-  if aClass.ObjKind=okClass then
+  if aClass.ObjKind in ([okClass]+okAllHelpers) then
     begin
     if CanonicalClassOf=nil then
       RaiseMsg(20180217143821,aClass);

packages/pastojs/src/pas2jsfs.pp

@@ -31,14 +31,15 @@ uses
   Classes, SysUtils, PScanner, fpjson;
 
 const // Messages
+  nUsingPath = 104; sUsingPath = 'Using %s: "%s"';
+  nFolderNotFound = 105; sFolderNotFound = '%s not found: %s';
+
   nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s';
   nUnitSearch = 202; sUnitSearch = 'Unitsearch: %s';
   nSearchingFileFound = 203; sSearchingFileFound = 'Searching file: %s... found';
   nSearchingFileNotFound = 204; sSearchingFileNotFound = 'Searching file: %s... not found';
   nDuplicateFileFound = 205; sDuplicateFileFound = 'Duplicate file found: "%s" and "%s"';
   nCustomJSFileNotFound = 206; sCustomJSFileNotFound = 'custom JS file not found: "%s"';
-  nUsingPath = 104; sUsingPath = 'Using %s: "%s"';
-  nFolderNotFound = 105; sFolderNotFound = '%s not found: %s';
 
 Type
   // Forward definitions

packages/pastojs/src/pas2jsuseanalyzer.pp

@@ -13,8 +13,13 @@
 
  **********************************************************************
 
-  Abstract:
-    Extends the FCL Pascal use analyzer for the language subset of pas2js.
+Abstract:
+  Extends the FCL Pascal use analyzer for the language subset of pas2js.
+
+Works:
+- Array of Const marks function System.VarRecs()
+- TPascalDescendantOfExt.Create marks class method NewInstance
+
 }
 unit Pas2jsUseAnalyzer;
 
@@ -35,6 +40,7 @@ type
   TPas2JSAnalyzer = class(TPasAnalyzer)
   public
     procedure UseExpr(El: TPasExpr); override;
+    procedure UseConstructor(Proc: TPasConstructor; PosEl: TPasElement); virtual;
   end;
 
 implementation
@@ -86,11 +92,35 @@ begin
     Ref:=TResolvedReference(El.CustomData);
     Decl:=Ref.Declaration;
     if Decl is TPasProcedure then
-      CheckArgs(TPasProcedure(Decl).ProcType.Args)
+      begin
+      CheckArgs(TPasProcedure(Decl).ProcType.Args);
+      if Decl.ClassType=TPasConstructor then
+        UseConstructor(TPasConstructor(Decl),El);
+      end
     else if Decl.ClassType=TPasProperty then
       CheckArgs(Resolver.GetPasPropertyArgs(TPasProperty(Decl)));
     end;
 end;
 
+procedure TPas2JSAnalyzer.UseConstructor(Proc: TPasConstructor;
+  PosEl: TPasElement);
+var
+  ClassScope: TPas2JSClassScope;
+begin
+  if Proc.Parent.ClassType=TPasClassType then
+    begin
+    ClassScope:=TPasClassType(Proc.Parent).CustomData as TPas2JSClassScope;
+    repeat
+      if ClassScope.NewInstanceFunction<>nil then
+        begin
+        UseProcedure(ClassScope.NewInstanceFunction);
+        break;
+        end;
+      ClassScope:=ClassScope.AncestorScope as TPas2JSClassScope;
+    until ClassScope=nil;
+    end;
+  if PosEl=nil then ;
+end;
+
 end.
 

packages/pastojs/tests/tcmodules.pas

@@ -461,6 +461,7 @@ type
     Procedure TestRecord_Const;
     Procedure TestRecord_TypecastFail;
     Procedure TestRecord_InFunction;
+    Procedure TestRecord_AnonymousFail;
     // ToDo: RTTI of local record
     // ToDo: pcu local record, name clash and rtti
 
@@ -680,6 +681,7 @@ type
     Procedure TestTypeHelper_ClassProperty;
     Procedure TestTypeHelper_ClassProperty_Array;
     Procedure TestTypeHelper_ClassMethod;
+    Procedure TestTypeHelper_ExtClassMethodFail;
     Procedure TestTypeHelper_Constructor;
     Procedure TestTypeHelper_Word;
     Procedure TestTypeHelper_Double;
@@ -3720,6 +3722,11 @@ begin
   '    // end',
   '    s = ''end'';',
   '    s = "end";',
+  '    s = "foo\"bar";',
+  '    s = ''a\''b'';',
+  '    s =  `${expr}\`-"-''-`;',
+  '    s = `multi',
+  'line`;',
   '  end;',
   'end;',
   'procedure Fly;',
@@ -3740,6 +3747,11 @@ begin
     '  // end',
     '  s = ''end'';',
     '  s = "end";',
+    '  s = "foo\"bar";',
+    '  s = ''a\''b'';',
+    '  s =  `${expr}\`-"-''-`;',
+    '  s = `multi',
+    'line`;',
     '  return Result;',
     '};',
     'this.Fly = function () {',
@@ -10600,6 +10612,18 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRecord_AnonymousFail;
+begin
+  StartProgram(false);
+  Add([
+  'var',
+  '  r: record x: word end;',
+  'begin']);
+  SetExpectedPasResolverError('not yet implemented: :TPasRecordType [20190408224556] anonymous record type',
+    nNotYetImplemented);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestAdvRecord_Function;
 begin
   StartProgram(false);
@@ -11207,6 +11231,7 @@ begin
   'var r: TPoint;',
   'begin',
   '  r:=TPoint.Create(1,2);',
+  '  with TPoint do r:=Create(1,2);',
   '  r.Create(3);',
   '  r:=r.Create(4);',
   '']);
@@ -11233,7 +11258,9 @@ begin
     'this.r = $mod.TPoint.$new();',
     '']),
     LinesToStr([ // $mod.$main
-    '$mod.r.$assign($mod.TPoint.$create("Create", [1, 2]));',
+    '$mod.r.$assign($mod.TPoint.$new().Create(1, 2));',
+    'var $with1 = $mod.TPoint;',
+    '$mod.r.$assign($with1.$new().Create(1, 2));',
     '$mod.r.Create(3, -1);',
     '$mod.r.$assign($mod.r.Create(4, -1));',
     '']));
@@ -16018,6 +16045,7 @@ begin
   Add('  A: texta;');
   Add('begin');
   Add('  a:=texta.new;');
+  Add('  a:=texta(texta.new);');
   Add('  a:=texta.new();');
   Add('  a:=texta.new(1);');
   Add('  with texta do begin');
@@ -16036,6 +16064,7 @@ begin
     LinesToStr([ // $mod.$main
     '$mod.A = new ExtA();',
     '$mod.A = new ExtA();',
+    '$mod.A = new ExtA();',
     '$mod.A = new ExtA(1,2);',
     '$mod.A = new ExtA();',
     '$mod.A = new ExtA();',
@@ -21197,12 +21226,15 @@ begin
   Add([
   '{$modeswitch externalclass}',
   'type',
+  '  TFly = function(w: word): word of object;',
   '  TExtA = class external name ''ExtObj''',
   '    procedure Run(w: word = 10);',
   '  end;',
   '  THelper = class helper for TExtA',
   '    function Foo(w: word = 1): word;',
+  '    function Fly(w: word = 2): word; external name ''Fly'';',
   '  end;',
+  'var p: TFly;',
   'function THelper.foo(w: word): word;',
   'begin',
   '  Run;',
@@ -21214,22 +21246,32 @@ begin
   '  Self.Foo;',
   '  Self.Foo();',
   '  Self.Foo(13);',
+  '  Fly;',
+  '  Fly();',
   '  with Self do begin',
   '    Foo;',
   '    Foo();',
   '    Foo(14);',
+  '    Fly;',
+  '    Fly();',
   '  end;',
+  '  p:=@Fly;',
   'end;',
   'var Obj: TExtA;',
   'begin',
   '  obj.Foo;',
   '  obj.Foo();',
   '  obj.Foo(21);',
+  '  obj.Fly;',
+  '  obj.Fly();',
   '  with obj do begin',
   '    Foo;',
   '    Foo();',
   '    Foo(22);',
+  '    Fly;',
+  '    Fly();',
   '  end;',
+  '  p:[email protected];',
   '']);
   ConvertProgram;
   CheckSource('TestExtClassHelper_Method_Call',
@@ -21246,22 +21288,33 @@ begin
     '    $mod.THelper.Foo.call(this, 1);',
     '    $mod.THelper.Foo.call(this, 1);',
     '    $mod.THelper.Foo.call(this, 13);',
+    '    this.Fly(2);',
+    '    this.Fly(2);',
     '    $mod.THelper.Foo.call(this, 1);',
     '    $mod.THelper.Foo.call(this, 1);',
     '    $mod.THelper.Foo.call(this, 14);',
+    '    this.Fly(2);',
+    '    this.Fly(2);',
+    '    $mod.p = rtl.createCallback(this, "Fly");',
     '    return Result;',
     '  };',
     '});',
+    'this.p = null;',
     'this.Obj = null;',
     '']),
     LinesToStr([ // $mod.$main
     '$mod.THelper.Foo.call($mod.Obj, 1);',
     '$mod.THelper.Foo.call($mod.Obj, 1);',
     '$mod.THelper.Foo.call($mod.Obj, 21);',
+    '$mod.Obj.Fly(2);',
+    '$mod.Obj.Fly(2);',
     'var $with1 = $mod.Obj;',
     '$mod.THelper.Foo.call($with1, 1);',
     '$mod.THelper.Foo.call($with1, 1);',
     '$mod.THelper.Foo.call($with1, 22);',
+    '$with1.Fly(2);',
+    '$with1.Fly(2);',
+    '$mod.p = rtl.createCallback($mod.Obj, "Fly");',
     '']));
 end;
 
@@ -21520,7 +21573,7 @@ begin
     'rtl.createHelper($mod, "THelper", null, function () {',
     '  this.NewHlp = function (w) {',
     '    this.Create(2);',
-    '    $mod.TRec.$create("Create", [3]);',
+    '    $mod.TRec.$new().Create(3);',
     '    $mod.THelper.NewHlp.call(this, 4);',
     '    $mod.THelper.$new("NewHlp", [5]);',
     '    return this;',
@@ -23022,6 +23075,23 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestTypeHelper_ExtClassMethodFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  THelper = type helper for word',
+  '    procedure Run; external name ''Run'';',
+  '  end;',
+  'var w: word;',
+  'begin',
+  '  w.Run;',
+  '']);
+  SetExpectedPasResolverError('Not supported: external method in type helper',nNotSupportedX);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestTypeHelper_Constructor;
 begin
   StartProgram(false);

packages/pastojs/tests/tcoptimizations.pas

@@ -76,6 +76,7 @@ type
     procedure TestWPO_Class_OmitPropertyGetter2;
     procedure TestWPO_Class_OmitPropertySetter1;
     procedure TestWPO_Class_OmitPropertySetter2;
+    procedure TestWPO_Class_KeepNewInstance;
     procedure TestWPO_CallInherited;
     procedure TestWPO_UseUnit;
     procedure TestWPO_ArrayOfConst_Use;
@@ -724,6 +725,56 @@ begin
     '']));
 end;
 
+procedure TTestOptimizations.TestWPO_Class_KeepNewInstance;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TExt = class external name ''Object''',
+  '  end;',
+  '  TBird = class(TExt)',
+  '  protected',
+  '    class function NewInstance(fnname: string; const paramarray): TBird; virtual;',
+  '  public',
+  '    constructor Create;',
+  '  end;',
+  'class function TBird.NewInstance(fnname: string; const paramarray): TBird;',
+  'begin',
+  '  asm',
+  '  Result = Object.create();',
+  '  end;',
+  'end;',
+  'constructor TBird.Create;',
+  'begin',
+  '  inherited;',
+  'end;',
+  'begin',
+  '  TBird.Create;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestWPO_Class_KeepNewInstance',
+    LinesToStr([
+    'rtl.createClassExt($mod, "TBird", Object, "NewInstance", function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.NewInstance = function (fnname, paramarray) {',
+    '    var Result = null;',
+    '    Result = Object.create();',
+    '    return Result;',
+    '  };',
+    '  this.Create = function () {',
+    '    return this;',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([
+    '$mod.TBird.$create("Create");',
+    '']));
+end;
+
 procedure TTestOptimizations.TestWPO_CallInherited;
 begin
   StartProgram(false);

packages/pastojs/tests/testpas2js.lpi

@@ -1,10 +1,15 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="11"/>
+    <Version Value="12"/>
     <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+        <CompatibilityMode Value="True"/>
+      </Flags>
       <SessionStorage Value="InProjectDir"/>
-      <MainUnit Value="0"/>
       <Title Value="Pascal to Javascript converter tests"/>
       <UseAppBundle Value="False"/>
       <ResourceType Value="res"/>
@@ -13,7 +18,7 @@
       <EnableI18N LFM="False"/>
     </i18n>
     <BuildModes Count="1">
-      <Item1 Name="Default" Default="True"/>
+      <Item1 Name="default" Default="True"/>
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
@@ -97,7 +102,7 @@
     </Target>
     <SearchPaths>
       <IncludeFiles Value="$(ProjOutDir)"/>
-      <OtherUnitFiles Value="../src;../../fcl-js/src;../../fcl-passrc/src;../../pastojs/tests"/>
+      <OtherUnitFiles Value="../src;../../fcl-js/src;../../fcl-json/src;../../fcl-passrc/src;../../pastojs/tests"/>
       <UnitOutputDirectory Value="lib"/>
     </SearchPaths>
     <CodeGeneration>

packages/pastojs/tests/testpas2js.pp

@@ -37,7 +37,6 @@ begin
   DefaultRunAllTests:=True;
   Application := TMyTestRunner.Create(nil);
   Application.Initialize;
-  Application.Title:='Pascal to Javascript converter tests';
   Application.Run;
   Application.Free;
 end.

packages/webidl/src/webidlparser.pp

@@ -1001,12 +1001,13 @@ begin
   Result:=TIDLDictionaryDefinition(Context.Add(aParent,TIDLDictionaryDefinition,Name));
   Result.ParentName:=ParentName;
   GetToken;
-  Repeat
+  While (CurrentToken<>tkCurlyBraceClose) do
+     begin
      ParseDictionaryMember(Result.Members);
      CheckCurrentTokens([tkSemicolon,tkCurlyBraceClose]);
      if (CurrentToken=tkSemicolon) then
        GetToken;
-  Until (CurrentToken=tkCurlyBraceClose);
+     end;
 end;
 
 function TWebIDLParser.ParseSequenceTypeDef(aParent : TIDLBaseObject): TIDLSequenceTypeDefDefinition;

utils/pas2js/dist/rtl.js

@@ -1103,7 +1103,7 @@ var rtl = {
     if (a<0) a += rtl.hiInt;
     if (b<=0) return a;
     if (b>54) return 0;
-    var r = a * (2**b);
+    var r = a * Math.pow(2,b);
     if (r <= rtl.hiInt) return r;
     return r % rtl.hiInt;
   },

utils/pas2js/docs/translation.html

@@ -228,6 +228,9 @@ Put + after a boolean switch option to enable it, - to disable it
   -vm<x>,<y>: Do not show messages numbered <x> and <y>.
   -?      : Show this help
   -h      : Show this help
+
+Environment variable PAS2JS_OPTS is parsed after default config
+and before command line parameters.
 </pre>
     </div>
 
@@ -1867,8 +1870,9 @@ function(){
       <li>A <b>record helper</b> can "extend" a record type. In $mode delphi a
         record helper can extend other types as well, see <i>type helper</i></li>
       <li>A <b>type helper</b> can extend all base types like integer, string,
-        char, boolean, double, currency, and some user types like enumeration,
-        set, range and array types. It cannot extend interfaces or helpers.<br>
+        char, boolean, double, currency, and user types like enumeration,
+        set, range, array, class, record and interface types.
+        It cannot extend helpers and procedural types.<br>
         Type helpers are enabled by default in <i>$mode delphi</i> and disabled in <i>$mode objfpc</i>.
         You can enable them with <b>{$modeswitch typehelpers}</b>.
         </li>
@@ -1929,6 +1933,8 @@ function(){
         <li><i>with value do ;</i> : uses a temporary variable. Delphi/FPC do not support it.</li>
         </ul>
       </li>
+      <li>A method with <i>external name</i> modifier is treated as an external
+        method of the helped type.</li>
     </ul>
     </div>
 

utils/pas2js/pas2jswebcompiler.pp

@@ -66,7 +66,6 @@ function TPas2JSWebcompiler.DoWriteJSFile(const DestFilename: String; aWriter: T
 
 Var
   S : String;
-  T : String;
 
 begin
 //  Writeln('aWriter',AWriter.BufferLength,', array size ',Length(AWriter.Buffer));

utils/pas2js/webfilecache.pp

@@ -3,7 +3,7 @@ unit webfilecache;
 {$mode objfpc}
 
 // Enable this to write lots of debugging info to the browser console.
-{ $DEFINE VERBOSEWEBCACHE}
+{$DEFINE VERBOSEWEBCACHE}
 
 interface
 
@@ -94,8 +94,8 @@ type
     function CreateResolver: TPas2jsFSResolver; override;
     function FileExists(const aFileName: String): Boolean; override;
     function FindCustomJSFileName(const aFilename: string): String; override;
-    function FindIncludeFileName(const aFilename: string): String; override;
-    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; override;
+    function FindIncludeFileName(const aFilename, ModuleDir: string): String; override;
+    function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; override;
     function FindUnitJSFileName(const aUnitFilename: string): String; override;
     function LoadFile(Filename: string; Binary: boolean=false): TPas2jsFile; override;
     procedure SaveToFile(ms: TFPJSStream; Filename: string); override;
@@ -330,10 +330,11 @@ begin
 {$ENDIF}
 end;
 
-function TPas2jsWebFS.FindIncludeFileName(const aFilename: string): String;
+function TPas2jsWebFS.FindIncludeFileName(const aFilename, ModuleDir: string
+  ): String;
 begin
 {$IFDEF VERBOSEWEBCACHE}
-  Writeln(ClassName,': FindIncludeFileName(',aFileName,')');
+  Writeln(ClassName,': FindIncludeFileName(',aFileName,',',ModuleDir,')');
 {$ENDIF}
   Result:=NormalizeFileName(aFileName);
   If not FCache.HasFile(Result) then
@@ -372,10 +373,10 @@ begin
   Result:=TPas2jsWebResolver.Create(Self);
 end;
 
-function TPas2jsWebFS.FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String;
+function TPas2jsWebFS.FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String;
 begin
 {$IFDEF VERBOSEWEBCACHE}
-  Writeln(ClassName,': FindUnitFileName(',aUnitName,')');
+  Writeln(ClassName,': FindUnitFileName(',aUnitName,',',InFilename,',',ModuleDir,')');
 {$ENDIF}
   Result:=NormalizeFileName(aUnitName+'.pas');
   isForeign:=False;
@@ -493,7 +494,8 @@ begin
     end;
 end;
 
-Function TPas2jsWebFS.LoadFiles(aList: TStrings; OnLoaded: TLoadFileEvent): Integer;
+function TPas2jsWebFS.LoadFiles(aList: TStrings; OnLoaded: TLoadFileEvent
+  ): Integer;
 
 Var
   i: Integer;
@@ -505,7 +507,8 @@ begin
       Inc(Result);
 end;
 
-function TPas2jsWebFS.LoadFiles(aList: array of String; OnLoaded: TLoadFileEvent): Integer;
+function TPas2jsWebFS.LoadFiles(aList: array of String; OnLoaded: TLoadFileEvent
+  ): integer;
 
 Var
   i: Integer;