* synchronize with trunk

git-svn-id: branches/unicodekvm@41588 -

.gitattributes

@@ -2652,6 +2652,7 @@ packages/fcl-passrc/tests/testpassrc.lpi svneol=native#text/plain
 packages/fcl-passrc/tests/testpassrc.lpr svneol=native#text/plain
 packages/fcl-pdf/Makefile svneol=native#text/plain
 packages/fcl-pdf/Makefile.fpc svneol=native#text/plain
+packages/fcl-pdf/examples/diamond.png -text svneol=unset#image/png
 packages/fcl-pdf/examples/poppy.jpg -text
 packages/fcl-pdf/examples/testfppdf.lpi svneol=native#text/plain
 packages/fcl-pdf/examples/testfppdf.lpr svneol=native#text/plain
@@ -11830,6 +11831,7 @@ tests/tbs/tb0651.pp svneol=native#text/pascal
 tests/tbs/tb0652.pp svneol=native#text/pascal
 tests/tbs/tb0653.pp svneol=native#text/plain
 tests/tbs/tb0654.pp svneol=native#text/plain
+tests/tbs/tb0655.pp svneol=native#text/pascal
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tb613.pp svneol=native#text/plain

compiler/sparcgen/sppara.pas

@@ -85,6 +85,8 @@ implementation
             else
               internalerror(2019021927);
           end;
+        { Create Function result paraloc }
+        create_funcretloc_info(p,side);
         result:=cur_stack_offset;
       end;
 

packages/fcl-base/src/base64.pp

@@ -425,6 +425,8 @@ var
   Outstream : TStringStream;
   Decoder   : TBase64DecodingStream;
 begin
+  if Length(s)=0 then
+    Exit('');
   SD:=S;
   while Length(Sd) mod 4 > 0 do 
     SD := SD + '=';

packages/fcl-image/src/clipping.pp

@@ -87,7 +87,7 @@ begin
       y1 := top;
     if ( y2 > bottom ) then // bottom side needs to be clipped
       y2 := bottom;
-    if (x1 > x2) or (y1 < y2) then
+    if (x1 > x2) or (y1 > y2) then
       ClearRect;
     end;
 end;

packages/fcl-image/src/ellipses.pp

@@ -19,11 +19,11 @@ interface
 
 uses classes, FPImage, FPCanvas;
 
-procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
-procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; c:TFPColor);
-procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; c:TFPColor);
-procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
-procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; c:TFPColor);
+procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
+procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; const c:TFPColor);
+procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; const c:TFPColor);
+procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
+procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; const c:TFPColor);
 procedure FillEllipseHashHorizontal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
 procedure FillEllipseHashVertical (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
 procedure FillEllipseHashDiagonal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
@@ -317,7 +317,7 @@ end;
 { The drawing routines }
 
 type
-  TPutPixelProc = procedure (Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
+  TPutPixelProc = procedure (Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
   TLinePoints = array[0..PatternBitCount-1] of boolean;
   PLinePoints = ^TLinePoints;
 
@@ -334,31 +334,31 @@ begin
   LinePoints^[0] := (APattern and i) <> 0;
 end;
 
-procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
+procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
 begin
   with Canv do
     DrawPixel(x,y,color);
 end;
 
-procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
+procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
 begin
   with Canv do
     Colors[x,y] := Colors[x,y] xor color;
 end;
 
-procedure PutPixelOr(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
+procedure PutPixelOr(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
 begin
   with Canv do
     Colors[x,y] := Colors[x,y] or color;
 end;
 
-procedure PutPixelAnd(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
+procedure PutPixelAnd(Canv:TFPCustomCanvas; x,y:integer; const color:TFPColor);
 begin
   with Canv do
     Colors[x,y] := Colors[x,y] and color;
 end;
 
-procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
+procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
 var info : TEllipseInfo;
     r, y : integer;
     MyPutPix : TPutPixelProc;
@@ -387,7 +387,7 @@ begin
     end;
 end;
 
-procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; c:TFPColor);
+procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; const c:TFPColor);
 var infoOut, infoIn : TEllipseInfo;
     r, y : integer;
     id : PEllipseInfoData;
@@ -430,7 +430,7 @@ begin
     end;
 end;
 
-procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; c:TFPColor);
+procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; const c:TFPColor);
 var info : TEllipseInfo;
     xx, y : integer;
     LinePoints : TLinePoints;
@@ -496,7 +496,7 @@ begin
     end;
 end;
 
-procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
+procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; const c:TFPColor);
 var info : TEllipseInfo;
     r, y : integer;
     id : PEllipseInfoData;
@@ -514,7 +514,7 @@ begin
   end;
 end;
 
-procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; c:TFPColor);
+procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; const c:TFPColor);
 begin
 end;
 

packages/fcl-image/src/fpcolcnv.inc

@@ -296,7 +296,7 @@ begin
 end;
 *)
 
-function AlphaBlend(color1, color2: TFPColor): TFPColor;
+function AlphaBlend(const color1, color2: TFPColor): TFPColor;
 var
   factor1, factor2: single;
 begin

packages/fcl-image/src/fpimage.pp

@@ -286,7 +286,7 @@ function ConvertColor (const From : TFPColor; Fmt : TColorFormat) : TDeviceColor
 function ConvertColor (const From : TDeviceColor; Fmt : TColorFormat) : TDeviceColor;
 *)
 
-function AlphaBlend(color1, color2: TFPColor): TFPColor;
+function AlphaBlend(const color1, color2: TFPColor): TFPColor;
 
 function FPColor (r,g,b,a:word) : TFPColor;
 function FPColor (r,g,b:word) : TFPColor;
@@ -561,7 +561,7 @@ FuzzyDepth: word = 4): TFPCustomImage;
 { HTML Color support. RRGGBB or color name. Only W3 color names s are supported}
 
 function TryHtmlToFPColor(const S: String; out FPColor: TFPColor): Boolean;
-function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; Def: TFPColor): TFPColor;
+function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; const Def: TFPColor): TFPColor;
 function HtmlToFPColor(const S: String): TFPColor;
 
 
@@ -613,12 +613,12 @@ begin
             (c.Alpha = d.Alpha);
 end;
 
-function GetFullColorData (color:TFPColor) : TColorData;
+function GetFullColorData (const color:TFPColor) : TColorData;
 begin
   result := PColorData(@color)^;
 end;
 
-function SetFullColorData (color:TColorData) : TFPColor;
+function SetFullColorData (const color:TColorData) : TFPColor;
 begin
   result := PFPColor (@color)^;
 end;
@@ -760,7 +760,7 @@ begin
   end;
 end;
 
-function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; Def: TFPColor): TFPColor;
+function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; const Def: TFPColor): TFPColor;
 begin
   if not TryHtmlToFPColor(S, Result) then
     Result := Def;

packages/fcl-image/src/fpwritexpm.pp

@@ -28,7 +28,7 @@ type
       FColorShift : word;
       FColorSize : byte;
       procedure SetColorSize (AValue : byte);
-      function ColorToHex (c:TFPColor) : string;
+      function ColorToHex (const c:TFPColor) : string;
     protected
       procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
     public
@@ -61,7 +61,7 @@ begin
     FColorSize := AValue;
 end;
 
-function TFPWriterXPM.ColorToHex (c:TFPColor) : string;
+function TFPWriterXPM.ColorToHex (const c:TFPColor) : string;
 var r,g,b : word;
 begin
   with c do

packages/fcl-image/src/ftfont.pp

@@ -349,7 +349,7 @@ const
 
 procedure TFreeTypeFont.DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer);
 
-  procedure Combine (canv:TFPCustomCanvas; x,y:integer; c : TFPColor; t:longword);
+  procedure Combine (canv:TFPCustomCanvas; x,y:integer; const c : TFPColor; t:longword);
   var
     pixelcolor: TFPColor;
   begin

packages/fcl-passrc/src/pasresolveeval.pas

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

packages/fcl-passrc/src/pasresolver.pp

@@ -5846,6 +5846,9 @@ var
   ptm: TProcTypeModifier;
   ObjKind: TPasObjKind;
   ParentBody: TProcedureBody;
+  HelperForType: TPasType;
+  Args: TFPList;
+  Arg: TPasArgument;
 begin
   if El.Parent is TPasProcedure then
     Proc:=TPasProcedure(El.Parent)
@@ -5940,19 +5943,28 @@ begin
         {if msDelphi in CurrentParser.CurrentModeswitches then
           begin
           // Delphi allows virtual/override in class helpers
-          // But this works differently to normal virtual/override and
-          // requires helpers to be TInterfacedObject
+          // But using them crashes in Delphi 10.3
+          // -> do not support them
           end
         }
         if Proc.IsVirtual then
           RaiseMsg(20190116215823,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
         if Proc.IsOverride then
           RaiseMsg(20190116215825,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
-        if (ObjKind<>okClassHelper) and IsClassMethod(Proc) and not IsClassConDestructor then
+        HelperForType:=ResolveAliasType(TPasClassType(Proc.Parent).HelperForType);
+        if (not Proc.IsStatic) and IsClassMethod(Proc) and not IsClassConDestructor then
           begin
-          if not Proc.IsStatic then
+          // non static class methods require a class
+          if (not (HelperForType.ClassType=TPasClassType))
+              or (TPasClassType(HelperForType).ObjKind<>okClass) then
             RaiseMsg(20190201153831,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,[ObjKindNames[ObjKind]],Proc);
           end;
+        if Proc.ClassType=TPasDestructor then
+          RaiseMsg(20190302151019,nXIsNotSupported,sXIsNotSupported,['destructor'],Proc);
+        if (Proc.ClassType=TPasConstructor)
+            and (HelperForType.ClassType=TPasClassType)
+            and (TPasClassType(HelperForType).ObjKind<>okClass) then
+          RaiseMsg(20190302151514,nXIsNotSupported,sXIsNotSupported,['constructor'],Proc);
         end;
       end;
       if Proc.IsAbstract then
@@ -6036,10 +6048,28 @@ begin
     if El is TPasFunctionType then
       EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType);
 
+    if Proc.PublicName<>nil then
+      ResolveExpr(Proc.PublicName,rraRead);
     if Proc.LibraryExpr<>nil then
       ResolveExpr(Proc.LibraryExpr,rraRead);
     if Proc.LibrarySymbolName<>nil then
       ResolveExpr(Proc.LibrarySymbolName,rraRead);
+    if Proc.DispIDExpr<>nil then
+      ResolveExpr(Proc.DispIDExpr,rraRead);
+    if Proc.MessageExpr<>nil then
+      begin
+      // message modifier
+      ResolveExpr(Proc.MessageExpr,rraRead);
+      Args:=Proc.ProcType.Args;
+      if Args.Count<>1 then
+        RaiseMsg(20190303223701,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El);
+      Arg:=TPasArgument(Args[0]);
+      if not (Arg.Access in [argVar,argOut]) then
+        RaiseMsg(20190303223834,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El);
+      if (Proc.ClassType<>TPasProcedure)
+          and (Proc.ClassType<>TPasFunction) then
+        RaiseMsg(20190303224128,nXExpectedButYFound,sXExpectedButYFound,['procedure name(var Msg);message id;',GetElementTypeName(El)],El);
+      end;
 
     if Proc.Parent is TPasMembersType then
       begin
@@ -6345,7 +6375,8 @@ begin
         SelfType:=TPasClassType(SelfType).HelperForType;
         end;
       LoSelfType:=ResolveAliasType(SelfType);
-      if LoSelfType is TPasClassType then
+      if (LoSelfType is TPasClassType)
+          and (TPasClassType(LoSelfType).ObjKind=okClass) then
         SelfArg.Access:=argConst
       else
         SelfArg.Access:=argVar;
@@ -7234,7 +7265,7 @@ begin
       else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
           and (HelperForType.CustomData is TResElDataBaseType)) then
       else if (HelperForType.ClassType=TPasClassType)
-          and (TPasClassType(HelperForType).ObjKind=okClass) then
+          and (TPasClassType(HelperForType).ObjKind in [okClass,okInterface]) then
         begin
         if TPasClassType(HelperForType).IsForward then
           RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined,

packages/fcl-passrc/src/pastree.pp

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

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1037,9 +1037,10 @@ begin
   repeat
     El:=El.Parent;
     if not (El is TPasType) then break;
-    MarkElementAsUsed(El);
-    if El is TPasMembersType then
-      UseClassConstructor(TPasMembersType(El));
+    UseType(TPasType(El),paumElement);
+    //MarkElementAsUsed(El);
+    //if El is TPasMembersType then
+    //  UseClassConstructor(TPasMembersType(El));
   until false;
 end;
 
@@ -2005,6 +2006,9 @@ begin
     else
       begin
       if ElementVisited(El,Mode) then exit;
+      // this class has been used (e.g. paumElement), which marked ancestors
+      // and published members
+      // -> now mark all members paumAllPasUsable
       FirstTime:=false;
       end;
     end;
@@ -2031,8 +2035,6 @@ begin
       end;
 
     ClassScope:=aClass.CustomData as TPasClassScope;
-    if ClassScope=nil then
-      exit; // ClassScope can be nil if msIgnoreInterfaces
 
     if FirstTime then
       begin
@@ -2115,6 +2117,11 @@ begin
         end;
         //writeln('TPasAnalyzer.UseClassType ',El.FullName,' ',Mode,' ',Member.Name);
         end;
+      if Proc.MessageExpr<>nil then
+        begin
+        UseProcedure(Proc);
+        continue;
+        end;
       end
     else if Member.ClassType=TPasAttributes then
       continue; // attributes are never used directly

packages/fcl-passrc/src/pparser.pp

@@ -4866,21 +4866,24 @@ begin
     end;
   pmMessage:
     begin
-    Repeat
-      NextToken;
-      If CurToken<>tkSemicolon then
-        begin
-        if Parent is TPasProcedure then
-          TPasProcedure(Parent).MessageName:=CurtokenString;
-        If (CurToken=tkString) and (Parent is TPasProcedure) then
-          TPasProcedure(Parent).Messagetype:=pmtString;
-        end;
-    until CurToken = tkSemicolon;
-    UngetToken;
+    NextToken;
+    E:=DoParseExpression(Parent);
+    TPasProcedure(Parent).MessageExpr:=E;
+    if E is TPrimitiveExpr then
+      begin
+      TPasProcedure(Parent).MessageName:=TPrimitiveExpr(E).Value;
+      case E.Kind of
+      pekNumber, pekUnary: TPasProcedure(Parent).Messagetype:=pmtInteger;
+      pekString: TPasProcedure(Parent).Messagetype:=pmtString;
+      end;
+      end;
+    if CurToken = tkSemicolon then
+      UngetToken;
     end;
   pmDispID:
     begin
-    TPasProcedure(Parent).DispIDExpr:=DoParseExpression(Parent,Nil);
+    NextToken;
+    TPasProcedure(Parent).DispIDExpr:=DoParseExpression(Parent);
     if CurToken = tkSemicolon then
       UngetToken;
     end;

packages/fcl-passrc/tests/tcresolver.pas

@@ -620,6 +620,8 @@ type
     Procedure TestClass_EnumeratorFunc;
     Procedure TestClass_ForInPropertyStaticArray;
     Procedure TestClass_TypeAlias;
+    Procedure TestClass_Message;
+    Procedure TestClass_Message_MissingParamFail;
 
     // published
     Procedure TestClass_PublishedClassVarFail;
@@ -932,7 +934,8 @@ type
     Procedure TestTypeHelper_Boolean;
     Procedure TestTypeHelper_Double;
     Procedure TestTypeHelper_Constructor_NewInstance;
-    Procedure TestTypeHelper_InterfaceFail;
+    Procedure TestTypeHelper_Interface;
+    Procedure TestTypeHelper_Interface_ConstructorFail;
 
     // attributes
     Procedure TestAttributes_Globals;
@@ -11117,6 +11120,42 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClass_Message;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  FlyId = 2;',
+  '  RunStr = ''Fast'';',
+  'type',
+  '  TObject = class',
+  '    procedure Fly(var msg); message 3+FlyId;',
+  '    procedure Run(var msg); virtual; abstract; message ''prefix''+RunStr;',
+  '  end;',
+  'procedure TObject.Fly(var msg);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClass_Message_MissingParamFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure Fly; message 3;',
+  '  end;',
+  'procedure TObject.Fly;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sMessageHandlersInvalidParams,nMessageHandlersInvalidParams);
+end;
+
 procedure TTestResolver.TestClass_PublishedClassVarFail;
 begin
   StartProgram(false);
@@ -17593,18 +17632,69 @@ begin
     end;
 end;
 
-procedure TTestResolver.TestTypeHelper_InterfaceFail;
+procedure TTestResolver.TestTypeHelper_Interface;
 begin
   StartProgram(false);
   Add([
   '{$modeswitch typehelpers}',
   'type',
-  '  IUnknown = interface end;',
+  '  IUnknown = interface',
+  '    function GetSizes(Index: word): word;',
+  '    procedure SetSizes(Index: word; value: word);',
+  '  end;',
+  '  TObject = class(IUnknown)',
+  '    function GetSizes(Index: word): word; virtual; abstract;',
+  '    procedure SetSizes(Index: word; value: word); virtual; abstract;',
+  '  end;',
   '  THelper = type helper for IUnknown',
+  '    procedure Fly;',
+  '    class procedure Run; static;',
+  '    property Sizes[Index: word]: word read GetSizes write SetSizes; default;',
   '  end;',
+  'var',
+  '  i: IUnknown;',
+  '  o: TObject;',
+  'procedure THelper.Fly;',
+  'begin',
+  '  i:=Self;',
+  '  o:=Self as TObject;',
+  '  Self:=nil;',
+  '  Self:=i;',
+  '  Self:=o;',
+  'end;',
+  'class procedure THelper.Run;',
+  'begin',
+  'end;',
+  'begin',
+  '  i.Fly;',
+  '  i.Fly();',
+  '  i.Run;',
+  '  i.Run();',
+  '  i.Sizes[3]:=i.Sizes[4];',
+  '  i[5]:=i[6];',
+  '  IUnknown.Run;',
+  '  IUnknown.Run();',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_Interface_ConstructorFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  IUnknown = interface',
+  '  end;',
+  '  THelper = type helper for IUnknown',
+  '    constructor Fly;',
+  '  end;',
+  'constructor THelper.Fly;',
+  'begin',
+  'end;',
   'begin',
   '']);
-  CheckResolverException('Type "IUnknown" cannot be extended by a type helper',nTypeXCannotBeExtendedByATypeHelper);
+  CheckResolverException('constructor is not supported',nXIsNotSupported);
 end;
 
 procedure TTestResolver.TestAttributes_Globals;

packages/fcl-pdf/examples/testfppdf.lpi

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="9"/>
+    <Version Value="11"/>
     <General>
       <Flags>
         <SaveOnlyProjectUnits Value="True"/>
@@ -19,9 +19,6 @@
     <i18n>
       <EnableI18N LFM="False"/>
     </i18n>
-    <VersionInfo>
-      <StringTable ProductVersion=""/>
-    </VersionInfo>
     <BuildModes Count="1">
       <Item1 Name="Default" Default="True"/>
     </BuildModes>
@@ -30,8 +27,16 @@
     </PublishOptions>
     <RunParams>
       <local>
-        <FormatVersion Value="1"/>
+        <CommandLineParams Value="-t 1"/>
       </local>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default">
+          <local>
+            <CommandLineParams Value="-t 1"/>
+          </local>
+        </Mode0>
+      </Modes>
     </RunParams>
     <Units Count="1">
       <Unit0>

packages/fcl-pdf/examples/testfppdf.lpr

@@ -33,7 +33,8 @@ type
     FRawJPEG,
     FImageCompression,
     FTextCompression,
-    FFontCompression: boolean;
+    FFontCompression,
+    FImageTransparency: boolean;
     FNoFontEmbedding: boolean;
     FAddMetadata : Boolean;
     FSubsetFontEmbedding: boolean;
@@ -93,6 +94,8 @@ begin
     Include(lOpts,poCompressText);
   if FImageCompression then
     Include(lOpts,poCompressImages);
+  if FImageTransparency then
+    Include(lOpts,poUseImageTransparency);
   if FRawJPEG then
     Include(lOpts,poUseRawJPEG);
   if FAddMetadata then
@@ -302,7 +305,7 @@ procedure TPDFTestApp.SimpleImage(D: TPDFDocument; APage: integer);
 Var
   P: TPDFPage;
   FtTitle: integer;
-  IDX: Integer;
+  IDX, IDX_Diamond: Integer;
   W, H: Integer;
 begin
   P := D.Pages[APage];
@@ -323,6 +326,10 @@ begin
   { full size image }
   P.DrawImageRawSize(25, 130, W, H, IDX);  // left-bottom coordinate of image
   P.WriteText(145, 90, '[Full size (defined in pixels)]');
+  P.WriteText(145, 95, '+alpha-transparent overlay (if enabled)');
+
+  IDX_Diamond := D.Images.AddFromFile('diamond.png',False);
+  P.DrawImageRawSize(30, 125, D.Images[IDX_Diamond].Width, D.Images[IDX_Diamond].Height, IDX_Diamond);
 
   { quarter size image }
   P.DrawImageRawSize(25, 190, W shr 1, H shr 1, IDX); // could also have used: Integer(W div 2), Integer(H div 2)
@@ -817,6 +824,7 @@ begin
   FFontCompression := BoolFlag('f',true);
   FTextCompression := BoolFlag('t',False);
   FImageCompression := BoolFlag('i',False);
+  FImageTransparency := BoolFlag('t',False);
   FAddMetadata :=  BoolFlag('m',False);
   FRawJPEG:=BoolFlag('j',False);
 
@@ -881,6 +889,8 @@ begin
           '                disables compression. A value of 1 enables compression.');
   writeln('    -j <0|1>    Toggle use of JPEG. A value of 0' + LineEnding +
           '                disables use of JPEG images. A value of 1 writes jpeg file as-is');
+  writeln('    -t <0|1>    Toggle image transparency support. A value of 0' + LineEnding +
+          '                disables transparency. A value of 1 enables transparency.');
   writeln('');
 end;
 

packages/fcl-pdf/src/fppdf.pp

@@ -69,7 +69,8 @@ type
   TPDFPageLayout = (lSingle, lTwo, lContinuous);
   TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels);
 
-  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID);
+  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts,
+    poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency);
   TPDFOptions = set of TPDFOption;
 
   EPDF = Class(Exception);
@@ -881,7 +882,8 @@ type
 
 
   TPDFImageCompression = (icNone, icDeflate, icJPEG);
-
+  TPDFImageStreamOption = (isoCompressed,isoTransparent);
+  TPDFImageStreamOptions = set of TPDFImageStreamOption;
 
   TPDFImageItem = Class(TCollectionItem)
   private
@@ -889,22 +891,33 @@ type
     FOwnsImage: Boolean;
     FStreamed: TBytes;
     FCompression: TPDFImageCompression;
+    FStreamedMask: TBytes;
+    FCompressionMask: TPDFImageCompression;
     FWidth,FHeight : Integer;
+    function GetHasMask: Boolean;
     function GetHeight: Integer;
     function GetStreamed: TBytes;
+    function GetStreamedMask: TBytes;
     function GetWidth: Integer;
     procedure SetImage(AValue: TFPCustomImage);
     procedure SetStreamed(AValue: TBytes);
+  Protected
+    Function WriteStream(const AStreamedData: TBytes; AStream: TStream): int64; virtual;
   Public
     Destructor Destroy; override;
-    Procedure CreateStreamedData(AUseCompression: Boolean);
-    Function WriteImageStream(AStream: TStream): int64; virtual;
+    Procedure CreateStreamedData(AUseCompression: Boolean); overload;
+    Procedure CreateStreamedData(aOptions : TPDFImageStreamOptions); overload;
+    procedure SetStreamedMask(const AValue: TBytes; const ACompression: TPDFImageCompression);
+    Function WriteImageStream(AStream: TStream): int64;
+    Function WriteMaskStream(AStream: TStream): int64;
     function Equals(AImage: TFPCustomImage): boolean; reintroduce;
     Property Image : TFPCustomImage Read FImage Write SetImage;
     Property StreamedData : TBytes Read GetStreamed Write SetStreamed;
+    Property StreamedMask : TBytes Read GetStreamedMask;
     Property OwnsImage : Boolean Read FOwnsImage Write FOwnsImage;
     Property Width : Integer Read GetWidth;
     Property Height : Integer Read GetHeight;
+    Property HasMask : Boolean read GetHasMask;
   end;
 
 
@@ -1053,7 +1066,10 @@ type
     procedure CreateToUnicode(const AFontNum: integer);virtual;
     procedure CreateFontFileEntry(const AFontNum: integer);virtual;
     procedure CreateCIDSet(const AFontNum: integer); virtual;
-    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual;
+    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
+      out ImageDict: TPDFDictionary);virtual;
+    procedure CreateImageMaskEntry(ImgWidth, ImgHeight, NumImg: integer;
+      ImageDict: TPDFDictionary);virtual;
     function CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; virtual;
     function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual;
     procedure CreatePageStream(APage : TPDFPage; PageNum: integer);
@@ -1064,6 +1080,7 @@ type
     function IndexOfGlobalXRef(const AValue: string): integer;
     Function FindGlobalXRef(Const AName : String) : TPDFXRef;
     Function GlobalXRefByName(Const AName : String) : TPDFXRef;
+    Function ImageStreamOptions : TPDFImageStreamOptions;
     Property GlobalXRefs[AIndex : Integer] : TPDFXRef Read GetX;
     Property GlobalXRefCount : Integer Read GetXC;
     Property CurrentColor: string Read FCurrentColor Write FCurrentColor;
@@ -2831,17 +2848,31 @@ begin
 end;
 
 function TPDFImageItem.GetStreamed: TBytes;
+
+Var
+  Opts : TPDFImageStreamOptions;
+
 begin
+  Opts:=[];
   if Length(FStreamed)=0 then
-  begin
+    begin
     if Collection.Owner is TPDFDocument then
-      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options)
+      begin
+      Opts:=TPDFDocument(Collection.Owner).ImageStreamOptions;
+      end
     else
-      CreateStreamedData(True);
-  end;
+      Opts:=[isoCompressed,isoTransparent];
+    end;
+  CreateStreamedData(Opts);
   Result:=FStreamed;
 end;
 
+function TPDFImageItem.GetStreamedMask: TBytes;
+begin
+  GetStreamed; // calls CreateStreamedData
+  Result:=FStreamedMask;
+end;
+
 function TPDFImageItem.GetHeight: Integer;
 begin
   If Assigned(FImage) then
@@ -2865,6 +2896,25 @@ begin
   FStreamed:=AValue;
 end;
 
+procedure TPDFImageItem.SetStreamedMask(const AValue: TBytes;
+  const ACompression: TPDFImageCompression);
+begin
+  If AValue=FStreamedMask then exit;
+  SetLength(FStreamedMask,0);
+  FStreamedMask:=AValue;
+  FCompressionMask:=ACompression;
+end;
+
+function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
+begin
+  Result:=WriteStream(FStreamed, AStream);
+end;
+
+function TPDFImageItem.WriteMaskStream(AStream: TStream): int64;
+begin
+  Result:=WriteStream(FStreamedMask, AStream);
+end;
+
 destructor TPDFImageItem.Destroy;
 begin
   if FOwnsImage then
@@ -2873,59 +2923,106 @@ begin
 end;
 
 procedure TPDFImageItem.CreateStreamedData(AUseCompression: Boolean);
+
+begin
+  CreateStreamedData([isoCompressed]);
+end;
+
+Procedure TPDFImageItem.CreateStreamedData(aOptions : TPDFImageStreamOptions);
+
+
+  function NeedsTransparency: Boolean;
+  var
+    Y, X: Integer;
+  begin
+    for Y:=0 to FHeight-1 do
+      for X:=0 to FWidth-1 do
+        begin
+        if Image.Colors[x,y].alpha < $FFFF then // has alpha channel
+          Exit(True);
+        end;
+    Result:=False;
+  end;
+
+  procedure CreateStream(out MS: TMemoryStream; out Str: TStream;
+    out Compression: TPDFImageCompression);
+  begin
+    MS := TMemoryStream.Create;
+    if (isoCompressed in aOptions) then
+      begin
+      Compression := icDeflate;
+      Str := Tcompressionstream.create(cldefault, MS);
+      end
+    else
+      begin
+      Compression := icNone;
+      Str := MS;
+      end;
+  end;
+
+  procedure StreamToBuffer(const MS: TMemoryStream; var Str: TStream; out Buffer: TBytes);
+  begin
+    if Str<>MS then
+      Str.Free;
+    Str := nil;
+    SetLength(Buffer, MS.Size);
+    MS.Position := 0;
+    if MS.Size>0 then
+      MS.ReadBuffer(Buffer[0], MS.Size);
+  end;
+
 Var
   X,Y : Integer;
   C : TFPColor;
-  MS : TMemoryStream;
-  Str : TStream;
+  MS,MSMask : TMemoryStream;
+  Str,StrMask : TStream;
   CWhite : TFPColor; // white color
+  CreateMask : Boolean;
 begin
   FillMem(@CWhite, SizeOf(CWhite), $FF);
   FWidth:=Image.Width;
   FHeight:=Image.Height;
+  CreateMask:=(isoTransparent in aOptions) and NeedsTransparency;
+  MS := nil;
   Str := nil;
-  MS := TMemoryStream.Create;
+  MSMask := nil;
+  StrMask := nil;
   try
-    if AUseCompression then
-      begin
-      FCompression := icDeflate;
-      Str := Tcompressionstream.create(cldefault, MS)
-      end
-    else
-      begin
-      FCompression := icNone;
-      Str := MS;
-      end;
+    CreateStream(MS, Str, FCompression);
+    if CreateMask then
+      CreateStream(MSMask, StrMask, FCompressionMask);
     for Y:=0 to FHeight-1 do
       for X:=0 to FWidth-1 do
         begin
         C:=Image.Colors[x,y];
-        if C.alpha < $FFFF then // remove alpha channel - assume white background
+        if CreateMask then
+          StrMask.WriteByte(C.Alpha shr 8)
+        else
+        if (C.alpha < $FFFF) then // remove alpha channel - assume white background
           C := AlphaBlend(CWhite, C);
 
         Str.WriteByte(C.Red shr 8);
         Str.WriteByte(C.Green shr 8);
         Str.WriteByte(C.Blue shr 8);
         end;
-    if Str<>MS then
-      Str.Free;
-    Str := nil;
-    SetLength(FStreamed, MS.Size);
-    MS.Position := 0;
-    if MS.Size>0 then
-      MS.ReadBuffer(FStreamed[0], MS.Size);
+    StreamToBuffer(MS, Str, FStreamed);
+    if CreateMask then
+      StreamToBuffer(MSMask, StrMask, FStreamedMask);
   finally
     Str.Free;
+    StrMask.Free;
     MS.Free;
+    MSMask.Free;
   end;
 end;
 
-function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
+function TPDFImageItem.WriteStream(const AStreamedData: TBytes;
+  AStream: TStream): int64;
 var
   Img : TBytes;
 begin
   TPDFObject.WriteString(CRLF+'stream'+CRLF,AStream);
-  Img:=StreamedData;
+  Img:=AStreamedData;
   Result:=Length(Img);
   AStream.WriteBuffer(Img[0],Result);
   TPDFObject.WriteString(CRLF, AStream);
@@ -2956,6 +3053,11 @@ begin
       end;
 end;
 
+function TPDFImageItem.GetHasMask: Boolean;
+begin
+  Result := Length(FStreamedMask)>0;
+end;
+
 { TPDFImages }
 
 function TPDFImages.GetI(AIndex : Integer): TPDFImageItem;
@@ -3092,7 +3194,7 @@ begin
     IP.Image:=I;
     if Not KeepImage then
       begin
-      IP.CreateStreamedData(poCompressImages in Owner.Options);
+      IP.CreateStreamedData(Owner.ImageStreamOptions);
       IP.FImage:=Nil; // not through property, that would clear the image
       i.Free;
       end;
@@ -4055,6 +4157,22 @@ begin
         begin
           if (E.FKey.Name='Name') then
           begin
+            if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='M') then
+            begin
+              NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
+              // write image stream length in xobject dictionary
+              ISize:=Length(Document.Images[NumImg].StreamedMask);
+              D:=Document.GlobalXRefs[AObject].Dict;
+              D.AddInteger('Length',ISize);
+              LastElement.Write(AStream);
+              case Document.Images[NumImg].FCompressionMask of
+                icJPEG: WriteString('/Filter /DCTDecode'+CRLF, AStream);
+                icDeflate: WriteString('/Filter /FlateDecode'+CRLF, AStream);
+              end;
+              WriteString('>>', AStream);
+              // write image stream in xobject dictionary
+              Document.Images[NumImg].WriteMaskStream(AStream);
+            end else
             if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='I') then
             begin
               NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
@@ -5087,24 +5205,25 @@ begin
   lXRef.FStream.AddItem(TPDFCIDSet.Create(self, AFontNum));
 end;
 
-procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
+procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
+  out ImageDict: TPDFDictionary);
 var
   N: TPDFName;
-  IDict,ADict: TPDFDictionary;
+  ADict: TPDFDictionary;
   i: integer;
   lXRef: integer;
 begin
   lXRef := GlobalXRefCount; // reference to be used later
 
-  IDict:=CreateGlobalXRef.Dict;
-  IDict.AddName('Type','XObject');
-  IDict.AddName('Subtype','Image');
-  IDict.AddInteger('Width',ImgWidth);
-  IDict.AddInteger('Height',ImgHeight);
-  IDict.AddName('ColorSpace','DeviceRGB');
-  IDict.AddInteger('BitsPerComponent',8);
+  ImageDict:=CreateGlobalXRef.Dict;
+  ImageDict.AddName('Type','XObject');
+  ImageDict.AddName('Subtype','Image');
+  ImageDict.AddInteger('Width',ImgWidth);
+  ImageDict.AddInteger('Height',ImgHeight);
+  ImageDict.AddName('ColorSpace','DeviceRGB');
+  ImageDict.AddInteger('BitsPerComponent',8);
   N:=CreateName('I'+IntToStr(NumImg)); // Needed later
-  IDict.AddElement('Name',N);
+  ImageDict.AddElement('Name',N);
 
   // now find where we must add the image xref - we are looking for "Resources"
   for i := 1 to GlobalXRefCount-1 do
@@ -5125,6 +5244,27 @@ begin
   end;
 end;
 
+procedure TPDFDocument.CreateImageMaskEntry(ImgWidth, ImgHeight,
+  NumImg: integer; ImageDict: TPDFDictionary);
+var
+  N: TPDFName;
+  MDict: TPDFDictionary;
+  lXRef: integer;
+begin
+  lXRef := GlobalXRefCount; // reference to be used later
+
+  MDict:=CreateGlobalXRef.Dict;
+  MDict.AddName('Type','XObject');
+  MDict.AddName('Subtype','Image');
+  MDict.AddInteger('Width',ImgWidth);
+  MDict.AddInteger('Height',ImgHeight);
+  MDict.AddName('ColorSpace','DeviceGray');
+  MDict.AddInteger('BitsPerComponent',8);
+  N:=CreateName('M'+IntToStr(NumImg)); // Needed later
+  MDict.AddElement('Name',N);
+  ImageDict.AddReference('SMask', lXRef);
+end;
+
 function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer;
 var
   lDict, ADict: TPDFDictionary;
@@ -5228,6 +5368,15 @@ begin
     Raise EPDF.CreateFmt(rsErrNoGlobalDict,[AName]);
 end;
 
+function TPDFDocument.ImageStreamOptions: TPDFImageStreamOptions;
+begin
+  Result:=[];
+  if (poCompressImages in Options) then
+    Include(Result,isoCompressed);
+  if (poUseImageTransparency in Options) then
+    Include(Result,isoTransparent);
+end;
+
 function TPDFDocument.CreateLineStyles: TPDFLineStyleDefs;
 begin
   Result:=TPDFLineStyleDefs.Create(TPDFLineStyleDef);
@@ -5492,9 +5641,14 @@ end;
 procedure TPDFDocument.CreateImageEntries;
 Var
   I : Integer;
+  IDict : TPDFDictionary;
 begin
   for i:=0 to Images.Count-1 do
-    CreateImageEntry(Images[i].Width,Images[i].Height,i);
+    begin
+    CreateImageEntry(Images[i].Width,Images[i].Height,i,IDict);
+    if Images[i].HasMask then
+      CreateImageMaskEntry(Images[i].Width,Images[i].Height,i,IDict);
+    end;
 end;
 
 procedure TPDFDocument.CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary);

packages/fcl-pdf/src/fpttf.pp

@@ -85,6 +85,7 @@ type
   TFPFontCacheItemArray = Array of TFPFontCacheItem;
 
   { TFPFontCacheList }
+  EFontNotFound = Class(Exception);
 
   TFPFontCacheList = class(TObject)
   private
@@ -97,6 +98,7 @@ type
     { Set any / or \ path delimiters to the OS specific delimiter }
     procedure   FixPathDelimiters;
   protected
+    function    DoFindPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean; Out aBaseFont : TFPFontCacheItem): String;
     function    GetCount: integer; virtual;
     function    GetItem(AIndex: Integer): TFPFontCacheItem; virtual;
     procedure   SetItem(AIndex: Integer; AValue: TFPFontCacheItem); virtual;
@@ -111,6 +113,10 @@ type
     procedure   ReadStandardFonts;
     property    Count: integer read GetCount;
     function    IndexOf(const AObject: TFPFontCacheItem): integer;
+    // Find postscript font name based on fontname and attributes
+    function    FindPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean): String;
+    // Same as Find, but raise exception when not found.
+    function    GetPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean): String;
     function    Find(const AFontCacheItem: TFPFontCacheItem): integer; overload;
     function    Find(const AFamilyName: string; ABold: boolean; AItalic: boolean): TFPFontCacheItem; overload;
     function    Find(const APostScriptName: string): TFPFontCacheItem; overload;
@@ -143,6 +149,7 @@ resourcestring
   rsNoSearchPathDefined = 'No search path was defined';
   rsNoFontFileName = 'The FileName property is empty, so we can''t load font data.';
   rsMissingFontFile = 'The font file <%s> can''t be found.';
+  SErrFontNotFound = 'The font <%s> can can''t be found';
 
 var
   uFontCacheList: TFPFontCacheList;
@@ -591,6 +598,56 @@ begin
   Result := FList.IndexOf(AObject);
 end;
 
+function TFPFontCacheList.GetPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean): String;
+
+Var
+  lFC : TFPFontCacheItem;
+  lMissingFontName : String;
+
+begin
+  Result:=DoFindPostScriptFontName(aFontName,aBold,aItalic,lfc);
+  if (Result=aFontName) and (aBold or aItalic) then
+    begin
+    if lFC<>Nil then
+      lMissingFontName := lfc.FamilyName
+    else
+      lMissingFontName := aFontName;
+    if (aBold and AItalic) then
+      lMissingFontName := lMissingFontName + '-BoldItalic'
+    else if aBold then
+      lMissingFontName := lMissingFontName + '-Bold'
+    else if aItalic then
+      lMissingFontName := lMissingFontName + '-Italic';
+    raise EFontNotFound.CreateFmt(SErrFontNotFound, [lMissingFontName]);
+    end;
+end;
+
+function TFPFontCacheList.FindPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean): String;
+
+Var
+  lFC : TFPFontCacheItem;
+
+begin
+  Result:=DoFindPostScriptFontName(aFontName,aBold,aItalic,lfc);
+end;
+
+function  TFPFontCacheList.DoFindPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean; Out aBaseFont : TFPFontCacheItem): String;
+
+Var
+   lNewFC : TFPFontCacheItem;
+
+begin
+  Result:=aFontName;
+  aBaseFont := FindFont(aFontName);
+  if not Assigned(aBaseFont) then
+    exit;
+  // find corresponding font style (bold and/or italic)
+  lNewFC := Find(aBaseFont.FamilyName, aBold, aItalic);
+  if not Assigned(lNewFC) then
+    exit;
+  Result := lNewFC.PostScriptName;
+end;
+
 function TFPFontCacheList.Find(const AFontCacheItem: TFPFontCacheItem): integer;
 var
   i: integer;

packages/fcl-report/src/fpreport.pp

@@ -1664,7 +1664,7 @@ type
     destructor  Destroy; override;
     class function ReportKindToResultType(const AType: TFPReportFieldKind): TResultType;
     Function StreamToReportElements(aStream : TStream) : TFPObjectList;
-    Procedure Clear;
+    Procedure Clear(ClearData : Boolean = True);
     Procedure SaveDataToNames;
     Procedure RestoreDataFromNames;
     procedure WriteElement(AWriter: TFPReportStreamer; AOriginal: TFPReportElement = nil); override;
@@ -4459,14 +4459,11 @@ begin
       FCurTextBlock.FGColor := FLastFGColor;
     if FLastBGColor <> clNone then
       FCurTextBlock.BGColor := FLastBGColor;
+    if (([htBold,htItalic] * FTextBlockState)=[]) then
+      lNewFontName:=Font.Name
+    else
+      lNewFontName:=gTTFontCache.FindPostScriptFontname(Font.Name, htBold in FTextBlockState, htItalic in FTextBlockState);
 
-    lNewFontName := Font.Name;
-    if [htBold, htItalic] <= FTextBlockState then // test if it is a sub-set of FTextBlockState
-      lNewFontName := lNewFontName + '-BoldItalic'
-    else if htBold in FTextBlockState then
-      lNewFontName := lNewFontName + '-Bold'
-    else if htItalic in FTextBlockState then
-      lNewFontName := lNewFontName + '-Italic';
     FCurTextBlock.FontName := lNewFontName;
 
     FCurTextBlock.Width := TextWidth(FCurTextBlock.Text);
@@ -8523,7 +8520,7 @@ begin
   inherited Destroy;
 end;
 
-procedure TFPCustomReport.Clear;
+procedure TFPCustomReport.Clear(ClearData : Boolean = True);
 
 Var
   P : TFPReportCustomPage;
@@ -8538,7 +8535,8 @@ begin
   FIsFirstPass := False;
   // Collections
   FreeAndNil(FExpr); // Special case, recreated on run
-  FReportData.Clear;
+  if ClearData then
+    FReportData.Clear;
   if Assigned(FPages) then
     begin
     While PageCount>0 do
@@ -10671,6 +10669,8 @@ end;
 procedure TFPReportData.Open;
 
 begin
+  if IsOpened then
+    exit;
   if Assigned(FOnOpen) then
     FOnOpen(Self);
   DoOpen;
@@ -12459,11 +12459,11 @@ begin
   TFPReportDataFooterBand.RegisterElement;
   TFPReportColumnHeaderBand.RegisterElement;
   TFPReportColumnFooterBand.RegisterElement;
-  TFPReportMemo.RegisterElement;
-  TFPReportImage.RegisterElement;
-  TFPReportCheckbox.RegisterElement;
-  TFPReportShape.RegisterElement;
-  TFPReportPage.RegisterElement;
+  TFPReportMemo.RegisterElement.FStandard:=True;
+  TFPReportImage.RegisterElement.FStandard:=True;
+  TFPReportCheckbox.RegisterElement.FStandard:=True;
+  TFPReportShape.RegisterElement.FStandard:=True;
+  TFPReportPage.RegisterElement.FStandard:=True;
 end;
 
 initialization

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

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

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

@@ -22,7 +22,7 @@ uses
   Classes, SysUtils, DB, SQLDB, httpdefs, httproute, fpjson, sqldbrestschema, sqldbrestio, sqldbrestdata, sqldbrestauth;
 
 Type
-  TRestDispatcherOption = (rdoConnectionInURL,rdoExposeMetadata,rdoCustomView,rdoHandleCORS);
+  TRestDispatcherOption = (rdoConnectionInURL,rdoExposeMetadata,rdoCustomView,rdoHandleCORS,rdoAccessCheckNeedsDB);
   TRestDispatcherOptions = set of TRestDispatcherOption;
 
 Const
@@ -192,11 +192,13 @@ Type
     FSchemas: TSQLDBRestSchemaList;
     FListRoute: THTTPRoute;
     FItemRoute: THTTPRoute;
+    FStatus: TRestStatusConfig;
     FStrings: TRestStringsConfig;
     procedure SetActive(AValue: Boolean);
     procedure SetAuthenticator(AValue: TRestAuthenticator);
     procedure SetConnections(AValue: TSQLDBRestConnectionList);
     procedure SetSchemas(AValue: TSQLDBRestSchemaList);
+    procedure SetStatus(AValue: TRestStatusConfig);
     procedure SetStrings(AValue: TRestStringsConfig);
   Protected
     // Auxiliary methods.
@@ -207,6 +209,7 @@ Type
     Function CreateConnectionList : TSQLDBRestConnectionList; virtual;
     Function CreateSchemaList : TSQLDBRestSchemaList; virtual;
     function CreateRestStrings: TRestStringsConfig; virtual;
+    function CreateRestStatusConfig: TRestStatusConfig; virtual;
     function CreateDBHandler(IO: TRestIO): TSQLDBRestDBHandler; virtual;
     function CreateInputStreamer(IO: TRestIO): TRestInputStreamer; virtual;
     function CreateOutputStreamer(IO: TRestIO): TRestOutputStreamer; virtual;
@@ -227,6 +230,10 @@ Type
     function ExtractRestOperation(aRequest: TRequest;AccessControl : Boolean = false): TRestoperation; virtual;
     function FindRestResource(aResource: UTF8String): TSQLDBRestResource; virtual;
     function AllowRestResource(aIO : TRestIO): Boolean; virtual;
+    function AllowRestOperation(aIO: TRestIO): Boolean; virtual;
+    // Called twice: once before connection is established, once after.
+    // checks rdoAccessCheckNeedsDB and availability of connection
+    function CheckResourceAccess(IO: TRestIO): Boolean;
     function ExtractRestResourceName(IO: TRestIO): UTF8String; virtual;
     // Override if you want to create non-sqldb based resources
     function CreateSpecialResourceDataset(IO: TRestIO; AOwner: TComponent): TDataset; virtual;
@@ -273,6 +280,8 @@ Type
     Property DefaultConnection : UTF8String Read FDefaultConnection Write FDefaultConnection;
     // Input/Output strings configuration
     Property Strings : TRestStringsConfig Read FStrings Write SetStrings;
+    // HTTP Status codes configuration
+    Property Statuses : TRestStatusConfig Read FStatus Write SetStatus;
     // default Output options, modifiable by query.
     Property OutputOptions : TRestOutputOptions Read FOutputOptions Write FOutputOptions Default allOutputOptions;
     // Set this to allow only this input format.
@@ -424,6 +433,12 @@ begin
   FSchemas.Assign(AValue);
 end;
 
+procedure TSQLDBRestDispatcher.SetStatus(AValue: TRestStatusConfig);
+begin
+  if FStatus=AValue then Exit;
+  FStatus.Assign(AValue);
+end;
+
 procedure TSQLDBRestDispatcher.SetStrings(AValue: TRestStringsConfig);
 begin
   if FStrings=AValue then Exit;
@@ -519,8 +534,8 @@ begin
     aName:='json';
   D:=TStreamerFactory.Instance.FindStreamerByName(rstInput,aName);
   if (D=Nil) then
-    Raise ESQLDBRest.CreateFmt(400,SErrUnknownOrUnSupportedFormat,[aName]);
-  Result:=TRestInputStreamer(D.MyClass.Create(IO.RequestContentStream,Fstrings,@IO.DoGetVariable));
+    Raise ESQLDBRest.CreateFmt(FStatus.GetStatusCode(rsInvalidParam),SErrUnknownOrUnSupportedFormat,[aName]);
+  Result:=TRestInputStreamer(D.MyClass.Create(IO.RequestContentStream,Fstrings,FStatus,@IO.DoGetVariable));
 end;
 
 function TSQLDBRestDispatcher.CreateOutputStreamer(IO : TRestIO): TRestOutputStreamer;
@@ -535,8 +550,8 @@ begin
     aName:='json';
   D:=TStreamerFactory.Instance.FindStreamerByName(rstOutput,aName);
   if (D=Nil) then
-    Raise ESQLDBRest.CreateFmt(400,SErrUnknownOrUnSupportedFormat,[aName]);
-  Result:=TRestOutputStreamer(D.MyClass.Create(IO.Response.ContentStream,Fstrings,@IO.DoGetVariable));
+    Raise ESQLDBRest.CreateFmt(FStatus.GetStatusCode(rsInvalidParam),SErrUnknownOrUnSupportedFormat,[aName]);
+  Result:=TRestOutputStreamer(D.MyClass.Create(IO.Response.ContentStream,Fstrings,FStatus,@IO.DoGetVariable));
 end;
 
 
@@ -554,6 +569,7 @@ begin
     // Set up output
     Result.Response.ContentStream:=TMemoryStream.Create;
     Result.Response.FreeContentStream:=True;
+    Result.SetRestStatuses(FStatus);
     Result.SetRestStrings(FStrings);
     aInput:=CreateInputStreamer(Result);
     aoutPut:=CreateOutPutStreamer(Result);
@@ -606,6 +622,7 @@ begin
   FSchemas:=CreateSchemaList;
   FOutputOptions:=allOutputOptions;
   FDispatchOptions:=DefaultDispatcherOptions;
+  FStatus:=CreateRestStatusConfig;
 end;
 
 destructor TSQLDBRestDispatcher.Destroy;
@@ -617,6 +634,7 @@ begin
   FreeAndNil(FSchemas);
   FreeAndNil(FConnections);
   FreeAndNil(FStrings);
+  FreeAndNil(FStatus);
   inherited Destroy;
 end;
 
@@ -626,6 +644,11 @@ begin
   Result:=TRestStringsConfig.Create
 end;
 
+function TSQLDBRestDispatcher.CreateRestStatusConfig: TRestStatusConfig;
+begin
+  Result:=TRestStatusConfig.Create;
+end;
+
 function TSQLDBRestDispatcher.ExtractRestResourceName(IO: TRestIO): UTF8String;
 
 begin
@@ -634,10 +657,10 @@ begin
     Result:=IO.Request.QueryFields.Values[Strings.ResourceParam];
 end;
 
-function TSQLDBRestDispatcher.AllowRestResource( aIO: TRestIO): Boolean;
+function TSQLDBRestDispatcher.AllowRestResource(aIO: TRestIO): Boolean;
 
 begin
-  Result:=True;
+  Result:=aIO.Resource.AllowResource(aIO.RestContext);
   if Assigned(FOnAllowResource) then
     FOnAllowResource(Self,aIO.Request,aIO.ResourceName,Result);
 end;
@@ -917,18 +940,18 @@ end;
 procedure TSQLDBRestDispatcher.SetDefaultResponsecode(IO : TRestIO);
 
 Const
-  DefaultCodes : Array[TRestOperation] of Integer = (500,200,201,200,204,200,200);
+  DefaultCodes : Array[TRestOperation] of TRestStatus = (rsError,rsGetOK,rsPOSTOK,rsPUTOK,rsDeleteOK,rsCORSOK,rsGetOK);
   DefaultTexts : Array[TRestOperation] of string = ('Internal Error','OK','Created','OK','No content','OK','OK');
 
 Var
-  aCode : Integer;
+  aCode : TRestStatus;
   aText : String;
 
 begin
   aCode:=DefaultCodes[IO.Operation];
   aText:=DefaultTexts[IO.Operation];
   if IO.Response.Code=0 then
-    IO.Response.Code:=aCode;
+    IO.Response.Code:=FStatus.GetStatusCode(aCode);
   if (IO.Response.CodeText='') then
     IO.Response.CodeText:=aText;
 end;
@@ -1102,7 +1125,7 @@ Var
 begin
   ST:=IO.Connection.GetStatementInfo(aSQL).StatementType;
   if (st<>stSelect) then
-    Raise ESQLDBRest.Create(400,'Only SELECT SQL is allowed for custom view'); // Should never happen.
+    raise ESQLDBRest.Create(FStatus.GetStatusCode(rsInvalidParam), SErrOnlySELECTSQLAllowedInCustomView); // Should never happen.
   Q:=TRestSQLQuery.Create(aOwner);
   try
     Q.DataBase:=IO.Connection;
@@ -1130,13 +1153,13 @@ begin
   else if (IO.Resource=FMetadataDetailResource) then
     begin
     if IO.GetVariable('ID',RN,[vsRoute,vsQuery])=vsNone then
-      Raise ESQLDBRest.Create(500,'Could not find resource name'); // Should never happen.
+      raise ESQLDBRest.Create(FStatus.GetStatusCode(rsError), SErrCouldNotFindResourceName); // Should never happen.
     Result:=CreateMetadataDetailDataset(IO,RN,AOwner)
     end
   else   if (IO.Resource=FCustomViewResource) then
     begin
     if IO.GetVariable(FStrings.GetRestString(rpCustomViewSQLParam),RN,[vsRoute,vsQuery])=vsNone then
-      Raise ESQLDBRest.Create(400,'Could not find SQL statement for custom view'); // Should never happen.
+      raise ESQLDBRest.Create(FStatus.GetStatusCode(rsInvalidParam), SErrNoSQLStatement); // Should never happen.
     Result:=CreateCustomViewDataset(IO,RN,aOwner);
     end
 
@@ -1155,7 +1178,7 @@ begin
     Allowed:=(ExtractRestOperation(IO.Request,True) in ([roUnknown]+IO.Resource.AllowedOperations));
   if not Allowed then
     begin
-    IO.Response.Code:=403;
+    IO.Response.Code:=FStatus.GetStatusCode(rsCORSNotAllowed);
     IO.Response.CodeText:='FORBIDDEN';
     IO.CreateErrorResponse;
     end
@@ -1167,7 +1190,7 @@ begin
     IO.Response.SetCustomHeader('Access-Control-Allow-Origin',S);
     S:=IO.Resource.GetHTTPAllow;
     IO.Response.SetCustomHeader('Access-Control-Allow-Methods',S);
-    IO.Response.Code:=200;
+    IO.Response.Code:=FStatus.GetStatusCode(rsCORSOK);
     IO.Response.CodeText:='OK';
     end;
 end;
@@ -1188,6 +1211,8 @@ begin
     Try
       if not AuthenticateRequest(IO,True) then
         exit;
+      if Not CheckResourceAccess(IO) then
+        exit;
       DoHandleEvent(True,IO);
       H:=CreateDBHandler(IO);
       if IsSpecialResource(IO.Resource) then
@@ -1265,6 +1290,33 @@ begin
   Result:=TSQLDBRestSchemaList.Create(TSQLDBRestSchemaRef);
 end;
 
+function TSQLDBRestDispatcher.AllowRestOperation(aIO: TRestIO): Boolean;
+
+begin
+  Result:=(aIO.Operation in aIO.Resource.GetAllowedOperations(aIO.RestContext));
+end;
+
+function TSQLDBRestDispatcher.CheckResourceAccess(IO: TRestIO): Boolean;
+
+Var
+  NeedDB : Boolean;
+
+begin
+  NeedDB:=(rdoAccessCheckNeedsDB in DispatchOptions);
+  Result:=NeedDB<>Assigned(IO.Connection);
+  if Result then
+    exit;
+  Result:=AllowRestResource(IO);
+  if not Result then
+    CreateErrorContent(IO,FStatus.GetStatusCode(rsResourceNotAllowed),'FORBIDDEN')
+  else
+    begin
+    Result:=AllowRestOperation(IO);
+    if not Result then
+      CreateErrorContent(IO,FStatus.GetStatusCode(rsRestOperationNotAllowed),'METHOD NOT ALLOWED')
+    end;
+end;
+
 procedure TSQLDBRestDispatcher.DoHandleRequest(IO : TRestIO);
 
 var
@@ -1276,22 +1328,20 @@ var
 begin
   Operation:=ExtractRestOperation(IO.Request);
   if (Operation=roUnknown) then
-    CreateErrorContent(IO,400,'Invalid method')
+    CreateErrorContent(IO,FStatus.GetStatusCode(rsInvalidMethod),'INVALID METHOD')
   else
     begin
     IO.SetOperation(Operation);
     ResourceName:=ExtractRestResourceName(IO);
     if (ResourceName='') then
-      CreateErrorContent(IO,404,'Invalid resource')
+      CreateErrorContent(IO,FStatus.GetStatusCode(rsNoResourceSpecified),'INVALID RESOURCE')
     else
       begin
       Resource:=FindSpecialResource(IO,ResourceName);
       If Resource=Nil then
         Resource:=FindRestResource(ResourceName);
       if Resource=Nil then
-        CreateErrorContent(IO,404,'Invalid resource')
-      else if Not (Operation in Resource.AllowedOperations) then
-        CreateErrorContent(IO,405,'Method not allowed')
+        CreateErrorContent(IO,FStatus.GetStatusCode(rsUnknownResource),'NOT FOUND')
       else
         begin
         IO.SetResource(Resource);
@@ -1299,13 +1349,11 @@ begin
         if Connection=Nil then
           begin
           if (rdoConnectionInURL in DispatchOptions) then
-            CreateErrorContent(IO,400,Format(SErrNoconnection,[GetConnectionName(IO)]))
+            CreateErrorContent(IO,FStatus.GetStatusCode(rsNoConnectionSpecified),Format(SErrNoconnection,[GetConnectionName(IO)]))
           else
-            CreateErrorContent(IO,500,Format(SErrNoconnection,[GetConnectionName(IO)]));
+            CreateErrorContent(IO,FStatus.GetStatusCode(rsError), Format(SErrNoconnection,[GetConnectionName(IO)]));
           end
-        else if not AllowRestResource(IO) then
-          CreateErrorContent(IO,403,'Forbidden')
-        else
+        else if CheckResourceAccess(IO) then
           if Operation=roOptions then
             HandleCORSRequest(Connection,IO)
           else
@@ -1365,7 +1413,7 @@ begin
         end;
       if (Code=0) then
         begin
-        Code:=500;
+        Code:=FStatus.GetStatusCode(rsError);
         Msg:=Format(SErrUnexpectedException,[E.ClassName,E.Message]);
         end;
       IO.Response.Code:=Code;
@@ -1377,7 +1425,7 @@ begin
   except
     on Ex : exception do
      begin
-     IO.Response.Code:=500;
+     IO.Response.Code:=FStatus.GetStatusCode(rsError);
      IO.Response.CodeText:=Format('Unexpected exception %s while handling original exception %s : "%s" (Original: "%s")',[Ex.ClassName,E.ClassName,Ex.Message,E.Message]);
      end;
   end;

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

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

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

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

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

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

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

@@ -21,10 +21,8 @@ interface
 uses
   Classes, SysUtils, fpjson, sqldb, db, httpdefs, sqldbrestschema;
 
-Type
-  TVariableSource = (vsNone,vsQuery,vsContent,vsRoute,vsHeader);
-  TVariableSources = Set of TVariableSource;
 
+Type
   TRestOutputOption = (ooMetadata,ooSparse,ooHumanReadable);
   TRestOutputOptions = Set of TRestOutputOption;
 
@@ -37,6 +35,8 @@ Const
 
 
 Type
+  TRestIO = Class;
+
   TRestStringProperty = (rpDateFormat,
                          rpDateTimeFormat,
                          rpTimeFormat,
@@ -133,6 +133,75 @@ Type
     Property XMLDocumentRoot : UTF8string Index ord(rpXMLDocumentRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
   end;
 
+  TRestStatus = (rsError,                   // Internal logic/unexpected error (500)
+                 rsGetOK,                   // GET command completed OK (200)
+                 rsPostOK,                  // POST command completed OK (204)
+                 rsPutOK,                   // PUT command completed OK (200)
+                 rsDeleteOK,                // DELETE command completed OK (204)
+                 rsInvalidParam,            // Something wrong/missing in Query parameters (400)
+                 rsCORSOK,                  // CORS request completed OK (200)
+                 rsCORSNotAllowed,          // CORS request not allowed (403)
+                 rsUnauthorized,            // Authentication failed (401)
+                 rsResourceNotAllowed,      // Resource request not allowed (403)
+                 rsRestOperationNotAllowed, // Resource operation (method) not allowed (405)
+                 rsInvalidMethod,           // Invalid HTTP method (400)
+                 rsUnknownResource,         // Unknown resource (404)
+                 rsNoResourceSpecified,     // Unable to determine resource (404)
+                 rsNoConnectionSpecified,   // Unable to determine connection for (400)
+                 rsRecordNotFound,          // Query did not return record for single resource (404)
+                 rsInvalidContent           // Invalid content for POST/PUT operation (400)
+
+                 );
+  TRestStatuses = set of TRestStatus;
+
+  { TRestStatusConfig }
+
+  TRestStatusConfig = Class(TPersistent)
+  private
+    FStatus : Array[TRestStatus] of Word;
+    function GetStatus(AIndex: Integer): Word;
+    function IsStatusStored(AIndex: Integer): Boolean;
+    procedure SetStatus(AIndex: Integer; AValue: Word);
+  Public
+    Procedure Assign(aSource : TPersistent); override;
+    function GetStatusCode(aStatus : TRestStatus): Word;
+  Published
+    // Internal logic/unexpected error (500)
+    Property Error : Word Index Ord(rsError) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // GET command completed OK (200)
+    Property GetOK : Word Index Ord(rsGetOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // POST command completed OK (204)
+    Property PostOK : Word Index Ord(rsPostOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // PUT command completed OK (200)
+    Property PutOK : Word Index Ord(rsPutOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // DELETE command completed OK (204)
+    Property DeleteOK : Word Index Ord(rsDeleteOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Something wrong/missing in Query parameters (400)
+    Property InvalidParam : Word Index Ord(rsInvalidParam) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // CORS request completed OK (200)
+    Property CORSOK : Word Index Ord(rsCORSOK) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // CORS request not allowed (403)
+    Property CORSNotAllowed : Word Index Ord(rsCORSNotAllowed) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Authentication failed (401)
+    Property Unauthorized : Word Index Ord(rsUnauthorized) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Resource request not allowed (403)
+    Property ResourceNotAllowed : Word Index Ord(rsResourceNotAllowed) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Resource operation (method) not allowed (405)
+    Property RestOperationNotAllowed : Word Index Ord(rsRestOperationNotAllowed) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Invalid HTTP method (400)
+    Property InvalidMethod : Word Index Ord(rsInvalidMethod) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Unknown resource (404)
+    Property UnknownResource : Word Index Ord(rsUnknownResource) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Unable to determine resource (404)
+    Property NoResourceSpecified : Word Index Ord(rsNoResourceSpecified) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Unable to determine connection for (400)
+    Property NoConnectionSpecified : Word Index Ord(rsNoConnectionSpecified) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Query did not return record for single resource (404)
+    Property RecordNotFound : Word Index Ord(rsRecordNotFound) Read GetStatus Write SetStatus Stored IsStatusStored;
+    // Invalid content for POST/PUT operation (400)
+    Property InvalidContent : Word Index Ord(rsInvalidContent) Read GetStatus Write SetStatus Stored IsStatusStored;
+  end;
+
   { TRestStreamer }
 
   TRestStreamer = Class(TObject)
@@ -140,12 +209,14 @@ Type
     FStream: TStream;
     FOnGetVar : TRestGetVariableEvent;
     FStrings: TRestStringsConfig;
+    FStatuses : TRestStatusConfig;
   Public
     // Registry
     Class Function GetContentType : String; virtual;
-    Constructor Create(aStream : TStream;aStrings : TRestStringsConfig;aOnGetVar : TRestGetVariableEvent);
+    Constructor Create(aStream : TStream;aStrings : TRestStringsConfig;aStatus : TRestStatusConfig; aOnGetVar : TRestGetVariableEvent);
     Function GetString(aString : TRestStringProperty) : UTF8String;
     Property Strings : TRestStringsConfig Read FStrings;
+    Property Statuses : TRestStatusConfig Read FStatuses;
     procedure InitStreaming; virtual; abstract;
     Function GetVariable(const aName : UTF8String) : UTF8String;
     Property Stream : TStream Read FStream;
@@ -192,6 +263,17 @@ Type
   end;
   TRestOutputStreamerClass = class of TRestOutputStreamer;
 
+  { TRestContext }
+
+  TRestContext = Class(TBaseRestContext)
+  Private
+    FIO : TRestIO;
+  Protected
+    property IO : TRestIO Read FIO;
+  Public
+    Function GetVariable(Const aName : UTF8String; aSources : TVariableSources; Out aValue : UTF8String) : Boolean; override;
+  end;
+
   { TRestIO }
 
   TRestIO = Class
@@ -205,11 +287,14 @@ Type
     FResource: TSQLDBRestResource;
     FResourceName: UTF8String;
     FResponse: TResponse;
+    FRestContext: TRestContext;
+    FRestStatuses: TRestStatusConfig;
     FRestStrings: TRestStringsConfig;
     FSchema: UTF8String;
     FTrans: TSQLTransaction;
     FContentStream : TStream;
-    FUserID: String;
+    function GetUserID: String;
+    procedure SetUserID(AValue: String);
   Protected
   Public
     Constructor Create(aRequest : TRequest; aResponse : TResponse); virtual;
@@ -220,6 +305,7 @@ Type
     Procedure SetResource(aResource : TSQLDBRestResource);
     procedure SetOperation(aOperation : TRestOperation);
     Procedure SetRestStrings(aValue : TRestStringsConfig);
+    Procedure SetRestStatuses(aValue : TRestStatusConfig);
     // Get things
     class function StrToNullBoolean(S: String; Strict: Boolean): TNullBoolean;
     Procedure DoGetVariable(Sender : TObject; Const aName : UTF8String; Out aVal : UTF8String);
@@ -229,6 +315,7 @@ Type
     function GetRequestOutputOptions(aDefault: TRestOutputOptions): TRestOutputOptions;
     function GetLimitOffset(aEnforceLimit: Int64; out aLimit, aOffset: Int64): boolean;
     // Create error response in output
+    function CreateRestContext: TRestContext; virtual;
     Procedure CreateErrorResponse;
     Property Operation : TRestOperation Read FOperation;
     // Not owned by TRestIO
@@ -238,15 +325,17 @@ Type
     Property Transaction : TSQLTransaction Read FTrans Write FTrans;
     Property Resource : TSQLDBRestResource Read FResource;
     Property RestStrings : TRestStringsConfig Read FRestStrings;
+    Property RestStatuses : TRestStatusConfig Read FRestStatuses;
     // owned by TRestIO
     Property RESTInput : TRestInputStreamer read FInput;
     Property RESTOutput : TRestOutputStreamer read FOutput;
     Property RequestContentStream : TStream Read FContentStream;
+    Property RestContext : TRestContext Read FRestContext;
     // For informative purposes
     Property ResourceName : UTF8String Read FResourceName;
     Property Schema : UTF8String Read FSchema;
     Property ConnectionName : UTF8String Read FCOnnection;
-    Property UserID : String Read FUserID Write FUserID;
+    Property UserID : String Read GetUserID Write SetUserID;
   end;
   TRestIOClass = Class of TRestIO;
 
@@ -343,6 +432,80 @@ Const
     'sql',             { rpCustomViewSQLParam }
     'datapacket'       { rpXMLDocumentRoot}
   );
+  DefaultStatuses : Array[TRestStatus] of Word = (
+    500, { rsError }
+    200, { rsGetOK }
+    201, { rsPostOK }
+    200, { rsPutOK }
+    204, { rsDeleteOK }
+    400, { rsInvalidParam }
+    200, { rsCORSOK}
+    403, { rsCORSNotallowed}
+    401, { rsUnauthorized }
+    403, { rsResourceNotAllowed }
+    405, { rsRestOperationNotAllowed }
+    400, { rsInvalidMethod }
+    404, { rsUnknownResource }
+    404, { rsNoResourceSpecified }
+    400, { rsNoConnectionSpecified }
+    404, { rsRecordNotFound }
+    400  { rsInvalidContent }
+  );
+
+{ TRestStatusConfig }
+
+function TRestStatusConfig.GetStatus(AIndex: Integer): Word;
+begin
+  Result:=GetStatusCode(TRestStatus(aIndex));
+end;
+
+function TRestStatusConfig.IsStatusStored(AIndex: Integer): Boolean;
+
+Var
+  W : Word;
+
+begin
+  W:=FStatus[TRestStatus(aIndex)];
+  Result:=(W<>0) and (W<>DefaultStatuses[TRestStatus(aIndex)]);
+end;
+
+procedure TRestStatusConfig.SetStatus(AIndex: Integer; AValue: Word);
+begin
+  if (aValue<>DefaultStatuses[TRestStatus(aIndex)]) then
+    aValue:=0;
+  FStatus[TRestStatus(aIndex)]:=aValue;
+end;
+
+procedure TRestStatusConfig.Assign(aSource: TPersistent);
+
+Var
+  C : TRestStatusConfig;
+  S : TRestStatus;
+
+begin
+  if aSource is TRestStatusConfig then
+    begin
+    C:=aSource as TRestStatusConfig;
+    for S in TRestStatus do
+      FStatus[S]:=C.FStatus[S];
+    end
+  else
+    inherited Assign(aSource);
+end;
+
+function TRestStatusConfig.GetStatusCode(aStatus: TRestStatus): Word;
+begin
+  Result:=FStatus[aStatus];
+  if Result=0 then
+    Result:=DefaultStatuses[aStatus];
+end;
+
+{ TRestContext }
+
+function TRestContext.GetVariable(const aName: UTF8String; aSources : TVariableSources; out aValue: UTF8String): Boolean;
+begin
+  Result:=FIO.GetVariable(aName,aValue,aSources)<>vsNone;
+end;
 
 { TStreamerDefList }
 
@@ -560,7 +723,7 @@ begin
     On E : Exception do
       begin
       S:=Format('Error formatting string "%s" with %d arguments. Original code: %d',[Fmt,Length(Args),aCode]);
-      aCode:=500;
+      aCode:=Statuses.GetStatusCode(rsError);
       end;
   end;
   CreateErrorContent(aCode,S);
@@ -608,11 +771,12 @@ end;
 
 { TRestStreamer }
 
-constructor TRestStreamer.Create(aStream: TStream; aStrings: TRestStringsConfig; aOnGetVar: TRestGetVariableEvent);
+constructor TRestStreamer.Create(aStream: TStream; aStrings: TRestStringsConfig; aStatus : TRestStatusConfig; aOnGetVar: TRestGetVariableEvent);
 begin
   FStream:=aStream;
   FOnGetVar:=aOnGetVar;
   FStrings:=aStrings;
+  FStatuses:=aStatus;
 end;
 
 function TRestStreamer.GetString(aString: TRestStringProperty): UTF8String;
@@ -707,21 +871,40 @@ begin
   FRestStrings:=aValue;
 end;
 
+procedure TRestIO.SetRestStatuses(aValue: TRestStatusConfig);
+begin
+  FRestStatuses:=aValue;
+end;
+
 procedure TRestIO.DoGetVariable(Sender: TObject; const aName: UTF8String; out
   aVal: UTF8String);
 begin
   GetVariable(aName,aVal);
 end;
 
+procedure TRestIO.SetUserID(AValue: String);
+begin
+  if (UserID=AValue) then Exit;
+  FRestContext.UserID:=AValue;
+end;
+
+function TRestIO.GetUserID: String;
+begin
+  Result:=FRestContext.UserID;
+end;
+
 constructor TRestIO.Create(aRequest: TRequest; aResponse: TResponse);
 begin
   FRequest:=aRequest;
   FResponse:=aResponse;
   FContentStream:=TStringStream.Create(aRequest.Content);
+  FRestContext:=CreateRestContext;
+  FRestContext.FIO:=Self;
 end;
 
 destructor TRestIO.Destroy;
 begin
+  FreeAndNil(FRestContext);
   if Assigned(FInput) then
     Finput.FOnGetVar:=Nil;
   if Assigned(Foutput) then
@@ -732,6 +915,12 @@ begin
   inherited Destroy;
 end;
 
+function TRestIO.CreateRestContext : TRestContext;
+
+begin
+  Result:=TRestContext.Create;
+end;
+
 function TRestIO.GetVariable(const aName: UTF8String; out aVal: UTF8String;
   AllowedSources: TVAriableSources): TVariableSource;
 
@@ -780,7 +969,8 @@ begin
   Result:=GetVariable(aName+FRestStrings.GetRestString(FilterStrings[aFilter]),aValue,[vsQuery]);
 end;
 
-Class function TRestIO.StrToNullBoolean(S: String; Strict: Boolean): TNullBoolean;
+class function TRestIO.StrToNullBoolean(S: String; Strict: Boolean
+  ): TNullBoolean;
 
 begin
   result:=nbNone;
@@ -810,7 +1000,8 @@ begin
     Result:=StrToNullBoolean(S,aStrict);
 end;
 
-Function TRestIO.GetRequestOutputOptions(aDefault : TRestOutputOptions) : TRestOutputOptions;
+function TRestIO.GetRequestOutputOptions(aDefault: TRestOutputOptions
+  ): TRestOutputOptions;
 
   Procedure CheckParam(aName : String; aOption: TRestOutputOption);
   begin
@@ -842,11 +1033,11 @@ begin
   if Not Result then
     Exit;
   if (S<>'') and not TryStrToInt64(S,aLimit) then
-    Raise ESQLDBRest.CreateFmt(400,SErrInvalidParam,[P]);
+    Raise ESQLDBRest.CreateFmt(RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidParam,[P]);
   P:=RestStrings.GetRestString(rpOffset);
   if GetVariable(P,S,[vsQuery])<>vsNone then
     if (S<>'') and not TryStrToInt64(S,aOffset) then
-      Raise ESQLDBRest.CreateFmt(400,SErrInvalidParam,[P]);
+      Raise ESQLDBRest.CreateFmt(RestStatuses.GetStatusCode(rsInvalidParam),SErrInvalidParam,[P]);
   if (aEnforceLimit>0) and (aLimit>aEnforceLimit) then
     aLimit:=aEnforceLimit;
 end;

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

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

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

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

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

@@ -158,13 +158,13 @@ begin
       end;
   end;
   if (FXML=Nil)  then
-    Raise ESQLDBRest.CreateFmt(400,SErrInvalidXMLInput,[Msg]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[Msg]);
   FPacket:=FXML.DocumentElement;
   NN:=UTF8Decode(GetString(rpXMLDocumentRoot));
   if (NN<>'') then
     begin
     if FPacket.NodeName<>NN then
-      Raise ESQLDBRest.CreateFmt(400,SErrInvalidXMLInput,[SErrMissingDocumentRoot]);
+      Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[SErrMissingDocumentRoot]);
     NN:=UTF8Decode(GetString(rpDataRoot));
     N:=FPacket.FindNode(NN);
     end
@@ -178,7 +178,7 @@ begin
       N:=Nil
     end;
   if Not (Assigned(N) and (N is TDOMelement)) then
-    Raise ESQLDBRest.CreateFmt(400,SErrInvalidXMLInputMissingElement,[NN]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInputMissingElement,[NN]);
   FData:=(N as TDOMelement);
 end;
 
@@ -211,7 +211,7 @@ end;
 procedure TXMLOutputStreamer.StartRow;
 begin
   if (FRow<>Nil) then
-    Raise ESQLDBRest.Create(500,SErrDoubleRowStart);
+    Raise ESQLDBRest.Create(Statuses.GetStatusCode(rsError),SErrDoubleRowStart);
   FRow:=FXML.CreateElement(UTF8Decode(GetString(rpRowName)));
   FData.AppendChild(FRow);
 end;
@@ -226,7 +226,7 @@ begin
   Result:=Nil;
   F:=aPair.DBField;;
   If (aPair.RestField.FieldType=rftUnknown) then
-    raise ESQLDBRest.CreateFmt(500,SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
+    raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
   If (F.IsNull) then
     Exit;
   S:=FieldToString(aPair.RestField.FieldType,F);
@@ -243,7 +243,7 @@ Var
 begin
   N:=aPair.RestField.PublicName;
   if FRow=Nil then
-    Raise ESQLDBRest.CreateFmt(500,SErrFieldWithoutRow,[N]);
+    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]);
   D:=FieldToXML(aPair);
   if (D=Nil) and (not HasOption(ooSparse)) then
     D:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName));

packages/pastojs/src/fppas2js.pp

@@ -521,6 +521,7 @@ const
   nJSNewNotSupported = 4026;
   nHelperClassMethodForExtClassMustBeStatic = 4027;
   nBitWiseOperationIs32Bit = 4028;
+  nDuplicateMessageIdXAtY = 4029;
 // resourcestring patterns of messages
 resourcestring
   sPasElementNotSupported = 'Pascal element not supported: %s';
@@ -551,6 +552,7 @@ resourcestring
   sJSNewNotSupported = 'Pascal class does not support the "new" constructor';
   sHelperClassMethodForExtClassMustBeStatic = 'Helper class method for external class must be static';
   sBitWiseOperationIs32Bit = 'Bitwise operation is 32-bit';
+  sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s';
 
 const
   ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
@@ -559,6 +561,7 @@ const
 
 type
   TPas2JSBuiltInName = (
+    // functions
     pbifnArray_Concat,
     pbifnArray_ConcatN,
     pbifnArray_Copy,
@@ -660,12 +663,15 @@ type
     pbifnSpaceLeft,
     pbifnStringSetLength,
     pbifnUnitInit,
+    // variables
     pbivnExceptObject,
     pbivnIntfExprRefs,
     pbivnIntfGUID,
     pbivnIntfKind,
     pbivnIntfMaps,
     pbivnImplementation,
+    pbivnMessageInt,
+    pbivnMessageStr,
     pbivnLoop,
     pbivnLoopEnd,
     pbivnLoopIn,
@@ -699,6 +705,7 @@ type
     pbivnSelf,
     pbivnTObjectDestroy,
     pbivnWith,
+    // types
     pbitnAnonymousPostfix,
     pbitnIntDouble,
     pbitnTI,
@@ -828,6 +835,8 @@ const
     '$kind',
     '$intfmaps',
     '$impl',
+    '$msgint', // pbivnMessageInt
+    '$msgstr', // pbivnMessageStr
     '$l',
     '$end',
     '$in',
@@ -1108,12 +1117,16 @@ type
     JS: string; // Option coStoreProcJS
   end;
 
+  TMessageIdToProc_List = TStringList;
+
   { TPas2JSClassScope }
 
   TPas2JSClassScope = class(TPasClassScope)
   public
     NewInstanceFunction: TPasClassFunction;
     GUID: string;
+    MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // temporary lists, not stored by filer!
+    destructor Destroy; override;
   end;
 
   { TPas2JSProcedureScope }
@@ -1393,6 +1406,8 @@ type
     function HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
     function IsTGUID(TypeEl: TPasRecordType): boolean; override;
     function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGuid): boolean;
+    procedure AddMessageStr(var MsgToProc: TMessageIdToProc_List; const S: string; Proc: TPasProcedure);
+    procedure AddMessageIdToClassScope(Proc: TPasProcedure); virtual;
     // CustomData
     function GetElementData(El: TPasElementBase;
       DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
@@ -1813,6 +1828,8 @@ type
     Procedure AddClassRTTI(El: TPasClassType; Src: TJSSourceElements;
       FuncContext: TFunctionContext);
     Procedure AddClassConstructors(FuncContext: TFunctionContext; PosEl: TPasElement);
+    Procedure AddClassMessageIds(El: TPasClassType; Src: TJSSourceElements;
+      FuncContext: TFunctionContext; pbivn: TPas2JSBuiltInName);
     // misc
     Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult;
       AContext: TConvertContext): TJSElement; virtual;
@@ -2139,6 +2156,15 @@ begin
   Result:='['+Result+']';
 end;
 
+{ TPas2JSClassScope }
+
+destructor TPas2JSClassScope.Destroy;
+begin
+  FreeAndNil(MsgIntToProc);
+  FreeAndNil(MsgStrToProc);
+  inherited Destroy;
+end;
+
 { TRootContext }
 
 procedure TRootContext.AddGlobalClassMethod(p: TPasProcedure);
@@ -3807,7 +3833,7 @@ begin
 
     for pm in Proc.Modifiers do
       if (not (pm in [pmVirtual, pmAbstract, pmOverride,
-                      pmOverload, pmReintroduce,
+                      pmOverload, pmMessage, pmReintroduce,
                       pmInline, pmAssembler, pmPublic,
                       pmExternal, pmForward])) then
         RaiseNotYetImplemented(20170208142159,El,'modifier '+ModifierNames[pm]);
@@ -3823,6 +3849,22 @@ begin
       RaiseMsg(20170324150417,nPasElementNotSupported,sPasElementNotSupported,
         ['public name'],Proc.PublicName);
 
+    // modifier dispid
+    if Proc.DispIDExpr<>nil then
+      RaiseMsg(20190303225224,nPasElementNotSupported,sPasElementNotSupported,
+        ['dispid'],Proc.DispIDExpr);
+
+    // modifier message
+    if Proc.MessageExpr<>nil then
+      begin
+      if (not (Proc.Parent is TPasClassType))
+          or (TPasClassType(Proc.Parent).ObjKind<>okClass) then
+        RaiseMsg(20190303231445,nInvalidXModifierY,sInvalidXModifierY,['message','at non class method'],Proc.MessageExpr);
+      if TPasClassType(Proc.Parent).IsExternal then
+        RaiseMsg(20190304002235,nInvalidXModifierY,sInvalidXModifierY,['message','in external class'],Proc.MessageExpr);
+      AddMessageIdToClassScope(Proc);
+      end;
+
     if Proc.Parent is TPasMembersType then
       begin
       // class/record member
@@ -5261,21 +5303,22 @@ begin
   if Expr=nil then
     RaiseInternalError(20170215123600);
   Value:=Eval(Expr,[refAutoConst],StoreCustomData);
-  try
-    case Value.Kind of
-    {$IFDEF FPC_HAS_CPSTRING}
-    revkString: Result:=ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr);
-    revkUnicodeString: Result:=UTF8Encode(TResEvalUTF16(Value).S);
-    {$ELSE}
-    revkUnicodeString: Result:=TResEvalUTF16(Value).S;
-    {$ENDIF}
-    else
-      str(Value.Kind,Result);
-      RaiseXExpectedButYFound(20170211221121,'string literal',Result,Expr);
+  if Value<>nil then
+    try
+      case Value.Kind of
+      {$IFDEF FPC_HAS_CPSTRING}
+      revkString: Result:=ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr);
+      revkUnicodeString: Result:=UTF8Encode(TResEvalUTF16(Value).S);
+      {$ELSE}
+      revkUnicodeString: Result:=TResEvalUTF16(Value).S;
+      {$ENDIF}
+      else
+        str(Value.Kind,Result);
+        RaiseXExpectedButYFound(20170211221121,'string literal',Result,Expr);
+      end;
+    finally
+      ReleaseEvalValue(Value);
     end;
-  finally
-    ReleaseEvalValue(Value);
-  end;
 
   if NotEmpty and (Result='') then
     RaiseXExpectedButYFound(20170321085318,'string literal','empty',Expr);
@@ -5375,6 +5418,55 @@ begin
   end;
 end;
 
+procedure TPas2JSResolver.AddMessageStr(var MsgToProc: TMessageIdToProc_List;
+  const S: string; Proc: TPasProcedure);
+var
+  i: Integer;
+begin
+  if MsgToProc=nil then
+    MsgToProc:=TMessageIdToProc_List.Create
+  else
+    begin
+    // check duplicate
+    for i:=0 to MsgToProc.Count-1 do
+      if MsgToProc[i]=S then
+        RaiseMsg(20190303233647,nDuplicateMessageIdXAtY,sDuplicateMessageIdXAtY,
+          [S,GetElementSourcePosStr(TPasProcedure(MsgToProc.Objects[i]).MessageExpr)],Proc.MessageExpr);
+    end;
+  MsgToProc.AddObject(S,Proc);
+end;
+
+procedure TPas2JSResolver.AddMessageIdToClassScope(Proc: TPasProcedure);
+var
+  AClass: TPasClassType;
+  ClassScope: TPas2JSClassScope;
+  Expr: TPasExpr;
+  Value: TResEvalValue;
+begin
+  AClass:=TPasClassType(Proc.Parent);
+  ClassScope:=TPas2JSClassScope(AClass.CustomData);
+  Expr:=Proc.MessageExpr;
+  Value:=Eval(Expr,[refConst]);
+  if Value=nil then
+    RaiseMsg(20190303225651,nIllegalExpressionAfterX,sIllegalExpressionAfterX,['message modifier'],Expr);
+  try
+    case Value.Kind of
+    {$ifdef FPC_HAS_CPSTRING}
+    revkString:
+      AddMessageStr(ClassScope.MsgStrToProc,ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr),Proc);
+    {$ENDIF}
+    revkUnicodeString:
+      AddMessageStr(ClassScope.MsgStrToProc,String(TResEvalUTF16(Value).S),Proc);
+    revkInt:
+      AddMessageStr(ClassScope.MsgIntToProc,IntToStr(TResEvalInt(Value).Int),Proc);
+    else
+      RaiseXExpectedButYFound(20190303225849,'integer constant',Value.AsString,Expr);
+    end;
+  finally
+    ReleaseEvalValue(Value);
+  end;
+end;
+
 function TPas2JSResolver.GetElementData(El: TPasElementBase;
   DataClass: TPas2JsElementDataClass): TPas2JsElementData;
 begin
@@ -12823,11 +12915,14 @@ var
   C: TClass;
   AssignSt: TJSSimpleAssignStatement;
   NeedInitFunction, HasConstructor: Boolean;
+  Proc: TPasProcedure;
+  aResolver: TPas2JSResolver;
 begin
   Result:=nil;
   {$IFDEF VerbosePas2JS}
   writeln('TPasToJSConverter.ConvertClassType START ',GetObjName(El));
   {$ENDIF}
+  aResolver:=AContext.Resolver;
   if not (El.ObjKind in [okClass,okInterface,okClassHelper,okRecordHelper,okTypeHelper]) then
     RaiseNotSupported(El,AContext,20170927183645);
   if El.Parent is TProcedureBody then
@@ -12850,6 +12945,8 @@ begin
       Ancestor:=nil;
       IsTObject:=(El.ObjKind=okClass) and SameText(El.Name,'TObject');
       end;
+    FreeAndNil(Scope.MsgIntToProc);
+    FreeAndNil(Scope.MsgStrToProc);
     end
   else
     begin
@@ -13012,6 +13109,7 @@ begin
           NewEl:=nil;
           C:=P.ClassType;
           if not (P is TPasProcedure) then continue;
+          Proc:=TPasProcedure(P);
           if IsTObject and (C=TPasDestructor) then
             begin
             DestructorName:=TransformVariableName(P,AContext);
@@ -13029,10 +13127,12 @@ begin
           else if (C=TPasClassConstructor)
               or (C=TPasClassDestructor) then
             begin
-            AddGlobalClassMethod(AContext,TPasProcedure(P));
+            AddGlobalClassMethod(AContext,Proc);
             continue;
-            end;
-          NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext);
+            end
+          else if (Proc.MessageExpr<>nil) and (aResolver<>nil) then
+            aResolver.AddMessageIdToClassScope(Proc);
+          NewEl:=ConvertProcedure(Proc,FuncContext);
           if NewEl=nil then
             continue; // e.g. abstract or external proc
           AddToSourceElements(Src,NewEl);
@@ -13041,13 +13141,16 @@ begin
           AddHelperConstructor(El,Src,FuncContext);
         end;
 
-      // add interfaces
-      if (El.ObjKind=okClass) and (AContext.Resolver<>nil) then
-        AddClassSupportedInterfaces(El,Src,FuncContext);
-
-      // add RTTI init function
-      if AContext.Resolver<>nil then
+      if aResolver<>nil then
+        begin
+        // add interfaces
+        if (El.ObjKind=okClass) then
+          AddClassSupportedInterfaces(El,Src,FuncContext);
+        AddClassMessageIds(El,Src,FuncContext,pbivnMessageInt);
+        AddClassMessageIds(El,Src,FuncContext,pbivnMessageStr);
+        // add RTTI init function
         AddClassRTTI(El,Src,FuncContext);
+        end;
 
       end;// end of init function
 
@@ -15764,6 +15867,44 @@ begin
   end;
 end;
 
+procedure TPasToJSConverter.AddClassMessageIds(El: TPasClassType;
+  Src: TJSSourceElements; FuncContext: TFunctionContext;
+  pbivn: TPas2JSBuiltInName);
+// $msgint = { id1:"proc1name", id2: "proc2name" ... }
+var
+  Scope: TPas2JSClassScope;
+  List: TMessageIdToProc_List;
+  i: Integer;
+  AssignSt: TJSSimpleAssignStatement;
+  ObjLit: TJSObjectLiteral;
+  LitEl: TJSObjectLiteralElement;
+  Proc: TPasProcedure;
+begin
+  Scope:=TPas2JSClassScope(El.CustomData);
+  case pbivn of
+  pbivnMessageInt: List:=Scope.MsgIntToProc;
+  pbivnMessageStr: List:=Scope.MsgStrToProc;
+  else
+    RaiseNotSupported(El,FuncContext,20190304001209,GetBIName(pbivn));
+  end;
+  if (List=nil) or (List.Count=0) then exit;
+
+  // this.$msgint = {}
+  AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
+  AddToSourceElements(Src,AssignSt);
+  AssignSt.LHS:=CreateMemberExpression(['this',GetBIName(pbivn)]);
+  ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
+  AssignSt.Expr:=ObjLit;
+
+  for i:=0 to List.Count-1 do
+    begin
+    LitEl:=ObjLit.Elements.AddElement;
+    LitEl.Name:=TJSString(List[i]);
+    Proc:=TPasProcedure(List.Objects[i]);
+    LitEl.Expr:=CreateLiteralJSString(Proc,TJSString(TransformVariableName(Proc,FuncContext)));
+    end;
+end;
+
 function TPasToJSConverter.CreateCallback(Expr: TPasExpr;
   ResolvedEl: TPasResolverResult; AContext: TConvertContext): TJSElement;
 // El is a reference to a proc
@@ -17769,12 +17910,14 @@ var
   function ConvertImplicitLeftIdentifier(PosEl: TPasElement;
     const LeftResolved: TPasResolverResult): TJSElement;
   var
-    GetExpr, SetExpr: TJSElement;
+    GetExpr, SetExpr, RHS: TJSElement;
     SetterArgName: string;
     AssignSt: TJSSimpleAssignStatement;
     Arg: TPasArgument;
+    TypeEl: TPasType;
+    IsCOMIntf: Boolean;
   begin
-    // implicit Left (e.g. with Left do proc, or (Self.)proc)
+    // implicit Left (e.g. "with Left do proc", or "Proc")
 
     if LeftResolved.IdentEl is TPasArgument then
       begin
@@ -17795,13 +17938,26 @@ var
     if rrfWritable in LeftResolved.Flags then
       begin
       // SetExpr  "ImplicitLeft = v"
+      TypeEl:=LeftResolved.LoTypeEl;
+      IsCOMIntf:=(TypeEl is TPasClassType)
+             and (TPasClassType(TypeEl).ObjKind=okInterface)
+             and (TPasClassType(TypeEl).InterfaceType=citCom);
       SetExpr:=ConvertLeftExpr;
       SetterArgName:=TempRefObjSetterArgName;
       FindAvailableLocalName(SetterArgName,SetExpr);
-      AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
-      AssignSt.LHS:=SetExpr;
-      AssignSt.Expr:=CreatePrimitiveDotExpr(SetterArgName,PosEl);
-      SetExpr:=AssignSt;
+      RHS:=CreatePrimitiveDotExpr(SetterArgName,PosEl);
+      if IsCOMIntf then
+        begin
+        // create   rtl.setIntfP(path,"IntfVar",v)
+        SetExpr:=CreateAssignComIntfVar(LeftResolved,SetExpr,RHS,AContext,PosEl);
+        end
+      else
+        begin
+        AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
+        AssignSt.LHS:=SetExpr;
+        AssignSt.Expr:=RHS;
+        SetExpr:=AssignSt;
+        end;
       end
     else
       begin
@@ -17818,10 +17974,12 @@ var
   var
     Prop: TPasProperty;
     OldAccess: TCtxAccess;
-    GetExpr, SetExpr, LeftJS, PathExpr: TJSElement;
+    GetExpr, SetExpr, LeftJS, PathExpr, RHS: TJSElement;
     DotExpr: TJSDotMemberExpression;
     AssignSt: TJSSimpleAssignStatement;
     SetterArgName, aName: String;
+    TypeEl: TPasType;
+    IsCOMIntf: Boolean;
   begin
     // explicit Left is property
     // path.Prop.Proc or Prop.Proc
@@ -17835,6 +17993,11 @@ var
     writeln('CreatePropertyReference LeftJS=',GetObjName(LeftJS));
     {$ENDIF}
 
+    TypeEl:=LeftResolved.LoTypeEl;
+    IsCOMIntf:=(TypeEl is TPasClassType)
+           and (TPasClassType(TypeEl).ObjKind=okInterface)
+           and (TPasClassType(TypeEl).InterfaceType=citCom);
+
     PathExpr:=nil;
     SetterArgName:='';
     if LeftJS=nil then
@@ -17856,17 +18019,28 @@ var
       aName:=String(DotExpr.Name);
       DotExpr.Free;
       GetExpr:=CreateMemberExpression(['this',TempRefGetPathName,aName]);
-      AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
+      SetterArgName:=TempRefObjSetterArgName;
+      RHS:=CreatePrimitiveDotExpr(SetterArgName,PosEl);
       if vmClass in Prop.VarModifiers then
         // assign class field -> always use class path
-        AssignSt.LHS:=CreateDotExpression(PosEl,
+        SetExpr:=CreateDotExpression(PosEl,
            CreateReferencePathExpr(Prop.Parent,AContext),
            CreatePrimitiveDotExpr(aName,PosEl))
       else
-        AssignSt.LHS:=CreateMemberExpression(['this',TempRefGetPathName,aName]);
-      SetExpr:=AssignSt;
-      SetterArgName:=TempRefObjSetterArgName;
-      AssignSt.Expr:=CreatePrimitiveDotExpr(SetterArgName,PosEl);
+        SetExpr:=CreateMemberExpression(['this',TempRefGetPathName,aName]);
+      if IsCOMIntf then
+        begin
+        // create   rtl.setIntfP(path,"IntfVar",v)
+        SetExpr:=CreateAssignComIntfVar(LeftResolved,SetExpr,RHS,AContext,PosEl);
+        end
+      else
+        begin
+        // create  SetExpr=v
+        AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
+        AssignSt.LHS:=SetExpr;
+        SetExpr:=AssignSt;
+        AssignSt.Expr:=RHS;
+        end;
       end
     else if LeftJS.ClassType=TJSCallExpression then
       begin
@@ -17907,9 +18081,8 @@ var
   end;
 
 var
-  Helper: TPasClassType;
   aResolver: TPas2JSResolver;
-  HelperForType, LoTypeEl: TPasType;
+  LoTypeEl: TPasType;
   Bin: TBinaryExpr;
   LeftResolved: TPasResolverResult;
   SelfJS: TJSElement;
@@ -17931,8 +18104,8 @@ begin
   {$ENDIF}
   Result:=nil;
   aResolver:=AContext.Resolver;
-  Helper:=Proc.Parent as TPasClassType;
-  HelperForType:=aResolver.ResolveAliasType(Helper.HelperForType);
+  //Helper:=Proc.Parent as TPasClassType;
+  //HelperForType:=aResolver.ResolveAliasType(Helper.HelperForType);
   IsStatic:=aResolver.MethodIsStatic(Proc);
   WithExprScope:=nil;
   SelfScope:=nil;
@@ -18067,14 +18240,12 @@ begin
       // normal method, neither static nor class method
       if IdentEl is TPasType then
         RaiseNotSupported(PosEl,AContext,20190201170843);
-      if (LoTypeEl is TPasClassType) and (rrfReadable in LeftResolved.Flags) then
+      if (LoTypeEl is TPasClassType) and (rrfReadable in LeftResolved.Flags)
+          and (TPasClassType(LoTypeEl).ObjKind=okClass) then
         begin
         // ClassInstance.HelperCall -> HelperType.HelperCall.call(ClassInstance,args?)
         SelfJS:=ConvertLeftExpr;
         end
-      else if HelperForType.ClassType=TPasClassType then
-        // only class helper can help a class
-        RaiseNotSupported(PosEl,AContext,20190203171241)
       else if (LoTypeEl is TPasRecordType) and (rrfReadable in LeftResolved.Flags) then
         begin
         // RecordInstance.HelperCall -> HelperType.HelperCall.call(RecordInstance,args?)
@@ -18088,7 +18259,8 @@ begin
             or (C=TPasConst)
             or (C=TPasProperty)
             or (C=TPasResultElement)
-            or (C=TPasEnumValue) then
+            or (C=TPasEnumValue)
+            or (C=TPasClassType) then
           begin
           // Left.HelperCall -> HelperType.HelperCall.call({get,set},args?)
           SelfJS:=CreateReference(PosEl,LeftResolved);
@@ -18117,11 +18289,14 @@ begin
       if not (rrfNewInstance in Ref.Flags) then
         RaiseNotSupported(PosEl,AContext,20190206151901);
       // new instance
-      if (LoTypeEl<>nil) and ((LoTypeEl.ClassType=TPasClassType)
-          or (LoTypeEl.ClassType=TPasClassOfType)) then
+      if (LoTypeEl<>nil)
+          and ((LoTypeEl.ClassType=TPasClassType)
+            or (LoTypeEl.ClassType=TPasClassOfType)) then
         begin
         // aClassVarOrType.HelperCall(args)
         //  -> aClassVarOrType.$create(HelperType.HelperCall,[args])
+        if (LoTypeEl.ClassType=TPasClassType) and (TPasClassType(LoTypeEl).ObjKind<>okClass) then
+          RaiseNotSupported(PosEl,AContext,20190302154215,GetElementTypeName(LoTypeEl));
         Call:=CreateCallExpression(PosEl);
         SelfJS:=ConvertLeftExpr;
         Call.Expr:=CreateDotExpression(PosEl,SelfJS,
@@ -21606,7 +21781,6 @@ begin
     ParamContext.Arg:=TargetArg;
     ParamContext.Expr:=El;
     ParamContext.ResolvedExpr:=ResolvedEl;
-    writeln('AAA1 TPasToJSConverter.CreateProcCallArgRef ',GetObjName(El));
     FullGetter:=ConvertExpression(El,ParamContext);
     // FullGetter is now a full JS expression to retrieve the value.
     if ParamContext.ReusingReference then

packages/pastojs/src/pas2jsfiler.pp

@@ -3795,6 +3795,7 @@ begin
       Obj.Add('Alias',El.AliasName);
     DefProcMods:=GetDefaultProcModifiers(El);
     WriteProcedureModifiers(Obj,'PMods',El.Modifiers,DefProcMods);
+    WriteExpr(Obj,El,'Msg',El.MessageExpr,aContext);
     if (El.MessageName<>'') or (El.MessageType<>pmtNone) then
       begin
       Obj.Add('Message',El.MessageName);
@@ -7574,6 +7575,7 @@ begin
     El.LibrarySymbolName:=ReadExpr(Obj,El,'LibName',aContext);
     El.DispIDExpr:=ReadExpr(Obj,El,'DispId',aContext);
     ReadString(Obj,'Alias',El.AliasName,El);
+    El.MessageExpr:=ReadExpr(Obj,El,'Msg',aContext);
     if ReadString(Obj,'Message',s,El) then
       begin
       El.MessageName:=s;

packages/pastojs/tests/tcmodules.pas

@@ -531,6 +531,8 @@ type
     Procedure TestClass_TObjectFreeFunctionFail;
     Procedure TestClass_TObjectFreePropertyFail;
     Procedure TestClass_ForIn;
+    Procedure TestClass_Message;
+    Procedure TestClass_Message_DuplicateIntFail;
 
     // class of
     Procedure TestClassOf_Create;
@@ -681,6 +683,7 @@ type
     Procedure TestTypeHelper_Array;
     Procedure TestTypeHelper_EnumType;
     Procedure TestTypeHelper_SetType;
+    Procedure TestTypeHelper_InterfaceType;
 
     // proc types
     Procedure TestProcType;
@@ -9992,6 +9995,7 @@ begin
   '  doit(vc,vc,vl,vl);',
   '  doit(vv,vv,vv,vv);',
   '  doit(vl,vl,vl,vl);',
+  //'  TRecord(U).i:=3;',
   'end;',
   'var i: TRecord;',
   'begin',
@@ -14346,6 +14350,58 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClass_Message;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure Fly(var Msg); virtual; abstract; message 2;',
+  '    procedure Run; overload; virtual; abstract;',
+  '    procedure Run(var Msg); overload; message ''Fast'';',
+  '  end;',
+  'procedure TObject.Run(var Msg);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClass_Message',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.Run$1 = function (Msg) {',
+    '  };',
+    '  this.$msgint = {',
+    '    "2": "Fly"',
+    '  };',
+    '  this.$msgstr = {',
+    '    Fast: "Run$1"',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
+procedure TTestModule.TestClass_Message_DuplicateIntFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure Fly(var Msg); virtual; abstract; message 3;',
+  '    procedure Run(var Msg); virtual; abstract; message 1+2;',
+  '  end;',
+  'begin',
+  '']);
+  SetExpectedPasResolverError('Duplicate message id "3" at test1.pp(5,56)',nDuplicateMessageIdXAtY);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestClassOf_Create;
 begin
   StartProgram(false);
@@ -23287,6 +23343,134 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestTypeHelper_InterfaceType;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces com}',
+  '{$modeswitch typehelpers}',
+  'type',
+  '  IUnknown = interface',
+  '    function _AddRef: longint;',
+  '    function _Release: longint;',
+  '  end;',
+  '  TObject = class(IUnknown)',
+  '    function _AddRef: longint; virtual; abstract;',
+  '    function _Release: longint; virtual; abstract;',
+  '  end;',
+  '  THelper = type helper for IUnknown',
+  '    procedure Fly(e: byte = 123);',
+  '    class procedure Run; static;',
+  '  end;',
+  'var',
+  '  i: IUnknown;',
+  '  o: TObject;',
+  'procedure THelper.Fly(e: byte);',
+  'begin',
+  '  i:=Self;',
+  '  o:=Self as TObject;',
+  '  Self:=nil;',
+  '  Self:=i;',
+  '  Self:=o;',
+  '  with Self do begin',
+  '    Fly;',
+  '    Fly();',
+  '  end;',
+  'end;',
+  'class procedure THelper.Run;',
+  'var l: IUnknown;',
+  'begin',
+  '  l.Fly;',
+  '  l.Fly();',
+  'end;',
+  'begin',
+  '  i.Fly;',
+  '  i.Fly();',
+  '  i.Run;',
+  '  i.Run();',
+  '  IUnknown.Run;',
+  '  IUnknown.Run();',
+  '']);
+  ConvertProgram;
+  CheckSource('TestTypeHelper_InterfaceType',
+    LinesToStr([ // statements
+    'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  rtl.addIntf(this, $mod.IUnknown);',
+    '});',
+    'rtl.createHelper($mod, "THelper", null, function () {',
+    '  this.Fly = function (e) {',
+    '    var $ir = rtl.createIntfRefs();',
+    '    try {',
+    '      rtl.setIntfP($mod, "i", this.get());',
+    '      $mod.o = rtl.intfAsClass(this.get(), $mod.TObject);',
+    '      this.set(null);',
+    '      this.set($mod.i);',
+    '      this.set($ir.ref(1, rtl.queryIntfT($mod.o, $mod.IUnknown)));',
+    '      var $with1 = this.get();',
+    '      $mod.THelper.Fly.call(this, 123);',
+    '      $mod.THelper.Fly.call(this, 123);',
+    '    } finally {',
+    '      $ir.free();',
+    '    };',
+    '  };',
+    '  this.Run = function () {',
+    '    var l = null;',
+    '    try {',
+    '      $mod.THelper.Fly.call({',
+    '        get: function () {',
+    '            return l;',
+    '          },',
+    '        set: function (v) {',
+    '            l = rtl.setIntfL(l, v);',
+    '          }',
+    '      }, 123);',
+    '      $mod.THelper.Fly.call({',
+    '        get: function () {',
+    '            return l;',
+    '          },',
+    '        set: function (v) {',
+    '            l = rtl.setIntfL(l, v);',
+    '          }',
+    '      }, 123);',
+    '    } finally {',
+    '      rtl._Release(l);',
+    '    };',
+    '  };',
+    '});',
+    'this.i = null;',
+    'this.o = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.THelper.Fly.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.i;',
+    '    },',
+    '  set: function (v) {',
+    '      rtl.setIntfP(this.p, "i", v);',
+    '    }',
+    '}, 123);',
+    '$mod.THelper.Fly.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.i;',
+    '    },',
+    '  set: function (v) {',
+    '      rtl.setIntfP(this.p, "i", v);',
+    '    }',
+    '}, 123);',
+    '$mod.THelper.Run();',
+    '$mod.THelper.Run();',
+    '$mod.THelper.Run();',
+    '$mod.THelper.Run();',
+    '']));
+end;
+
 procedure TTestModule.TestProcType;
 begin
   StartProgram(false);

packages/rtl-objpas/src/i386/invoke.inc

@@ -21,6 +21,8 @@ function ReturnResultInParam(aType: PTypeInfo): Boolean;
 var
   td: PTypeData;
 begin
+  { Only on Win32 structured types of sizes 1, 2 and 4 are returned directly
+    instead of a result parameter }
   Result := False;
   if Assigned(aType) then begin
     case aType^.Kind of
@@ -33,12 +35,20 @@ begin
       tkDynArray:
         Result := True;
       tkArray: begin
+{$ifdef win32}
         td := GetTypeData(aType);
         Result := not (td^.ArrayData.Size in [1, 2, 4]);
+{$else}
+        Result := True;
+{$endif}
       end;
       tkRecord: begin
+{$ifdef win32}
         td := GetTypeData(aType);
         Result := not (td^.RecSize in [1, 2, 4]);
+{$else}
+        Result := True;
+{$endif}
       end;
       tkSet: begin
         td := GetTypeData(aType);

packages/rtl-objpas/src/inc/variants.pp

@@ -2488,12 +2488,25 @@ begin
   DoOleVarFromVar(TVarData(aDest), TVarData(aSource));
 end;
 
-procedure sysolevarfromint(var Dest : olevariant; const Source : LongInt; const range : ShortInt);
+procedure sysolevarfromint(var Dest : olevariant; const Source : Int64; const range : ShortInt);
 begin
   DoVarClearIfComplex(TVarData(Dest));
+  { 64-bit values have their own types, all smaller ones are stored as signed 32-bit value }
   with TVarData(Dest) do begin
-    vInteger := Source;
-    vType := varInteger;
+    case range of
+      -8: begin
+        vInt64 := Int64(Source);
+        vType := varInt64;
+      end;
+      8: begin
+        vQWord := QWord(Source);
+        vType := varQWord;
+      end;
+      else begin
+        vInteger := LongInt(Source);
+        vType := varInteger;
+      end;
+    end;
   end;
 end;
 

rtl/amicommon/athreads.pp

@@ -741,6 +741,7 @@ end;
 Type  PINTRTLEvent = ^TINTRTLEvent;
       TINTRTLEvent = record
         isset: boolean;
+        Sem: TSignalSemaphore; // Semaphore to protect the whole stuff
       end;
 
 Function intRTLEventCreate: PRTLEvent;
@@ -749,6 +750,8 @@ var p:pintrtlevent;
 
 begin
   new(p);
+  p^.isset:=false;
+  InitSemaphore(@p^.Sem);
   result:=PRTLEVENT(p);
 end;
 
@@ -766,7 +769,9 @@ var p:pintrtlevent;
 
 begin
   p:=pintrtlevent(aevent);
+  ObtainSemaphore(@p^.Sem);
   p^.isset:=true;
+  ReleaseSemaphore(@p^.Sem);
 end;
 
 
@@ -775,7 +780,9 @@ var p:pintrtlevent;
 
 begin
   p:=pintrtlevent(aevent);
+  ObtainSemaphore(@p^.Sem);
   p^.isset:=false;
+  ReleaseSemaphore(@p^.Sem);
 end;
 
 
@@ -784,7 +791,15 @@ var p:pintrtlevent;
 
 begin
   p:=pintrtlevent(aevent);
+  ObtainSemaphore(@p^.Sem);
+  while not p^.isset do 
+    begin
+      ReleaseSemaphore(@p^.Sem);
+      DOSDelay(1);
+      ObtainSemaphore(@p^.Sem);
+    end;
   p^.isset:=false;
+  ReleaseSemaphore(@p^.Sem);
 end;
 
 procedure intRTLEventWaitForTimeout(AEvent: PRTLEvent;timeout : longint);
@@ -792,6 +807,17 @@ var
   p : pintrtlevent;
 begin
   p:=pintrtlevent(aevent);
+  timeout:=timeout div 20; // DOSDelay expects (1/50 seconds)
+  ObtainSemaphore(@p^.Sem);
+  while (not p^.isset) and (timeout > 0) do
+    begin
+      ReleaseSemaphore(@p^.Sem);
+      DOSDelay(1);
+      dec(timeout);
+      ObtainSemaphore(@p^.Sem);
+    end;
+  p^.isset:=false;
+  ReleaseSemaphore(@p^.Sem);
 end;
 
 

rtl/amicommon/tthread.inc

@@ -120,6 +120,14 @@ end;
 
 function TThread.WaitFor: Integer;
 begin
+  if MainThreadID=GetCurrentThreadID then
+    {
+     FFinished is set after DoTerminate, which does a synchronize of OnTerminate,
+     so make sure synchronize works (or indeed any other synchronize that may be
+     in progress)
+    }
+    while not FFinished do
+      CheckSynchronize(100);
+
   result:=WaitForThreadTerminate(FThreadID,0);
-  FFinished:=(result = 0);
 end;

rtl/inc/varianth.inc

@@ -186,7 +186,7 @@ type
       olevarfrompstr: procedure(var dest : olevariant; const source : shortstring);
       olevarfromlstr: procedure(var dest : olevariant; const source : ansistring);
       olevarfromvar: procedure(var dest : olevariant; const source : variant);
-      olevarfromint: procedure(var dest : olevariant; const source : longint;const range : shortint);
+      olevarfromint: procedure(var dest : olevariant; const source : int64;const range : shortint);
 
       { operators }
       varop : procedure(var left : variant;const right : variant;opcode : tvarop);

rtl/objpas/sysutils/sysencodingh.inc

@@ -45,6 +45,7 @@ type
   strict protected
     FIsSingleByte: Boolean;
     FMaxCharSize: Integer;
+    class procedure FreeEncodings;
     function GetByteCount(Chars: PUnicodeChar; CharCount: Integer): Integer; overload; virtual; abstract;
     function GetBytes(Chars: PUnicodeChar; CharCount: Integer; Bytes: PByte; ByteCount: Integer): Integer; overload; virtual; abstract;
     function GetCharCount(Bytes: PByte; ByteCount: Integer): Integer; overload; virtual; abstract;
@@ -54,7 +55,6 @@ type
     function GetCodePage: Cardinal; virtual; abstract;
     function GetEncodingName: UnicodeString; virtual; abstract;
   public
-    class procedure FreeEncodings;
     function Clone: TEncoding; virtual;
     class function Convert(Source, Destination: TEncoding; const Bytes: TBytes): TBytes; overload;
     class function Convert(Source, Destination: TEncoding; const Bytes: TBytes; StartIndex, Count: Integer): TBytes; overload;

rtl/win/wininc/ascdef.inc

@@ -111,7 +111,7 @@ function GetDiskFreeSpace(lpRootPathName:LPCSTR; lpSectorsPerCluster:LPDWORD; lp
 function CreateDirectory(lpPathName:LPCSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryA';
 function CreateDirectoryEx(lpTemplateDirectory:LPCSTR; lpNewDirectory:LPCSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryExA';
 function RemoveDirectory(lpPathName:LPCSTR):WINBOOL; external 'kernel32' name 'RemoveDirectoryA';
-function GetFullPathName(lpFileName:LPCSTR; nBufferLength:DWORD; lpBuffer:LPSTR; var lpFilePart:LPSTR):DWORD; external 'kernel32' name 'GetFullPathNameA';
+function GetFullPathName(lpFileName:LPCSTR; nBufferLength:DWORD; lpBuffer:LPSTR; lpFilePart:PLPSTR):DWORD; external 'kernel32' name 'GetFullPathNameA';
 function DefineDosDevice(dwFlags:DWORD; lpDeviceName:LPCSTR; lpTargetPath:LPCSTR):WINBOOL; external 'kernel32' name 'DefineDosDeviceA';
 function QueryDosDevice(lpDeviceName:LPCSTR; lpTargetPath:LPSTR; ucchMax:DWORD):DWORD; external 'kernel32' name 'QueryDosDeviceA';
 function CreateFile(lpFileName:LPCSTR; dwDesiredAccess:DWORD; dwShareMode:DWORD; lpSecurityAttributes:LPSECURITY_ATTRIBUTES; dwCreationDisposition:DWORD;dwFlagsAndAttributes:DWORD; hTemplateFile:HANDLE):HANDLE; external 'kernel32' name 'CreateFileA';
@@ -479,6 +479,7 @@ function FindFirstFileEx(lpfilename : LPCStr;fInfoLevelId:FINDEX_INFO_LEVELS ;lp
 // winver>$0600
 function FindFirstFileTransacted(lpfilename : LPCStr;fInfoLevelId:FINDEX_INFO_LEVELS ;lpFindFileData:pointer;fSearchOp : FINDEX_SEARCH_OPS;lpSearchFilter:pointer;dwAdditionalFlags:dword;htransaction : HANDLE):Handle; stdcall;
     external 'kernel32' name 'FindFirstFileTransactedA';
+function GetComputerNameEx(NameType:COMPUTER_NAME_FORMAT;lpbuffer:LPSTR;nSize:LPDWORD):BOOL;stdcall;external 'kernel32' name 'GetComputerNameExA';
 {$endif read_interface}
 
 

rtl/win/wininc/ascfun.inc

@@ -110,7 +110,7 @@ function GetDiskFreeSpaceA(lpRootPathName:LPCSTR; lpSectorsPerCluster:LPDWORD; l
 function CreateDirectoryA(lpPathName:LPCSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryA';
 function CreateDirectoryExA(lpTemplateDirectory:LPCSTR; lpNewDirectory:LPCSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryExA';
 function RemoveDirectoryA(lpPathName:LPCSTR):WINBOOL; external 'kernel32' name 'RemoveDirectoryA';
-function GetFullPathNameA(lpFileName:LPCSTR; nBufferLength:DWORD; lpBuffer:LPSTR; var lpFilePart:LPSTR):DWORD; external 'kernel32' name 'GetFullPathNameA';
+function GetFullPathNameA(lpFileName:LPCSTR; nBufferLength:DWORD; lpBuffer:LPSTR; lpFilePart:PLPSTR):DWORD; external 'kernel32' name 'GetFullPathNameA';
 function DefineDosDeviceA(dwFlags:DWORD; lpDeviceName:LPCSTR; lpTargetPath:LPCSTR):WINBOOL; external 'kernel32' name 'DefineDosDeviceA';
 function QueryDosDeviceA(lpDeviceName:LPCSTR; lpTargetPath:LPSTR; ucchMax:DWORD):DWORD; external 'kernel32' name 'QueryDosDeviceA';
 function CreateFileA(lpFileName:LPCSTR; dwDesiredAccess:DWORD; dwShareMode:DWORD; lpSecurityAttributes:LPSECURITY_ATTRIBUTES; dwCreationDisposition:DWORD;dwFlagsAndAttributes:DWORD; hTemplateFile:HANDLE):HANDLE; external 'kernel32' name 'CreateFileA';
@@ -492,7 +492,7 @@ function GetConsoleAliasesLengthA(ExeName:LPSTR):DWORD;stdcall;external 'kernel3
 function GetConsoleAliasExesLengthA:DWORD;stdcall;external 'kernel32' name 'GetConsoleAliasExesLengthA';
 function GetConsoleAliasesA(AliasBuffer:LPSTR; AliasBufferLength:DWORD; ExeName:LPSTR):DWORD;stdcall;external 'kernel32' name 'GetConsoleAliasesA';
 function GetConsoleAliasExesA(ExeNameBuffer:LPSTR; ExeNameBufferLength:DWORD):DWORD;stdcall;external 'kernel32' name 'GetConsoleAliasExesA';
-  
+function GetComputerNameExA(NameType:COMPUTER_NAME_FORMAT;lpbuffer:LPSTR;nSize:LPDWORD):BOOL;stdcall;external 'kernel32' name 'GetComputerNameExA';
 {$endif read_interface}
 
 

rtl/win/wininc/base.inc

@@ -748,6 +748,8 @@
      PFNPROCESSPOLICIESA = function (_para1:HWND; _para2:LPCSTR; _para3:LPCSTR; _para4:LPCSTR; _para5:DWORD):WINBOOL;stdcall;
      PFNPROCESSPOLICIESW = function (_para1:HWND; _para2:LPCWSTR; _para3:LPCWSTR; _para4:LPCWSTR; _para5:DWORD):WINBOOL;stdcall;
      PFNPROCESSPOLICIES  = function (_para1:HWND; _para2:LPCTSTR; _para3:LPCTSTR; _para4:LPCTSTR; _para5:DWORD):WINBOOL;stdcall;
+     TIMEFMT_ENUMPROCEX  = function (TimeFormat : LPWSTR; AppData : LPARAM) : BOOL; stdcall;
+
   (*  Not convertable by H2PAS
   #define SECURITY_NULL_SID_AUTHORITY     {0,0,0,0,0,0}
   #define SECURITY_WORLD_SID_AUTHORITY    {0,0,0,0,0,1}

rtl/win/wininc/defines.inc

@@ -472,20 +472,28 @@
      OPEN_ALWAYS = 4;
      TRUNCATE_EXISTING = 5;
 
-     FILE_ATTRIBUTE_ARCHIVE = 32;
-     FILE_ATTRIBUTE_NORMAL = 128;
-     FILE_ATTRIBUTE_DIRECTORY = 16;
-     FILE_ATTRIBUTE_HIDDEN = 2;
-     FILE_ATTRIBUTE_READONLY = 1;
-     FILE_ATTRIBUTE_SYSTEM = 4;
-     FILE_ATTRIBUTE_TEMPORARY = 256;
-     FILE_ATTRIBUTE_SPARSE_FILE = $0200;
-     FILE_ATTRIBUTE_REPARSE_POINT = $0400;
-     FILE_ATTRIBUTE_COMPRESSED = $0800;
-     FILE_ATTRIBUTE_OFFLINE = $1000;
-     FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $2000;
-     FILE_ATTRIBUTE_ENCRYPTED = $4000;
-     FILE_ATTRIBUTE_VIRTUAL = $20000;
+     FILE_ATTRIBUTE_READONLY             = $0000001;
+     FILE_ATTRIBUTE_HIDDEN               = $0000002;
+     FILE_ATTRIBUTE_SYSTEM               = $0000004;
+     FILE_ATTRIBUTE_DIRECTORY            = $0000010;
+     FILE_ATTRIBUTE_ARCHIVE              = $0000020;
+     FILE_ATTRIBUTE_DEVICE               = $0000040;
+     FILE_ATTRIBUTE_NORMAL               = $0000080;
+     FILE_ATTRIBUTE_TEMPORARY            = $0000100;
+     FILE_ATTRIBUTE_SPARSE_FILE          = $0000200;
+     FILE_ATTRIBUTE_REPARSE_POINT        = $0000400;
+     FILE_ATTRIBUTE_COMPRESSED           = $0000800;
+     FILE_ATTRIBUTE_OFFLINE              = $0001000;
+     FILE_ATTRIBUTE_NOT_CONTENT_INDEXED  = $0002000;
+     FILE_ATTRIBUTE_ENCRYPTED            = $0004000;
+     FILE_ATTRIBUTE_INTEGRITY_STREAM     = $0008000;
+     FILE_ATTRIBUTE_VIRTUAL              = $0010000;
+     FILE_ATTRIBUTE_NO_SCRUB_DATA        = $0020000;
+     FILE_ATTRIBUTE_EA                   = $0040000;
+     FILE_ATTRIBUTE_PINNED               = $0080000;
+     FILE_ATTRIBUTE_UNPINNED             = $0100000;
+     FILE_ATTRIBUTE_RECALL_ON_OPEN       = $0040000;   // same as EA ?
+     FILE_ATTRIBUTE_RECALL_ON_DATA_ACCESS = $0400000;
 
      FILE_FLAG_WRITE_THROUGH = $80000000;
      FILE_FLAG_OVERLAPPED = 1073741824;
@@ -1250,6 +1258,12 @@
      DMDFO_STRETCH = 1;
      DMDFO_CENTER  = 2;
 
+
+   LOCALE_NAME_USER_DEFAULT : pwidechar = nil;
+   LOCALE_NAME_INVARIANT : pwidechar = '';
+   LOCALE_NAME_SYSTEM_DEFAULT : pwidechar = '!x-sys-default-locale';
+
+
   //
   // Predefined Resource Types
   //
@@ -6351,6 +6365,7 @@ const
     CONSOLE_WINDOWED_MODE = 2;    
 
 
+
 {$endif read_interface}
 
 {$ifdef read_implementation}

rtl/win/wininc/func.inc

@@ -137,6 +137,7 @@ function GetExitCodeThread(hThread:HANDLE; lpExitCode:LPDWORD):WINBOOL; external
 function GetThreadSelectorEntry(hThread:HANDLE; dwSelector:DWORD; lpSelectorEntry:LPLDT_ENTRY):WINBOOL; external 'kernel32' name 'GetThreadSelectorEntry';
 function GetLastError:DWORD; external 'kernel32' name 'GetLastError';
 procedure SetLastError(dwErrCode:DWORD); external 'kernel32' name 'SetLastError';
+function GetErrorMode : DWORD; stdcall; external 'kernel32' name 'GetErrorMode';
 function CreateIoCompletionPort(FileHandle:HANDLE; ExistingCompletionPort:HANDLE; CompletionKey:ULONG_PTR; NumberOfConcurrentThreads:DWORD):HANDLE; external 'kernel32' name 'CreateIoCompletionPort';
 function SetErrorMode(uMode:UINT):UINT; external 'kernel32' name 'SetErrorMode';
 function ReadProcessMemory(hProcess:HANDLE; lpBaseAddress:LPCVOID; lpBuffer:LPVOID; nSize:PTRUINT; lpNumberOfBytesRead:PPTRUINT):WINBOOL; external 'kernel32' name 'ReadProcessMemory';
@@ -1062,6 +1063,7 @@ function SHGetFileInfo(_para1:LPCTSTR; _para2:DWORD; var _para3:SHFILEINFO; _par
 function SHGetPathFromIDList(_para1:LPCITEMIDLIST; _para2:LPTSTR):WINBOOL; external 'shell32' name 'SHGetPathFromIDList';
 function SHGetSpecialFolderLocation(_para1:HWND; _para2:longint; var _para3:LPITEMIDLIST):HRESULT; external 'shell32' name 'SHGetSpecialFolderLocation';
 function FlashWindowEx(pfwi : PFLASHWINFO) : BOOL; stdcall; external 'user32' name 'FlashWindowEx';
+function EnumTimeFormatsEx(TimeFormatsExEnum : TIMEFMT_ENUMPROCEX; LocaleName : LPCWSTR;Flags : DWORD;AppData : LPARAM) : BOOL; external 'kernel32' name 'EnumTimeFormatsEx';
 
 { was missing, bug report 1808 PM }
 {

rtl/win/wininc/redef.inc

@@ -508,10 +508,15 @@ function GetFileInformationByHandle(hFile: THandle; var lpFileInformation: TByHa
 function GetFileVersionInfoSize(lptstrFilename: PChar; var lpdwHandle: DWORD): DWORD;external 'version' name 'GetFileVersionInfoSizeA';
 function GetFileVersionInfoSizeA(lptstrFilename: LPCSTR; var lpdwHandle: DWORD): DWORD; external 'version' name 'GetFileVersionInfoSizeA';
 function GetFileVersionInfoSizeW(lptstrFilename: LPWSTR; var lpdwHandle: DWORD): DWORD; external 'version' name 'GetFileVersionInfoSizeW';
-// removed because old definition was wrong !
-// function GetFullPathName(lpFileName: PChar; nBufferLength: DWORD; lpBuffer: PChar; var lpFilePart: PChar): DWORD;external 'kernel32' name 'GetFullPathNameA';
-// function GetFullPathNameA(lpFileName: LPCSTR; nBufferLength: DWORD; lpBuffer: LPCSTR; var lpFilePart: LPCSTR): DWORD; external 'kernel32' name 'GetFullPathNameA';
-// function GetFullPathNameW(lpFileName: LPWSTR; nBufferLength: DWORD; lpBuffer: LPWSTR; var lpFilePart: LPWSTR): DWORD; external 'kernel32' name 'GetFullPathNameW';
+
+{$ifdef Unicode}
+ function GetFullPathName (lpFileName: LPCWSTR; nBufferLength: DWORD; lpBuffer: LPWSTR; var lpFilePart: LPWSTR): DWORD; external 'kernel32' name 'GetFullPathNameW';
+{$else}
+ function GetFullPathName (lpFileName: LPCSTR;  nBufferLength: DWORD; lpBuffer: LPSTR;  var lpFilePart: LPSTR):  DWORD; external 'kernel32' name 'GetFullPathNameA';
+{$endif}
+ function GetFullPathNameW(lpFileName: LPCWSTR; nBufferLength: DWORD; lpBuffer: LPWSTR; var lpFilePart: LPWSTR): DWORD; external 'kernel32' name 'GetFullPathNameW';
+ function GetFullPathNameA(lpFileName: LPCSTR;  nBufferLength: DWORD; lpBuffer: LPSTR;  var lpFilePart: LPSTR):  DWORD; external 'kernel32' name 'GetFullPathNameA';
+
 function GetGlyphOutline(DC: HDC; p2, p3: UINT; const p4: TGlyphMetrics; p5: DWORD; p6: Pointer; const p7: TMat2): DWORD;external 'gdi32' name 'GetGlyphOutlineA';
 function GetGlyphOutlineA(DC: HDC; p2, p3: UINT; const p4: TGlyphMetrics; p5: DWORD; p6: Pointer; const p7: TMat2): DWORD; external 'gdi32' name 'GetGlyphOutlineA';
 function GetGlyphOutlineW(DC: HDC; p2, p3: UINT; const p4: TGlyphMetrics; p5: DWORD; p6: Pointer; const p7: TMat2): DWORD; external 'gdi32' name 'GetGlyphOutlineW';

rtl/win/wininc/struct.inc

@@ -9385,6 +9385,18 @@ type
     CONSOLE_READCONSOLE_CONTROL = _CONSOLE_READCONSOLE_CONTROL;
     PCONSOLE_READCONSOLE_CONTROL = ^_CONSOLE_READCONSOLE_CONTROL;
 
+
+    COMPUTER_NAME_FORMAT =  (
+          ComputerNameNetBIOS=0,
+          ComputerNameDnsHostname,
+          ComputerNameDnsDomain,
+          ComputerNameDnsFullyQualified,
+          ComputerNamePhysicalNetBIOS,
+          ComputerNamePhysicalDnsHostname,
+          ComputerNamePhysicalDnsDomain,
+          ComputerNamePhysicalDnsFullyQualified,
+          ComputerNameMax=31);
+    TCOMPUTER_NAME_FORMAT = COMPUTER_NAME_FORMAT;
 {$pop}
 {$endif read_interface}
 

rtl/win/wininc/unidef.inc

@@ -110,7 +110,7 @@ function GetDiskFreeSpace(lpRootPathName:LPCWSTR; lpSectorsPerCluster:LPDWORD; l
 function CreateDirectory(lpPathName:LPCWSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryW';
 function CreateDirectoryEx(lpTemplateDirectory:LPCWSTR; lpNewDirectory:LPCWSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryExW';
 function RemoveDirectory(lpPathName:LPCWSTR):WINBOOL; external 'kernel32' name 'RemoveDirectoryW';
-function GetFullPathName(lpFileName:LPCWSTR; nBufferLength:DWORD; lpBuffer:LPWSTR; var lpFilePart:LPWSTR):DWORD; external 'kernel32' name 'GetFullPathNameW';
+function GetFullPathName(lpFileName:LPCWSTR; nBufferLength:DWORD; lpBuffer:LPWSTR; lpFilePart:PLPWSTR):DWORD; external 'kernel32' name 'GetFullPathNameW';
 function DefineDosDevice(dwFlags:DWORD; lpDeviceName:LPCWSTR; lpTargetPath:LPCWSTR):WINBOOL; external 'kernel32' name 'DefineDosDeviceW';
 function QueryDosDevice(lpDeviceName:LPCWSTR; lpTargetPath:LPWSTR; ucchMax:DWORD):DWORD; external 'kernel32' name 'QueryDosDeviceW';
 function CreateFile(lpFileName:LPCWSTR; dwDesiredAccess:DWORD; dwShareMode:DWORD; lpSecurityAttributes:LPSECURITY_ATTRIBUTES; dwCreationDisposition:DWORD;dwFlagsAndAttributes:DWORD; hTemplateFile:HANDLE):HANDLE; external 'kernel32' name 'CreateFileW';
@@ -472,7 +472,7 @@ function CreateProcessAsUser(_para1:HANDLE; _para2:LPCWSTR; _para3:LPWSTR; _para
 function FindFirstFileEx(lpfilename : LPCWStr;fInfoLevelId:FINDEX_INFO_LEVELS ;lpFindFileData:pointer;fSearchOp : FINDEX_SEARCH_OPS;lpSearchFilter:pointer;dwAdditionalFlags:dword):Handle; stdcall; external 'kernel32' name 'FindFirstFileExW';
 // winver>$0600 
 function FindFirstFileTransacted(lpfilename : LPCWStr;fInfoLevelId:FINDEX_INFO_LEVELS ;lpFindFileData:pointer;fSearchOp : FINDEX_SEARCH_OPS;lpSearchFilter:pointer;dwAdditionalFlags:dword;htransaction : HANDLE):Handle; stdcall; external 'kernel32' name 'FindFirstFileTransactedW';
-
+function GetComputerNameEx(NameType:COMPUTER_NAME_FORMAT;lpbuffer:LPWSTR;nSize:LPDWORD):BOOL;stdcall;external 'kernel32' name 'GetComputerNameExW';
 {$endif read_interface}
 
 

rtl/win/wininc/unifun.inc

@@ -110,7 +110,7 @@ function GetDiskFreeSpaceW(lpRootPathName:LPCWSTR; lpSectorsPerCluster:LPDWORD;
 function CreateDirectoryW(lpPathName:LPCWSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryW';
 function CreateDirectoryExW(lpTemplateDirectory:LPCWSTR; lpNewDirectory:LPCWSTR; lpSecurityAttributes:LPSECURITY_ATTRIBUTES):WINBOOL; external 'kernel32' name 'CreateDirectoryExW';
 function RemoveDirectoryW(lpPathName:LPCWSTR):WINBOOL; external 'kernel32' name 'RemoveDirectoryW';
-function GetFullPathNameW(lpFileName:LPCWSTR; nBufferLength:DWORD; lpBuffer:LPWSTR; var lpFilePart:LPWSTR):DWORD; external 'kernel32' name 'GetFullPathNameW';
+function GetFullPathNameW(lpFileName:LPCWSTR; nBufferLength:DWORD; lpBuffer:LPWSTR; lpFilePart:PLPWSTR):DWORD; external 'kernel32' name 'GetFullPathNameW';
 function DefineDosDeviceW(dwFlags:DWORD; lpDeviceName:LPCWSTR; lpTargetPath:LPCWSTR):WINBOOL; external 'kernel32' name 'DefineDosDeviceW';
 function QueryDosDeviceW(lpDeviceName:LPCWSTR; lpTargetPath:LPWSTR; ucchMax:DWORD):DWORD; external 'kernel32' name 'QueryDosDeviceW';
 function CreateFileW(lpFileName:LPCWSTR; dwDesiredAccess:DWORD; dwShareMode:DWORD; lpSecurityAttributes:LPSECURITY_ATTRIBUTES; dwCreationDisposition:DWORD;dwFlagsAndAttributes:DWORD; hTemplateFile:HANDLE):HANDLE; external 'kernel32' name 'CreateFileW';
@@ -495,7 +495,7 @@ function GetConsoleAliasesLengthW(ExeName:LPWSTR):DWORD;stdcall;external 'kernel
 function GetConsoleAliasExesLengthW:DWORD;stdcall;external 'kernel32' name 'GetConsoleAliasExesLengthW';
 function GetConsoleAliasesW(AliasBuffer:LPWSTR; AliasBufferLength:DWORD; ExeName:LPWSTR):DWORD;stdcall;external 'kernel32' name 'GetConsoleAliasesW';
 function GetConsoleAliasExesW(ExeNameBuffer:LPWSTR; ExeNameBufferLength:DWORD):DWORD;stdcall;external 'kernel32' name 'GetConsoleAliasExesW';
-
+function GetComputerNameExW(NameType:COMPUTER_NAME_FORMAT;lpbuffer:LPWSTR;nSize:LPDWORD):BOOL;stdcall;external 'kernel32' name 'GetComputerNameExW';
 {$endif read_interface}
 
 

tests/tbs/tb0655.pp

@@ -0,0 +1,115 @@
+program tb0655;
+
+uses
+  Variants;
+
+var
+  s8: Int8 = $12;
+  u8: UInt8 = $98;
+  s16: Int16 = $1234;
+  u16: UInt16 = $9876;
+  s32: Int32 = $12345768;
+  u32: UInt32 = $98765432;
+  s64: Int64 = $1234567812345678;
+  u64: UInt64 = UInt64($9876543298765432);
+  v: Variant;
+  ov: OleVariant;
+begin
+  v := s8;
+  if VarType(v) <> varShortInt then
+    Halt(1);
+  if Int8(v) <> s8 then
+    Halt(2);
+
+  v := u8;
+  if VarType(v) <> varByte then
+    Halt(3);
+  if UInt8(v) <> u8 then
+    Halt(4);
+
+  v := s16;
+  if VarType(v) <> varSmallInt then
+    Halt(5);
+  if Int16(v) <> s16 then
+    Halt(6);
+
+  v := u16;
+  if VarType(v) <> varWord then
+    Halt(7);
+  if UInt16(v) <> u16 then
+    Halt(8);
+
+  v := s32;
+  if VarType(v) <> varInteger then
+    Halt(9);
+  if Int32(v) <> s32 then
+    Halt(10);
+
+  v := u32;
+  if VarType(v) <> varLongWord then
+    Halt(11);
+  if UInt32(v) <> u32 then
+    Halt(12);
+
+  v := s64;
+  if VarType(v) <> varInt64 then
+    Halt(13);
+  if Int64(v) <> s64 then
+    Halt(14);
+
+  v := u64;
+  if VarType(v) <> varUInt64 then
+    Halt(15);
+  if UInt64(v) <> u64 then
+    Halt(16);
+
+  { OleVariant has slightly different behaviour to Variant }
+  ov := s8;
+  if VarType(ov) <> varInteger then
+    Halt(17);
+  if Int8(ov) <> s8 then
+    Halt(18);
+
+  ov := u8;
+  if VarType(ov) <> varInteger then
+    Halt(19);
+  if UInt8(ov) <> u8 then
+    Halt(20);
+
+  ov := s16;
+  if VarType(ov) <> varInteger then
+    Halt(21);
+  if Int16(ov) <> s16 then
+    Halt(22);
+
+  ov := u16;
+  if VarType(ov) <> varInteger then
+    Halt(23);
+  if UInt16(ov) <> u16 then
+    Halt(24);
+
+  ov := s32;
+  if VarType(ov) <> varInteger then
+    Halt(25);
+  if Int32(ov) <> s32 then
+    Halt(26);
+
+  ov := u32;
+  if VarType(ov) <> varInteger then
+    Halt(27);
+  { ! }
+  if UInt32(Int32(ov)) <> u32 then
+    Halt(28);
+
+  ov := s64;
+  if VarType(ov) <> varInt64 then
+    Halt(29);
+  if Int64(ov) <> s64 then
+    Halt(30);
+
+  ov := u64;
+  if VarType(ov) <> varUInt64 then
+    Halt(31);
+  if UInt64(ov) <> u64 then
+    Halt(32);
+end.

utils/pas2js/docs/translation.html

@@ -798,9 +798,9 @@ function(){
     <ul>
       <li>Local variables become local JavaScript variables: <i>var l = 0;</i>.</li>
       <li>Local constants become JavaScript variables in the unit/program implementation section.</li>
-      <li>Overloaded functions are given an unique name by appending $1, $2, ...<br>
-      Overloading is always on. You don't need to add the <i>overload</i> modifier.</li>
-      <li>Supported: default values, local types, FuncName:=</li>
+      <li>Local types are elevated to module.</li>
+      <li>Overloaded functions are given an unique name by appending $1, $2, ...</li>
+      <li>Supported: default values, const/var/out/default, FuncName:=</li>
     </ul>
     </div>
 
@@ -1612,7 +1612,8 @@ function(){
       <li>private, protected, public, strict private, strict protected</li>
       <li>class vars, const, nested types</li>
       <li>methods, class methods, class constructor, external methods</li>
-      <li>method modifiers overload, reintroduce, virtual, override, abstract, static, external name</li>
+      <li>method modifiers overload, reintroduce, virtual, override, abstract,
+      static, external name, message integer, message string</li>
       <li>call inherited</li>
       <li>assigned()</li>
       <li>type cast</li>