paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 15:49:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

# 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

Browse Source 
git-svn-id: branches/fixes_3_2@41998 -
This commit is contained in:
marco 2019-05-05 15:31:55 +00:00
parent 0fa5c1b1e3
commit 7e85b53c0a
27 changed files with 1557 additions and 458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
packages/fcl-json/tests/testjson.lpi
View File

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

2
packages/fcl-passrc/src/pasresolveeval.pas
View File

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

69
packages/fcl-passrc/src/pasresolver.pp
View File

@ -2,7 +2,7 @@
This file is part of the Free Component Library
Pascal resolver
Copyright (c) 2018 Mattias Gaertner mattias@freepascal.org
Copyright (c) 2019 Mattias Gaertner mattias@freepascal.org
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

55
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -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}',

38
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

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

4
packages/fcl-web/src/base/restbase.pp
View File

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

21
packages/fcl-web/src/restbridge/sqldbrestauth.pp
View File

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

516
packages/fcl-web/src/restbridge/sqldbrestbridge.pp
View File

@ -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:=@IO.DoSQLLog;
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:=@Self.DoSQLLog;
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

293
packages/fcl-web/src/restbridge/sqldbrestdata.pp
View File

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

32
packages/fcl-web/src/restbridge/sqldbrestio.pp
View File

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

2
packages/fcl-web/src/restbridge/sqldbrestjson.pp
View File

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

26
packages/fcl-web/src/restbridge/sqldbrestschema.pp
View File

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

251
packages/pastojs/src/fppas2js.pp
View File

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

467
packages/pastojs/src/pas2jscompiler.pp
View File

@ -1,4 +1,4 @@
{ Author: Mattias Gaertner 2018 mattias@freepascal.org
{ Author: Mattias Gaertner 2019 mattias@freepascal.org
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;
begin
Result:=FFiles.Count;
end;
function TPas2jsCompiler.GetDefaultNamespace: String;
procedure TPas2JSConfigSupport.LoadConfig(Const aFileName: String);
type
TSkip = (
skipNone,
skipIf,
skipElse
);
const
IdentChars = ['a'..'z','A'..'Z','_','0'..'9'];
var
C: TClass;
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:='';
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;
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;
procedure TPas2JSConfigSupport.LoadDefaultConfig;
var
aFileName: string;
begin
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];

3
packages/pastojs/src/pas2jsfilecache.pp
View File

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

2
packages/pastojs/src/pas2jsfiler.pp
View File

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

5
packages/pastojs/src/pas2jsfs.pp
View File

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

36
packages/pastojs/src/pas2jsuseanalyzer.pp
View File

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

74
packages/pastojs/tests/tcmodules.pas
View File

@ -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:=@obj.Fly;',
'']);
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);

51
packages/pastojs/tests/tcoptimizations.pas
View File

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

13
packages/pastojs/tests/testpas2js.lpi
View File

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

1
packages/pastojs/tests/testpas2js.pp
View File

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

5
packages/webidl/src/webidlparser.pp
View File

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

2
utils/pas2js/dist/rtl.js vendored
View File

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

10
utils/pas2js/docs/translation.html
View File

@ -228,6 +228,9 @@ Put + after a boolean switch option to enable it, - to disable it
-vm&lt;x&gt;,&lt;y&gt;: Do not show messages numbered &lt;x&gt; and &lt;y&gt;.
-? : 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>

1
utils/pas2js/pas2jswebcompiler.pp
View File

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

21
utils/pas2js/webfilecache.pp
View File

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