View Issue Details

IDProjectCategoryView StatusLast Update
0030402FPCRTLpublic2017-03-18 19:19
ReporterKarl-Michael SchindlerAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
PlatformdarwinOSMac OS XOS Version10.5, 10.6
Product Version3.1.1Product Build 
Target Version3.2.0Fixed in Version3.1.1 
Summary0030402: using tmp dir in iso mode for internal files.
DescriptionIn iso mode temporary files are created in the current directory of the binary. On unixoides the patch puts the files to the temporary directory /tmp or according to the environment variables TMP, TEMP or TMPDIR.
TagsNo tags attached.
Fixed in Revision35622
FPCOldBugId
FPCTarget
Attached Files
  • fpc-tmpdir.patch (2,571 bytes)
    Index: rtl/inc/iso7185.pp
    ===================================================================
    --- rtl/inc/iso7185.pp	(Revision 34190)
    +++ rtl/inc/iso7185.pp	(Arbeitskopie)
    @@ -26,8 +26,8 @@
     
         Procedure Rewrite(var t : Text);
         Procedure Reset(var t : Text);
    -    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
    -    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
    +    Procedure Reset(var f : TypedFile);
    +    Procedure Rewrite(var f : TypedFile);
     
         Function Eof(Var t: Text): Boolean;
         Function Eof:Boolean;
    @@ -46,11 +46,50 @@
         Function Eof(var f:TypedFile): Boolean;
     
       implementation
    -
    +  
    +  function getTempDir: string;
    +    var
    +      key: string;
    +      value: string;
    +      i_env, i_key, i_value: integer;
    +    begin
    +    {$IFDEF HASUNIX}
    +      value := '/tmp/';  (** default for UNIX **)
    +    {$ELSE}
    +      value := '';
    +    {$ENDIF}
    +      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;
    +      getTempDir := value;
    +    end;
    +  
     {$i-}
         procedure DoAssign(var t : Text);
           begin
    -        Assign(t,'fpc_'+HexStr(random(1000000000),8)+'.tmp');
    +        Assign(t,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
           end;
     
     
    @@ -149,6 +188,32 @@
           end;
     
     
    +    procedure DoAssign(var f : TypedFile);
    +      begin
    +        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
    +      end;
    +
    +
    +    procedure Rewrite(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Rewrite(f);
    +      end;
    +
    +
    +    procedure Reset(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Reset(f);
    +      end;
    +
    +
         procedure Get(var f:TypedFile);[IOCheck];
           Begin
             if not(eof(f)) then
    
    fpc-tmpdir.patch (2,571 bytes)
  • iso7185.patch (2,193 bytes)
    --- rtl/inc/iso7185.pp	2016-09-13 23:42:07.000000000 +0300
    +++ rtl/inc/iso7185-KMS.pp	2016-09-13 23:42:02.000000000 +0300
    @@ -26,8 +26,8 @@
     
         Procedure Rewrite(var t : Text);
         Procedure Reset(var t : Text);
    -    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
    -    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
    +    Procedure Reset(var f : TypedFile);
    +    Procedure Rewrite(var f : TypedFile);
     
         Function Eof(Var t: Text): Boolean;
         Function Eof:Boolean;
    @@ -47,16 +47,17 @@
     
       implementation
     
    -{$IFDEF UNIX}
       function getTempDir: string;
         var
           key: string;
           value: string;
           i_env, i_key, i_value: integer;
    -      pd : char; // Pathdelim not available ?
         begin
    +{$IFDEF UNIX}
           value := '/tmp/';  (** default for UNIX **)
    -      pd:='/';
    +{$ELSE}
    +      value := '';       (** no default elsewhere **)
    +{$ENDIF}    
           while (envp <> NIL) and assigned(envp^) do
           begin
             i_env := 0;
    @@ -82,17 +83,11 @@
             end;
             inc(envp);
           end;
    -      i_value:=length(value);
    -      if (i_value>0) and (value[i_value]<>pd) then
    -       value:=value+pd;
    +      i_value := length(value);
    +      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
    +       value := value + DirectorySeparator;
           getTempDir := value;
         end;
    -{$else}    
    -  function getTempDir: string;
    -  begin
    -    getTempDir:='';
    -  end;
    -{$ENDIF}  
     
     {$i-}
         procedure DoAssign(var t : Text);
    @@ -205,6 +200,32 @@
           end;
     
     
    +    procedure DoAssign(var f : TypedFile);
    +      begin
    +        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
    +      end;
    +
    +
    +    procedure Rewrite(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Rewrite(f);
    +      end;
    +
    +
    +    procedure Reset(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Reset(f);
    +      end;
    +
    +
         procedure Get(var f:TypedFile);[IOCheck];
           Begin
             if not(eof(f)) then
    
    iso7185.patch (2,193 bytes)
  • iso7185_1.pp.patch (5,360 bytes)
    Index: rtl/inc/iso7185.pp
    ===================================================================
    --- rtl/inc/iso7185.pp	(revision 34525)
    +++ rtl/inc/iso7185.pp	(working copy)
    @@ -26,8 +26,8 @@
     
         Procedure Rewrite(var t : Text);
         Procedure Reset(var t : Text);
    -    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
    -    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
    +    Procedure Reset(var f : TypedFile);
    +    Procedure Rewrite(var f : TypedFile);
     
         Function Eof(Var t: Text): Boolean;
         Function Eof:Boolean;
    @@ -47,16 +47,108 @@
     
       implementation
     
    -{$IFDEF UNIX}
    +  {$IFDEF WINDOWS}
    +    type
    +      LPWSTR = Pwidechar;
    +      WINBOOL = longbool;
    +      TSysCharSet = Set of AnsiChar;
    +
    +    function GetEnvironmentStringsW:LPWSTR;stdcall; external 'kernel32' name 'GetEnvironmentStringsW';
    +    function FreeEnvironmentStringsW(_para1:LPWSTR):WINBOOL;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}
    +
    +  {$ENDIF WINDOWS}
    +
    +  {$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;
    @@ -83,17 +175,13 @@
             inc(envp);
           end;
           i_value:=length(value);
    -      if (i_value>0) and (value[i_value]<>pd) then
    -       value:=value+pd;
    +      if (i_value>0) and (value[i_value]<>DirectorySeparator) then
    +       value:=value+DirectorySeparator;
           getTempDir := value;
         end;
    -{$else}    
    -  function getTempDir: string;
    -  begin
    -    getTempDir:='';
    -  end;
    -{$ENDIF}  
     
    +{$ENDIF UNIX}
    +
     {$i-}
         procedure DoAssign(var t : Text);
     {$ifndef FPC_HAS_FEATURE_RANDOM}
    @@ -204,7 +292,42 @@
               FileFunc(TextRec(t).InOutFunc)(TextRec(t));
           end;
     
    +    procedure DoAssign(var f : TypedFile);
    +{$ifndef FPC_HAS_FEATURE_RANDOM}
    +      const
    +        NextIndex : Word = 1;
    +{$endif FPC_HAS_FEATURE_RANDOM}
    +      begin
    +{$ifdef FPC_HAS_FEATURE_RANDOM}
    +        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
    +{$else FPC_HAS_FEATURE_RANDOM}
    +        Assign(f,getTempDir+'fpc_'+HexStr(NextIndex,4)+'.tmp');
    +        Inc(NextIndex);
    +{$endif FPC_HAS_FEATURE_RANDOM}
    +      end;
     
    +
    +    procedure Rewrite(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Rewrite(f);
    +      end;
    +
    +
    +    procedure Reset(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Reset(f);
    +      end;
    +
    +
    +
         procedure Get(var f:TypedFile);[IOCheck];
           Begin
             if not(eof(f)) then
    
    iso7185_1.pp.patch (5,360 bytes)
  • iso7185_2.pp.patch (6,136 bytes)
    --- rtl/inc/iso7185.pp.orig	2016-12-22 14:25:59.000000000 +0100
    +++ rtl/inc/iso7185.pp	2016-12-22 18:29:44.000000000 +0100
    @@ -26,13 +26,13 @@
     
         Procedure Rewrite(var t : Text);
         Procedure Reset(var t : Text);
    -    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
    -    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
    +    Procedure Reset(var f : TypedFile);
    +    Procedure Rewrite(var f : TypedFile);
     
         Procedure Rewrite(var t : Text;const filename : string);
         Procedure Reset(var t : Text;const filename : string);
    -    Procedure Reset(var f : TypedFile;const filename : string);   [INTERNPROC: fpc_in_Reset_TypedFile_Name];
    -    Procedure Rewrite(var f : TypedFile;const filename : string); [INTERNPROC: fpc_in_Rewrite_TypedFile_Name];
    +    Procedure Reset(var f : TypedFile;const filename : string);
    +    Procedure Rewrite(var f : TypedFile;const filename : string);
     
         Function Eof(Var t: Text): Boolean;
         Function Eof:Boolean;
    @@ -52,16 +52,105 @@
     
       implementation
     
    -{$IFDEF UNIX}
    +{$IF defined(WINDOWS)}
    +    type
    +      LPWStr = PWideChar;
    +      WinBool = LongBool;
    +      TSysCharSet = set of AnsiChar;
    +
    +    function GetEnvironmentStringsW: LPWStr; stdcall; external 'kernel32' name 'GetEnvironmentStringsW';
    +    function FreeEnvironmentStringsW(_para1 : LPWStr): WinBool; 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;
    -      pd : char; // Pathdelim not available ?
         begin
           value := '/tmp/';  (** default for UNIX **)
    -      pd:='/';
           while (envp <> NIL) and assigned(envp^) do
           begin
             i_env := 0;
    @@ -88,16 +177,19 @@
             inc(envp);
           end;
           i_value:=length(value);
    -      if (i_value>0) and (value[i_value]<>pd) then
    -       value:=value+pd;
    +      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
    +        value := value + DirectorySeparator;
           getTempDir := value;
         end;
    -{$else}    
    +
    +{$ELSE}  // neither unix nor windows
    +
       function getTempDir: string;
       begin
    -    getTempDir:='';
    +    getTempDir := '';
       end;
    -{$ENDIF}  
    +
    +{$ENDIF}
     
     {$i-}
         procedure DoAssign(var t : Text);
    @@ -234,6 +326,60 @@
           end;
     
     
    +    procedure DoAssign(var f : TypedFile);
    +{$ifndef FPC_HAS_FEATURE_RANDOM}
    +      const
    +        NextIndex : Word = 1;
    +{$endif FPC_HAS_FEATURE_RANDOM}
    +      begin
    +{$ifdef FPC_HAS_FEATURE_RANDOM}
    +        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
    +{$else FPC_HAS_FEATURE_RANDOM}
    +        Assign(f,getTempDir+'fpc_'+HexStr(NextIndex,4)+'.tmp');
    +        Inc(NextIndex);
    +{$endif FPC_HAS_FEATURE_RANDOM}
    +      end;
    +
    +
    +    procedure Rewrite(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Rewrite(f);
    +      end;
    +
    +
    +    procedure Reset(var f : TypedFile);[IOCheck];
    +      begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          DoAssign(f);
    +
    +        System.Reset(f);
    +      end;
    +
    +
    +    Procedure Rewrite(var f : TypedFile; const filename : string);[IOCheck];
    +      Begin
    +        { create file name? }
    +        if FileRec(f).mode=0 then
    +          Assign(f,filename);
    +
    +        System.Rewrite(f);
    +      End;
    +
    +
    +    Procedure Reset(var f : TypedFile; const filename : string);[IOCheck];
    +      Begin
    +        if FileRec(f).mode=0 then
    +          Assign(f,filename);
    +
    +        System.Reset(f);
    +      End;
    +
    +
         procedure Get(var f:TypedFile);[IOCheck];
           Begin
             if not(eof(f)) then
    
    iso7185_2.pp.patch (6,136 bytes)
  • iso7185_typefile.patch (8,593 bytes)
    --- rtl/inc/iso7185.pp	(Revision 35178)
    +++ rtl/inc/iso7185.pp	(Arbeitskopie)
    @@ -52,16 +52,105 @@
     
       implementation
     
    -{$IFDEF UNIX}
    +{$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;
    -      pd : char; // Pathdelim not available ?
         begin
           value := '/tmp/';  (** default for UNIX **)
    -      pd:='/';
           while (envp <> NIL) and assigned(envp^) do
           begin
             i_env := 0;
    @@ -88,17 +177,20 @@
             inc(envp);
           end;
           i_value:=length(value);
    -      if (i_value>0) and (value[i_value]<>pd) then
    -       value:=value+pd;
    +      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
    +        value := value + DirectorySeparator;
           getTempDir := value;
         end;
    -{$else}    
    +
    +{$ELSE}  // neither unix nor windows
    +
       function getTempDir: string;
       begin
         getTempDir:='';
       end;
    -{$ENDIF}  
     
    +{$ENDIF}
    +
     {$i-}
         procedure DoAssign(var t : Text);
     {$ifndef FPC_HAS_FEATURE_RANDOM}
    --- rtl/inc/typefile.inc	(Revision 35178)
    +++ rtl/inc/typefile.inc	(Arbeitskopie)
    @@ -69,11 +69,151 @@
     End;
     
     
    +{ this code is duplicated in the iso7185 unit }
    +{$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}
    +
     {$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 +224,7 @@
     {$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;
    
    iso7185_typefile.patch (8,593 bytes)

Activities

Karl-Michael Schindler

2016-07-23 20:08

reporter  

fpc-tmpdir.patch (2,571 bytes)
Index: rtl/inc/iso7185.pp
===================================================================
--- rtl/inc/iso7185.pp	(Revision 34190)
+++ rtl/inc/iso7185.pp	(Arbeitskopie)
@@ -26,8 +26,8 @@
 
     Procedure Rewrite(var t : Text);
     Procedure Reset(var t : Text);
-    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
-    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
+    Procedure Reset(var f : TypedFile);
+    Procedure Rewrite(var f : TypedFile);
 
     Function Eof(Var t: Text): Boolean;
     Function Eof:Boolean;
@@ -46,11 +46,50 @@
     Function Eof(var f:TypedFile): Boolean;
 
   implementation
-
+  
+  function getTempDir: string;
+    var
+      key: string;
+      value: string;
+      i_env, i_key, i_value: integer;
+    begin
+    {$IFDEF HASUNIX}
+      value := '/tmp/';  (** default for UNIX **)
+    {$ELSE}
+      value := '';
+    {$ENDIF}
+      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;
+      getTempDir := value;
+    end;
+  
 {$i-}
     procedure DoAssign(var t : Text);
       begin
-        Assign(t,'fpc_'+HexStr(random(1000000000),8)+'.tmp');
+        Assign(t,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
       end;
 
 
@@ -149,6 +188,32 @@
       end;
 
 
+    procedure DoAssign(var f : TypedFile);
+      begin
+        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
+      end;
+
+
+    procedure Rewrite(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Rewrite(f);
+      end;
+
+
+    procedure Reset(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Reset(f);
+      end;
+
+
     procedure Get(var f:TypedFile);[IOCheck];
       Begin
         if not(eof(f)) then
fpc-tmpdir.patch (2,571 bytes)

Pierre Muller

2016-07-28 23:37

developer   ~0093875

Hi Karl-Michael,

  I am not familiar with ISO mode expectations,
thus I cannot comment on the validity of your patch as a whole.
But regarding unix behavior, are the three
environment variables you are testing all considered equivalent?

  If several of those variables are set to different values,
isn't one prevalent, for instance in GNU software?
I don't think your code establishes such a hierachy.

Pierre Muller

Karl-Michael Schindler

2016-07-29 00:08

reporter   ~0093876

Last edited: 2016-07-29 00:24

View 2 revisions

As much as I know ISO, it does not make any specification. But on unixoides it is quite uncommon to place temporary files in the directory, from where the program is started, because it is leaving temporary files all over the places.
I do not know about the prevalence of the three. A short review did not reveal anything solid. This page (http://dcx.sybase.com/1200/en/dbadmin/temp-environment-variables.html) suggests a hierarchy of TMP, TMPDIR, TEMP. The current code takes the last one in the sequence of the environment variables. The code could be modified to take the first one.

Michael Van Canneyt

2016-09-10 14:14

administrator   ~0094535

I added the gettempdir function. Trunk version of iso file has changed somewhat so your patch didn't apply cleanly. please check and set to closed if OK.

Karl-Michael Schindler

2016-09-13 13:02

reporter   ~0094623

Thanks for taking care. As much as i see, that patch fixes text files only, but not general typed files. Therefore, the three procedures for typed files still need to be added, or do i miss something?

These are the three missing procedures:

procedure DoAssign(var f : TypedFile);
procedure Rewrite(var f : TypedFile);[IOCheck];
procedure Reset(var f : TypedFile);[IOCheck];

Can you take their implementation directly from the present patch file or should i produce a new patch file?

MiSchi.

Michael Van Canneyt

2016-09-13 13:10

administrator   ~0094626

As I said, the patch didn't apply. Please do create a new one, I will apply it ASAP.

Karl-Michael Schindler

2016-09-13 22:46

reporter  

iso7185.patch (2,193 bytes)
--- rtl/inc/iso7185.pp	2016-09-13 23:42:07.000000000 +0300
+++ rtl/inc/iso7185-KMS.pp	2016-09-13 23:42:02.000000000 +0300
@@ -26,8 +26,8 @@
 
     Procedure Rewrite(var t : Text);
     Procedure Reset(var t : Text);
-    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
-    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
+    Procedure Reset(var f : TypedFile);
+    Procedure Rewrite(var f : TypedFile);
 
     Function Eof(Var t: Text): Boolean;
     Function Eof:Boolean;
@@ -47,16 +47,17 @@
 
   implementation
 
-{$IFDEF UNIX}
   function getTempDir: string;
     var
       key: string;
       value: string;
       i_env, i_key, i_value: integer;
-      pd : char; // Pathdelim not available ?
     begin
+{$IFDEF UNIX}
       value := '/tmp/';  (** default for UNIX **)
-      pd:='/';
+{$ELSE}
+      value := '';       (** no default elsewhere **)
+{$ENDIF}    
       while (envp <> NIL) and assigned(envp^) do
       begin
         i_env := 0;
@@ -82,17 +83,11 @@
         end;
         inc(envp);
       end;
-      i_value:=length(value);
-      if (i_value>0) and (value[i_value]<>pd) then
-       value:=value+pd;
+      i_value := length(value);
+      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
+       value := value + DirectorySeparator;
       getTempDir := value;
     end;
-{$else}    
-  function getTempDir: string;
-  begin
-    getTempDir:='';
-  end;
-{$ENDIF}  
 
 {$i-}
     procedure DoAssign(var t : Text);
@@ -205,6 +200,32 @@
       end;
 
 
+    procedure DoAssign(var f : TypedFile);
+      begin
+        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
+      end;
+
+
+    procedure Rewrite(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Rewrite(f);
+      end;
+
+
+    procedure Reset(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Reset(f);
+      end;
+
+
     procedure Get(var f:TypedFile);[IOCheck];
       Begin
         if not(eof(f)) then
iso7185.patch (2,193 bytes)

Karl-Michael Schindler

2016-09-13 22:50

reporter   ~0094644

I hope the second patch file does the trick on the current version. I used DirectorySeparator as path delimiter and also checked for the environment variables in getTempDir on non-unixoids such as windows. Finally, the procedures for typed files are added.

Cyrax

2016-09-14 04:26

reporter   ~0094646

Second patch will cause building FPC under Windows fail. There is no envp declared for Windows.

Michael Van Canneyt

2016-09-14 13:03

administrator   ~0094647

Indeed, that is why the whole function was under {$IFDEF UNIX}

Secondly, removing [INTERNPROC: fpc_in_Reset_TypedFile] is probably not a good idea: as far as I know INTERNPROC has a special meaning.

Can you confirm with the compiler people that this is allowed, please ?

Cyrax

2016-09-14 15:49

reporter  

iso7185_1.pp.patch (5,360 bytes)
Index: rtl/inc/iso7185.pp
===================================================================
--- rtl/inc/iso7185.pp	(revision 34525)
+++ rtl/inc/iso7185.pp	(working copy)
@@ -26,8 +26,8 @@
 
     Procedure Rewrite(var t : Text);
     Procedure Reset(var t : Text);
-    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
-    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
+    Procedure Reset(var f : TypedFile);
+    Procedure Rewrite(var f : TypedFile);
 
     Function Eof(Var t: Text): Boolean;
     Function Eof:Boolean;
@@ -47,16 +47,108 @@
 
   implementation
 
-{$IFDEF UNIX}
+  {$IFDEF WINDOWS}
+    type
+      LPWSTR = Pwidechar;
+      WINBOOL = longbool;
+      TSysCharSet = Set of AnsiChar;
+
+    function GetEnvironmentStringsW:LPWSTR;stdcall; external 'kernel32' name 'GetEnvironmentStringsW';
+    function FreeEnvironmentStringsW(_para1:LPWSTR):WINBOOL;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}
+
+  {$ENDIF WINDOWS}
+
+  {$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;
@@ -83,17 +175,13 @@
         inc(envp);
       end;
       i_value:=length(value);
-      if (i_value>0) and (value[i_value]<>pd) then
-       value:=value+pd;
+      if (i_value>0) and (value[i_value]<>DirectorySeparator) then
+       value:=value+DirectorySeparator;
       getTempDir := value;
     end;
-{$else}    
-  function getTempDir: string;
-  begin
-    getTempDir:='';
-  end;
-{$ENDIF}  
 
+{$ENDIF UNIX}
+
 {$i-}
     procedure DoAssign(var t : Text);
 {$ifndef FPC_HAS_FEATURE_RANDOM}
@@ -204,7 +292,42 @@
           FileFunc(TextRec(t).InOutFunc)(TextRec(t));
       end;
 
+    procedure DoAssign(var f : TypedFile);
+{$ifndef FPC_HAS_FEATURE_RANDOM}
+      const
+        NextIndex : Word = 1;
+{$endif FPC_HAS_FEATURE_RANDOM}
+      begin
+{$ifdef FPC_HAS_FEATURE_RANDOM}
+        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
+{$else FPC_HAS_FEATURE_RANDOM}
+        Assign(f,getTempDir+'fpc_'+HexStr(NextIndex,4)+'.tmp');
+        Inc(NextIndex);
+{$endif FPC_HAS_FEATURE_RANDOM}
+      end;
 
+
+    procedure Rewrite(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Rewrite(f);
+      end;
+
+
+    procedure Reset(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Reset(f);
+      end;
+
+
+
     procedure Get(var f:TypedFile);[IOCheck];
       Begin
         if not(eof(f)) then
iso7185_1.pp.patch (5,360 bytes)

Cyrax

2016-09-14 15:51

reporter   ~0094651

Attached my attempt to make iso mode work under Windows.

Karl-Michael Schindler

2016-12-22 20:42

reporter  

iso7185_2.pp.patch (6,136 bytes)
--- rtl/inc/iso7185.pp.orig	2016-12-22 14:25:59.000000000 +0100
+++ rtl/inc/iso7185.pp	2016-12-22 18:29:44.000000000 +0100
@@ -26,13 +26,13 @@
 
     Procedure Rewrite(var t : Text);
     Procedure Reset(var t : Text);
-    Procedure Reset(var f : TypedFile);   [INTERNPROC: fpc_in_Reset_TypedFile];
-    Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
+    Procedure Reset(var f : TypedFile);
+    Procedure Rewrite(var f : TypedFile);
 
     Procedure Rewrite(var t : Text;const filename : string);
     Procedure Reset(var t : Text;const filename : string);
-    Procedure Reset(var f : TypedFile;const filename : string);   [INTERNPROC: fpc_in_Reset_TypedFile_Name];
-    Procedure Rewrite(var f : TypedFile;const filename : string); [INTERNPROC: fpc_in_Rewrite_TypedFile_Name];
+    Procedure Reset(var f : TypedFile;const filename : string);
+    Procedure Rewrite(var f : TypedFile;const filename : string);
 
     Function Eof(Var t: Text): Boolean;
     Function Eof:Boolean;
@@ -52,16 +52,105 @@
 
   implementation
 
-{$IFDEF UNIX}
+{$IF defined(WINDOWS)}
+    type
+      LPWStr = PWideChar;
+      WinBool = LongBool;
+      TSysCharSet = set of AnsiChar;
+
+    function GetEnvironmentStringsW: LPWStr; stdcall; external 'kernel32' name 'GetEnvironmentStringsW';
+    function FreeEnvironmentStringsW(_para1 : LPWStr): WinBool; 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;
-      pd : char; // Pathdelim not available ?
     begin
       value := '/tmp/';  (** default for UNIX **)
-      pd:='/';
       while (envp <> NIL) and assigned(envp^) do
       begin
         i_env := 0;
@@ -88,16 +177,19 @@
         inc(envp);
       end;
       i_value:=length(value);
-      if (i_value>0) and (value[i_value]<>pd) then
-       value:=value+pd;
+      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
+        value := value + DirectorySeparator;
       getTempDir := value;
     end;
-{$else}    
+
+{$ELSE}  // neither unix nor windows
+
   function getTempDir: string;
   begin
-    getTempDir:='';
+    getTempDir := '';
   end;
-{$ENDIF}  
+
+{$ENDIF}
 
 {$i-}
     procedure DoAssign(var t : Text);
@@ -234,6 +326,60 @@
       end;
 
 
+    procedure DoAssign(var f : TypedFile);
+{$ifndef FPC_HAS_FEATURE_RANDOM}
+      const
+        NextIndex : Word = 1;
+{$endif FPC_HAS_FEATURE_RANDOM}
+      begin
+{$ifdef FPC_HAS_FEATURE_RANDOM}
+        Assign(f,getTempDir+'fpc_'+HexStr(random(1000000000),8)+'.tmp');
+{$else FPC_HAS_FEATURE_RANDOM}
+        Assign(f,getTempDir+'fpc_'+HexStr(NextIndex,4)+'.tmp');
+        Inc(NextIndex);
+{$endif FPC_HAS_FEATURE_RANDOM}
+      end;
+
+
+    procedure Rewrite(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Rewrite(f);
+      end;
+
+
+    procedure Reset(var f : TypedFile);[IOCheck];
+      begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          DoAssign(f);
+
+        System.Reset(f);
+      end;
+
+
+    Procedure Rewrite(var f : TypedFile; const filename : string);[IOCheck];
+      Begin
+        { create file name? }
+        if FileRec(f).mode=0 then
+          Assign(f,filename);
+
+        System.Rewrite(f);
+      End;
+
+
+    Procedure Reset(var f : TypedFile; const filename : string);[IOCheck];
+      Begin
+        if FileRec(f).mode=0 then
+          Assign(f,filename);
+
+        System.Reset(f);
+      End;
+
+
     procedure Get(var f:TypedFile);[IOCheck];
       Begin
         if not(eof(f)) then
iso7185_2.pp.patch (6,136 bytes)

Karl-Michael Schindler

2016-12-22 20:53

reporter   ~0097017

Hi.

I uploaded another version (iso7185_2.pp.patch). It applies to current (35177) trunk and contains the windows version from Cyrax (thanks for that), the unix version and a dummy for the rest.

Removing INTERNPROC is required. If present it references to internal calling convention, which is definitely wrong for a local defined procedure. Leaving it produces an error when compiling.

I have tested cross building versus all targets (nearly 49) on OS X, but would appreciate further native tests on other systems.

Michael.

Sven Barth

2016-12-23 14:22

manager   ~0097034

Last edited: 2016-12-23 14:24

View 3 revisions

Removing INTERNPROC is *wrong*, cause the compiler diverts to the correct internal function based on the mode (ISO or not) [see compiler/ninl.pas, tinlinenode.handle_reset_rewrite_typed]. You should instead modify fpc_reset_typed_iso and fpc_rewrite_typed_iso (both are located in rtl/inc/typefile.inc).

Michael Van Canneyt

2016-12-23 14:50

administrator   ~0097038

That is why I didn't apply the previous patches, because of the removed internproc. Only I cannot give the detailed axplanation that Sven can give...

Karl-Michael Schindler

2016-12-23 15:24

reporter   ~0097040

OK. Thanks for clarifications. I obviously got wrong the meaning of INTERNPROC. Working on it.

Karl-Michael Schindler

2016-12-23 16:39

reporter  

iso7185_typefile.patch (8,593 bytes)
--- rtl/inc/iso7185.pp	(Revision 35178)
+++ rtl/inc/iso7185.pp	(Arbeitskopie)
@@ -52,16 +52,105 @@
 
   implementation
 
-{$IFDEF UNIX}
+{$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;
-      pd : char; // Pathdelim not available ?
     begin
       value := '/tmp/';  (** default for UNIX **)
-      pd:='/';
       while (envp <> NIL) and assigned(envp^) do
       begin
         i_env := 0;
@@ -88,17 +177,20 @@
         inc(envp);
       end;
       i_value:=length(value);
-      if (i_value>0) and (value[i_value]<>pd) then
-       value:=value+pd;
+      if (i_value > 0) and (value[i_value] <> DirectorySeparator) then
+        value := value + DirectorySeparator;
       getTempDir := value;
     end;
-{$else}    
+
+{$ELSE}  // neither unix nor windows
+
   function getTempDir: string;
   begin
     getTempDir:='';
   end;
-{$ENDIF}  
 
+{$ENDIF}
+
 {$i-}
     procedure DoAssign(var t : Text);
 {$ifndef FPC_HAS_FEATURE_RANDOM}
--- rtl/inc/typefile.inc	(Revision 35178)
+++ rtl/inc/typefile.inc	(Arbeitskopie)
@@ -69,11 +69,151 @@
 End;
 
 
+{ this code is duplicated in the iso7185 unit }
+{$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}
+
 {$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 +224,7 @@
 {$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;
iso7185_typefile.patch (8,593 bytes)

Karl-Michael Schindler

2016-12-23 16:42

reporter   ~0097046

Upload of iso7185_typefile.patch. This patches iso7185.pp and typefile.inc. Tested natively on OSX and cross-building with i386-win32, arm-linux and arm-gba.

Michael Van Canneyt

2017-03-18 19:12

administrator   ~0099027

Applied the patch, but slightly different: I put the common code in a file called isotmp.inc, so as to avoid code duplication.

Karl-Michael Schindler

2017-03-18 19:19

reporter   ~0099030

Very nice solution. Thanks for applying.

Issue History

Date Modified Username Field Change
2016-07-23 20:08 Karl-Michael Schindler New Issue
2016-07-23 20:08 Karl-Michael Schindler File Added: fpc-tmpdir.patch
2016-07-28 23:37 Pierre Muller Note Added: 0093875
2016-07-29 00:08 Karl-Michael Schindler Note Added: 0093876
2016-07-29 00:24 Karl-Michael Schindler Note Edited: 0093876 View Revisions
2016-09-10 14:14 Michael Van Canneyt Fixed in Revision => 34480
2016-09-10 14:14 Michael Van Canneyt Note Added: 0094535
2016-09-10 14:14 Michael Van Canneyt Status new => resolved
2016-09-10 14:14 Michael Van Canneyt Resolution open => fixed
2016-09-10 14:14 Michael Van Canneyt Assigned To => Michael Van Canneyt
2016-09-13 13:02 Karl-Michael Schindler Note Added: 0094623
2016-09-13 13:02 Karl-Michael Schindler Status resolved => feedback
2016-09-13 13:02 Karl-Michael Schindler Resolution fixed => reopened
2016-09-13 13:10 Michael Van Canneyt Note Added: 0094626
2016-09-13 22:46 Karl-Michael Schindler File Added: iso7185.patch
2016-09-13 22:50 Karl-Michael Schindler Note Added: 0094644
2016-09-13 22:50 Karl-Michael Schindler Status feedback => assigned
2016-09-14 04:26 Cyrax Note Added: 0094646
2016-09-14 13:03 Michael Van Canneyt Note Added: 0094647
2016-09-14 15:49 Cyrax File Added: iso7185_1.pp.patch
2016-09-14 15:51 Cyrax Note Added: 0094651
2016-12-22 20:42 Karl-Michael Schindler File Added: iso7185_2.pp.patch
2016-12-22 20:53 Karl-Michael Schindler Note Added: 0097017
2016-12-23 14:22 Sven Barth Note Added: 0097034
2016-12-23 14:24 Sven Barth Note Edited: 0097034 View Revisions
2016-12-23 14:24 Sven Barth Note Edited: 0097034 View Revisions
2016-12-23 14:50 Michael Van Canneyt Note Added: 0097038
2016-12-23 15:24 Karl-Michael Schindler Note Added: 0097040
2016-12-23 16:39 Karl-Michael Schindler File Added: iso7185_typefile.patch
2016-12-23 16:42 Karl-Michael Schindler Note Added: 0097046
2017-03-18 19:12 Michael Van Canneyt Fixed in Revision 34480 => 35622
2017-03-18 19:12 Michael Van Canneyt Note Added: 0099027
2017-03-18 19:12 Michael Van Canneyt Status assigned => resolved
2017-03-18 19:12 Michael Van Canneyt Fixed in Version => 3.1.1
2017-03-18 19:12 Michael Van Canneyt Resolution reopened => fixed
2017-03-18 19:12 Michael Van Canneyt Target Version => 3.2.0
2017-03-18 19:19 Karl-Michael Schindler Note Added: 0099030
2017-03-18 19:19 Karl-Michael Schindler Status resolved => closed