* Patch from Karl-Michael Schindler (Bug ID 30402)

git-svn-id: trunk@35622 -

.gitattributes

@@ -9034,6 +9034,7 @@ rtl/inc/innr.inc svneol=native#text/plain
 rtl/inc/int64.inc svneol=native#text/plain
 rtl/inc/intres.inc svneol=native#text/plain
 rtl/inc/iso7185.pp svneol=native#text/pascal
+rtl/inc/isotmp.inc svneol=native#text/plain
 rtl/inc/lineinfo.pp svneol=native#text/plain
 rtl/inc/llvmintr.inc svneol=native#text/plain
 rtl/inc/lnfodwrf.pp svneol=native#text/plain

rtl/inc/iso7185.pp

@@ -52,52 +52,8 @@ unit iso7185;
 
   implementation
 
-{$IFDEF UNIX}
+
-  function getTempDir: string;
+{$i isotmp.inc}
-    var
-      key: string;
-      value: string;
-      i_env, i_key, i_value: integer;
-      pd : char; // Pathdelim not available ?
-    begin
-      value := '/tmp/';  (** default for UNIX **)
-      pd:='/';
-      while (envp <> NIL) and assigned(envp^) do
-      begin
-        i_env := 0;
-        i_key := 1;
-        while not (envp^[i_env] in ['=', #0]) do
-        begin
-          key[i_key] := envp^[i_env];
-          inc(i_env);
-          inc(i_key);
-        end;
-        setlength(key, i_key - 1);
-        if (key = 'TEMP') or (key = 'TMP') or (key = 'TMPDIR') then
-        begin
-          inc(i_env);    (** skip '=' **)
-          i_value := 1;
-          while (envp^[i_env] <> #0) do
-          begin
-            value[i_value] := envp^[i_env];
-            inc(i_env);
-            inc(i_value);
-          end;
-          setlength(value, i_value - 1);
-        end;
-        inc(envp);
-      end;
-      i_value:=length(value);
-      if (i_value>0) and (value[i_value]<>pd) then
-       value:=value+pd;
-      getTempDir := value;
-    end;
-{$else}    
-  function getTempDir: string;
-  begin
-    getTempDir:='';
-  end;
-{$ENDIF}  
  
 {$i-}
     procedure DoAssign(var t : Text);

rtl/inc/isotmp.inc

@@ -0,0 +1,138 @@
+{$IF defined(WINDOWS)}
+    type
+      isoLPWStr = PWideChar;
+      isoWinBool = LongBool;
+      TSysCharSet = set of AnsiChar;
+
+    function GetEnvironmentStringsW: isoLPWStr; stdcall; external 'kernel32' name 'GetEnvironmentStringsW';
+    function FreeEnvironmentStringsW(_para1 : isoLPWStr): isoWinBool; stdcall; external 'kernel32' name 'FreeEnvironmentStringsW';
+
+    function StrLen(p : PWideChar): sizeint; external name 'FPC_PWIDECHAR_LENGTH'; overload;
+
+    {$push}
+    {$checkpointer off}
+
+    function CharInSet(Ch : WideChar; const CSet : TSysCharSet): Boolean;
+    begin
+      CharInSet := (Ch <= #$FF) and (AnsiChar(byte(Ch)) in CSet);
+    end;
+
+    function InternalChangeCase(const S : UnicodeString; const Chars: TSysCharSet; const Adjustment: Longint): UnicodeString;
+      var
+        i : Integer;
+        p : PWideChar;
+        unique : Boolean;
+      begin
+        InternalChangeCase := S;
+        if InternalChangeCase = '' then
+          exit;
+        unique := false;
+        p := PWideChar(InternalChangeCase);
+        for i := 1 to Length(InternalChangeCase) do
+        begin
+          if CharInSet(p^, Chars) then
+          begin
+            if not unique then
+            begin
+              UniqueString(InternalChangeCase);
+              p := @InternalChangeCase[i];
+              unique := true;
+            end;
+            p^ := WideChar(Ord(p^) + Adjustment);
+          end;
+          inc(p);
+        end;
+      end;
+
+    function UpperCase(const s : UnicodeString) : UnicodeString;
+      begin
+        UpperCase := InternalChangeCase(s, ['a'..'z'], -32);
+      end;
+
+    function GetEnvironmentVariable(const EnvVar : UnicodeString) : UnicodeString;
+    var
+      s, upperenv : UnicodeString;
+      i : Longint;
+      hp, p : PWideChar;
+    begin
+      GetEnvironmentVariable := '';
+      p := GetEnvironmentStringsW;
+      hp := p;
+      upperenv := uppercase(envvar);
+      while hp^ <> #0 do
+      begin
+        s := hp;
+        i := pos('=', s);
+        if uppercase(copy(s,1,i-1)) = upperenv then
+        begin
+          GetEnvironmentVariable := copy(s, i+1, length(s)-i);
+          break;
+        end;
+        { next string entry }
+        hp := hp + strlen(hp) + 1;
+      end;
+      FreeEnvironmentStringsW(p);
+    end;
+
+    function getTempDir: String;
+    var
+      astringLength : Integer;
+    begin
+      getTempDir := GetEnvironmentVariable('TMP');
+      if getTempDir = '' then
+        getTempDir := GetEnvironmentVariable('TEMP');
+      astringlength := Length(getTempDir);
+      if (astringlength > 0) and (getTempDir[astringlength] <> DirectorySeparator) then
+        getTempDir := getTempDir + DirectorySeparator;
+    end;
+
+    {$pop}
+
+{$ELSEIF defined(UNIX)}
+
+  function getTempDir: string;
+    var
+      key: string;
+      value: string;
+      i_env, i_key, i_value: integer;
+    begin
+      value := '/tmp/';  (** default for UNIX **)
+      while (envp <> NIL) and assigned(envp^) do
+      begin
+        i_env := 0;
+        i_key := 1;
+        while not (envp^[i_env] in ['=', #0]) do
+        begin
+          key[i_key] := envp^[i_env];
+          inc(i_env);
+          inc(i_key);
+        end;
+        setlength(key, i_key - 1);
+        if (key = 'TEMP') or (key = 'TMP') or (key = 'TMPDIR') then
+        begin
+          inc(i_env);    (** skip '=' **)
+          i_value := 1;
+          while (envp^[i_env] <> #0) do
+          begin
+            value[i_value] := envp^[i_env];
+            inc(i_env);
+            inc(i_value);
+          end;
+          setlength(value, i_value - 1);
+        end;
+        inc(envp);
+      end;
+      i_value:=length(value);
+      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
+        value := value + DirectorySeparator;
+      getTempDir := value;
+    end;
+
+{$ELSE}  // neither unix nor windows
+
+  function getTempDir: string;
+  begin
+    getTempDir:='';
+  end;
+
+{$ENDIF}

rtl/inc/typefile.inc

@@ -68,12 +68,14 @@ Begin
   Rewrite(UnTypedFile(f),Size);
 End;
 
+{$i isotmp.inc}
+
 
 {$ifdef FPC_HAS_FEATURE_RANDOM}
 { this code is duplicated in the iso7185 unit }
 Procedure DoAssign(var t : TypedFile);
 Begin
-  Assign(t,'fpc_'+HexStr(random(1000000000),8)+'.tmp');
+  Assign(t,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
 End;
 {$else FPC_HAS_FEATURE_RANDOM}
 { this code is duplicated in the iso7185 unit }
@@ -84,7 +86,7 @@ Begin
 {$ifdef EXCLUDE_COMPLEX_PROCS}
   runerror(219);
 {$else EXCLUDE_COMPLEX_PROCS}
-  Assign(t,'fpc_'+HexStr(start,8)+'.tmp');
+  Assign(t,getTempDir+'fpc_'+HexStr(start,8)+'.tmp');
   inc(start);
 {$endif EXCLUDE_COMPLEX_PROCS}
 End;