* fixed passing of variant parameters for windows api

* widestrings need to be allocated by a special OS call on windows

git-svn-id: trunk@458 -

.gitattributes

@@ -5763,6 +5763,7 @@ tests/webtbs/tw2388.pp svneol=native#text/plain
 tests/webtbs/tw2397.pp svneol=native#text/plain
 tests/webtbs/tw2409.pp svneol=native#text/plain
 tests/webtbs/tw2421.pp svneol=native#text/plain
+tests/webtbs/tw2423.pp svneol=native#text/plain
 tests/webtbs/tw2425.pp svneol=native#text/plain
 tests/webtbs/tw2432.pp svneol=native#text/plain
 tests/webtbs/tw2435.pp svneol=native#text/plain

compiler/i386/cpupara.pas

@@ -129,13 +129,15 @@ unit cpupara;
         case def.deftype of
           variantdef :
             begin
-              { Win32 stdcall passes small records on the stack for call by
-                value }
+              { variants are small enough to be passed by value except if
+                required by the windows api
+              }
               if (target_info.system=system_i386_win32) and
                  (calloption=pocall_stdcall) and
-                 (varspez=vs_value) and
-                 (def.size<=16) then
-                result:=false
+                 (varspez=vs_const) then
+                result:=true
+              else
+                result:=false;
             end;
           formaldef :
             result:=true;

rtl/inc/wstrings.inc

@@ -143,7 +143,11 @@ Function NewWideString(Len : SizeInt) : Pointer;
 Var
   P : Pointer;
 begin
+{$ifdef MSWINDOWS}
+  P:=SysAllocStringLen(nil,Len*sizeof(WideChar)+WideRecLen);
+{$else MSWINDOWS}
   GetMem(P,Len*sizeof(WideChar)+WideRecLen);
+{$endif MSWINDOWS}
   If P<>Nil then
    begin
      PWideRec(P)^.Len:=0;         { Initial length }
@@ -163,7 +167,11 @@ begin
   If S=Nil then
     exit;
   Dec (S,WideFirstOff);
+{$ifdef MSWINDOWS}
+  SysFreeString(S);
+{$else MSWINDOWS}
   FreeMem (S);
+{$endif MSWINDOWS}
   S:=Nil;
 end;
 

rtl/win/sysos.inc

@@ -242,8 +242,6 @@ threadvar
    function GetCurrentDirectory(bufsize : longint;name : pchar) : longbool;
      stdcall;external 'kernel32' name 'GetCurrentDirectoryA';
 
-
-
    Procedure Errno2InOutRes;
    Begin
      { DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }

rtl/win32/system.pp

@@ -36,7 +36,7 @@ const
 { FileNameCaseSensitive is defined separately below!!! }
  maxExitCode = 65535;
  MaxPathLen = 260;
- 
+
 type
    PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
    TEXCEPTION_FRAME = record
@@ -111,6 +111,17 @@ type
 
 implementation
 
+{ used by wstrings.inc because wstrings.inc is included before sysos.inc
+  this is put here (FK) }
+
+function SysAllocStringLen(psz:pointer;len:Integer):pointer;stdcall;
+ external 'oleaut32.dll' name 'SysAllocStringLen';
+
+procedure SysFreeString(bstr:pointer);stdcall;
+ external 'oleaut32.dll' name 'SysFreeString';
+
+
+
 { include system independent routines }
 {$I system.inc}
 

tests/webtbs/tw2423.pp

@@ -0,0 +1,106 @@
+{ %target=win32 }
+{ Source provided for Free Pascal Bug Report 2423 }
+{ Submitted by "Pavel V. Ozerski" on  2003-03-18 }
+{ e-mail: [email protected] }
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+{ $define BugAvoid}
+type
+ pVariant=^Variant;
+function ShowHTMLDialog(const hwndParent:longint;const pmk:pointer;
+                                const pvarArgIn:Variant;const pchOptions:{pwidechar}pointer;
+                                pvarArgOut:pVariant):longint;stdcall;
+ external 'MSHTML.DLL';
+function CreateURLMoniker(const pmkContext:pointer;const szURL:pWideChar;var ppmk:pointer):longint;stdcall;
+ external 'URLMON.DLL';
+
+{$ifdef BugAvoid}
+
+function SysAllocStringLen(psz:pointer;len:Integer):pointer;stdcall;
+ external 'oleaut32.dll' name 'SysAllocStringLen';
+
+procedure SysFreeString(bstr:pointer);stdcall;
+ external 'oleaut32.dll' name 'SysFreeString';
+
+function MultiByteToWideChar(CodePage:cardinal;dwFlags:cardinal;
+                             lpMultiByteStr:pChar;cchMultiByte:longint;
+                             lpWideCharStr:pointer;cchWideChar:longint
+                             ):longint;stdcall;
+ external 'kernel32.dll';
+
+function MakeWide(const s:ansistring):pointer;
+ var
+  l:cardinal;
+ begin
+  l:=succ(length(s));
+  Result:=SysAllocStringLen(nil,l);
+  MultiByteToWideChar(0,1,@s[1],length(s),Result,l);
+ end;
+
+{$endif}
+
+var
+ buf:pointer;
+const
+ Htm:AnsiString='<HTML><SCRIPT language="JavaScript">document.write(window.dialogArguments)</SCRIPT></HTML>';
+var
+ t:file;
+ ws:widestring;
+ s:ansistring;
+ pmk:pointer;
+
+ {$ifdef BugAvoid}
+
+  InParam_data:TVarData;
+  InParam:variant absolute InParam_data;
+
+ {$else}
+
+ inparam:variant;
+
+ {$endif}
+
+ i:longint;
+begin
+ s:=paramstr(0);
+ for i:=length(s)downto 1 do
+  if s[i]='\'then
+   begin
+    setlength(s,i);
+    break;
+   end; 
+ s:=s+'demo.htm';
+ assign(t,s);
+ rewrite(t,1);
+ blockwrite(t,Htm[1],length(Htm));
+ close(t);
+ ws:=s;
+
+
+{$ifdef BugAvoid}
+
+ buf:=MakeWide(s);
+
+
+{$else}
+
+ buf:=pWideChar(ws);
+
+{$endif}
+
+ CreateURLMoniker(nil,buf,pmk);
+
+{$ifdef BugAvoid}
+
+ InParam_data.VType:=8;
+ InParam_data.VPointer:=buf;
+
+{$else}
+
+ InParam:=ws;
+
+{$endif}
+
+ ShowHTMLDialog(0,pmk,InParam,nil,nil);
+end.