+ disp. var. property setting, resolves #10133 and #9134

git-svn-id: trunk@9189 -

.gitattributes

@@ -7043,6 +7043,7 @@ tests/test/tclass7.pp svneol=native#text/plain
 tests/test/tclass8.pp svneol=native#text/plain
 tests/test/tclrprop.pp svneol=native#text/plain
 tests/test/tcmp.pp svneol=native#text/plain
+tests/test/tdispvar1.pp svneol=native#text/plain
 tests/test/tendian1.pp svneol=native#text/plain
 tests/test/tenum1.pp svneol=native#text/plain
 tests/test/tenum2.pp svneol=native#text/plain

compiler/ncal.pas

@@ -186,7 +186,7 @@ interface
        tcallparanodeclass = class of tcallparanode;
 
     function reverseparameters(p: tcallparanode): tcallparanode;
-    function translate_disp_call(selfnode,parametersnode : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
+    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
 
     var
       ccallnode : tcallnodeclass;
@@ -238,7 +238,7 @@ implementation
       end;
 
 
-    function translate_disp_call(selfnode,parametersnode : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
+    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
       const
         DISPATCH_METHOD = $1;
         DISPATCH_PROPERTYGET = $2;
@@ -352,8 +352,10 @@ implementation
 
             para:=tcallparanode(para.nextpara);
           end;
-
-        calldesc.calltype:=DISPATCH_METHOD;
+        if assigned(putvalue) then
+          calldesc.calltype:=DISPATCH_PROPERTYPUT
+        else
+          calldesc.calltype:=DISPATCH_METHOD;
         calldesc.argcount:=paracount;
 
         { allocate space }
@@ -381,8 +383,8 @@ implementation
               end;
 
             dispatchbyref:=para.left.resultdef.typ in [variantdef];
-            { assign the argument/parameter to the temporary location }
 
+            { assign the argument/parameter to the temporary location }
             if para.left.nodetype<>nothingn then
               if dispatchbyref then
                 addstatement(statements,cassignmentnode.create(
@@ -2400,13 +2402,13 @@ implementation
                  converted_result_data:=ctempcreatenode.create(procdefinition.returndef,sizeof(procdefinition.returndef),tt_persistent,true);
                  addstatement(statements,converted_result_data);
                  addstatement(statements,cassignmentnode.create(ctemprefnode.create(converted_result_data),
-                   ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,'',tprocdef(procdefinition).dispid,true),
+                   ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,true),
                    procdefinition.returndef)));
                  addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
                  addstatement(statements,ctemprefnode.create(converted_result_data));
                end
              else
-               result:=translate_disp_call(methodpointer,parameters,'',tprocdef(procdefinition).dispid,false);
+               result:=translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,false);
 
              { don't free reused nodes }
              methodpointer:=nil;

compiler/pexpr.pas

@@ -2078,10 +2078,24 @@ implementation
                                  end
                                else
                                  p2:=nil;
-                               p1:=translate_disp_call(p1,p2,dispatchstring,0,
-                                 { this is only an approximation
-                                   setting useresult if not necessary is only a waste of time, no more, no less (FK) }
-                                 afterassignment or in_args or (token<>_SEMICOLON));
+                               { property setter? }
+                               if (token=_ASSIGNMENT) and not(afterassignment) then
+                                 begin
+                                   consume(_ASSIGNMENT);
+                                   { read the expression }
+                                   p3:=comp_expr(true);
+                                   { concat value parameter too }
+                                   p2:=ccallparanode.create(p3,p2);
+                                   { passing p3 here is only for information purposes }
+                                   p1:=translate_disp_call(p1,p2,p3,dispatchstring,0,false);
+                                 end
+                               else
+                                 begin
+                                   p1:=translate_disp_call(p1,p2,nil,dispatchstring,0,
+                                     { this is only an approximation
+                                       setting useresult if not necessary is only a waste of time, no more, no less (FK) }
+                                     afterassignment or in_args or (token<>_SEMICOLON));
+                                 end;
                              end
                            else { Error }
                              Consume(_ID);

packages/base/winunits/comobj.pp

@@ -803,7 +803,12 @@ implementation
           case InvokeKind of
             DISPATCH_PROPERTYPUT:
               begin
-                { !! FIXME}
+                if (Arguments[0].VType and varDispatch)<>0 then
+                  InvokeKind:=DISPATCH_PROPERTYPUTREF;
+                { first name is actually the name of the property to set }
+                DispIDs^[0]:=DISPATCH_PROPERTYPUT;
+                DispParams.rgdispidNamedArgs:=@DispIDs^[0];
+                inc(DispParams.cNamedArgs);
               end;
             DISPATCH_METHOD:
               if assigned(Result) and (CallDesc^.ArgCount=0) then

tests/test/tdispvar1.pp

@@ -0,0 +1,67 @@
+{ %TARGET=win32,win64 }
+{ %NOTE=This test requires an installed OpenOffice }
+program ttt;
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif fpc}
+
+uses
+  Windows, SysUtils, Classes, ComObj, ActiveX, Variants;
+
+var StarOffice : Variant;
+	Document : Variant;
+
+function TSampleCode_Connect() : boolean;
+begin
+    if  VarIsEmpty(StarOffice) then
+        StarOffice := CreateOleObject('com.sun.star.ServiceManager');
+
+    Result := not (VarIsEmpty(StarOffice) or VarIsNull(StarOffice));
+end;
+
+function TSampleCode_CreateDocument(bReadOnly : boolean) : boolean;
+var
+    StarDesktop : Variant;
+    LoadParams : Variant;
+    CoreReflection : Variant;
+    PropertyValue : Variant;
+    AutoObject : Variant;
+    TextObject : Variant;
+    Cursor : Variant;
+begin
+   StarDesktop := StarOffice.createInstance('com.sun.star.frame.Desktop');
+
+   if (bReadOnly) then begin
+        LoadParams := VarArrayCreate([0, 0], varVariant);
+        CoreReflection := StarOffice.createInstance('com.sun.star.reflection.CoreReflection');
+
+        CoreReflection.forName('com.sun.star.beans.PropertyValue').
+			createObject(PropertyValue); // CoreReflection().forName().createObject() bring to "Illegal qualifier"
+        AutoObject := CoreReflection.forName('com.sun.star.beans.PropertyValue');
+	AutoObject.createObject(PropertyValue);
+
+	PropertyValue.Name := 'ReadOnly'; 	// "Arg cant be assigned" and
+        PropertyValue.Value := true;		//	"Incompatimle types: const string, untyped expected"
+
+        LoadParams[0] := PropertyValue;
+   end
+   else
+        LoadParams := VarArrayCreate([0, -1], varVariant);
+
+   Document := StarDesktop.LoadComponentFromURL( 'private:factory/swriter', '_blank', 0,  LoadParams);
+   if not bReadOnly then begin
+       TextObject := Document.Text;
+       Cursor := TextObject.createTextCursor;
+       TextObject.insertString(Cursor,'Output of FPC Test tdispvar1.pp',False);
+	  // works with D7, but not FPC
+   end;
+
+   Result := not (VarIsEmpty(Document) or VarIsNull(Document));
+end;
+
+begin
+	CoInitialize(nil);
+	TSampleCode_Connect();
+        TSampleCode_CreateDocument(false);
+end.