diff --git a/.gitattributes b/.gitattributes index 75ca909423..c73a832a66 100644 --- a/.gitattributes +++ b/.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 diff --git a/rtl/inc/iso7185.pp b/rtl/inc/iso7185.pp index 80cb12a77b..35c4ba787d 100644 --- a/rtl/inc/iso7185.pp +++ b/rtl/inc/iso7185.pp @@ -52,53 +52,9 @@ unit iso7185; implementation -{$IFDEF UNIX} - function getTempDir: string; - 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 isotmp.inc} + {$i-} procedure DoAssign(var t : Text); {$ifndef FPC_HAS_FEATURE_RANDOM} diff --git a/rtl/inc/isotmp.inc b/rtl/inc/isotmp.inc new file mode 100644 index 0000000000..5075821cd5 --- /dev/null +++ b/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} diff --git a/rtl/inc/typefile.inc b/rtl/inc/typefile.inc index 350fb68c06..e3f2be71bd 100644 --- a/rtl/inc/typefile.inc +++ b/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;