paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 05:59:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@35622 -
This commit is contained in:
michael 2017-03-18 18:11:18 +00:00
parent cfbf1820e1
commit cd03ec93fe
4 changed files with 145 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -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

48
rtl/inc/iso7185.pp
View File

@ -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}

138
rtl/inc/isotmp.inc Normal file
View File

@ -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}

6
rtl/inc/typefile.inc
View File

@ -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;