paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-10 23:20:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ unicodestring support for assign/erase/rename

Browse Source 
+ codepage support for textrec/filerec and the above routines
  * textrec/filerec now store the filename by default using widechar. It is
    possible to switch back to ansichars using the FPC_ANSI_TEXTFILEREC define.
    In that case, from now on the filename will always be stored in
    DefaultFileSystemEncoding
  * fixed potential buffer overflows and non-null-terminated file names in
    textrec/filerec
  + dodirseparators(pwidechar), changed the dodirseparators(pchar/pwidechar)
    parameters into var-parameters and gave those routines an extra parameter
    that indicates whether the p(wide)char can be changed in place if
    necessary or whether a copy must be made first (avoids us having to make
    all strings always unique everywhere, because they might be changed on
    some platforms via a pchar)
  * do_open/do_erase/do_rename got extra boolean parameters indicating whether
    the passed pchars point to data that can be freely changed (to pass on to
    dodirseparators() if applicable)
  * objects.pp: force assign(pchar) to be called, because
    assign(array[0..255]) cannot choose between pchar and rawbytestring
    versions (and removing the pchar version means that assign(pchar) will
    be mapped to assign(shortstring) in {$h-})
  * fixed up some routines in other units that depend on the format of
    the textrec/filerec.name field

git-svn-id: branches/cpstrrtl@25137 -
This commit is contained in:
Jonas Maebe 2013-07-19 16:30:51 +00:00
parent d676bbf9af
commit df6a2dce00
41 changed files with 1042 additions and 333 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
rtl/amiga/dos.pp
View File

@ -725,7 +725,11 @@ var
begin
DosError:=0;
FTime := 0;
Str := StrPas(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
Str := strpas(filerec(f).Name);
{$else}
Str := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
DoDirSeparators(Str);
FLock := dosLock(Str, SHARED_LOCK);
IF FLock <> 0 then begin
@ -756,7 +760,11 @@ end;
FLock: longint;
Begin
new(DateStamp);
Str := StrPas(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
Str := strpas(filerec(f).Name);
{$else}
Str := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
DoDirSeparators(str);
{ Check first of all, if file exists }
FLock := dosLock(Str, SHARED_LOCK);
@ -788,7 +796,11 @@ begin
DosError:=0;
flags:=0;
New(info);
Str := StrPas(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
Str := strpas(filerec(f).Name);
{$else}
Str := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
DoDirSeparators(str);
{ open with shared lock to check if file exists }
MyLock:=dosLock(Str,SHARED_LOCK);
@ -825,7 +837,17 @@ procedure setfattr(var f; attr : word);
var
flags: longint;
tmpLock : longint;
{$ifndef FPC_ANSI_TEXTFILEREC}
r : rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
p : pchar;
begin
{$ifdef FPC_ANSI_TEXTFILEREC}
p := @filerec(f).Name;
{$else}
r := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
p := pchar(r);
{$endif}
DosError:=0;
flags:=FIBF_WRITE;
@ -836,10 +858,10 @@ begin
{ converts the path (KB) }
{ create a shared lock on the file }
tmpLock:=Lock(filerec(f).name,SHARED_LOCK);
tmpLock:=Lock(p,SHARED_LOCK);
if tmpLock <> 0 then begin
Unlock(tmpLock);
if not SetProtection(filerec(f).name,flags) then DosError:=5;
if not SetProtection(p,flags) then DosError:=5;
end else
DosError:=3;
end;

6
rtl/amiga/sysfile.inc
View File

@ -170,7 +170,7 @@ begin
end;
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
var
tmpStr: array[0..255] of Char;
begin
@ -180,7 +180,7 @@ begin
dosError2InOut(IoErr);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
{ quite stack-effective code, huh? :) damn path conversions... (KB) }
var
tmpStr1: array[0..255] of Char;
@ -306,7 +306,7 @@ begin
end;
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.

6
rtl/embedded/sysfile.inc
View File

@ -27,11 +27,11 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
begin
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
begin
end;
@ -69,7 +69,7 @@ procedure do_truncate(handle, pos: longint);
begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
begin
end;

14
rtl/emx/dos.pas
View File

@ -944,8 +944,11 @@ var
buffer:array[0..255] of char;
begin
DosError := 0;
path:='';
path := StrPas(filerec(f).Name);
{$ifdef FPC_ANSI_TEXTFILEREC}
path:=filerec(f).Name;
{$else}
path:=ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
{ Takes care of slash and backslash support }
path:=FExpand(path);
move(path[1],buffer,length(path));
@ -974,9 +977,12 @@ var
path: pathstr;
buffer:array[0..255] of char;
begin
path:='';
DosError := 0;
path := StrPas(filerec(f).Name);
{$ifdef FPC_ANSI_TEXTFILEREC}
path:=filerec(f).Name;
{$else}
path:=ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
{ Takes care of slash and backslash support }
path:=FExpand(path);
move(path[1],buffer,length(path));

37
rtl/emx/sysfile.inc
View File

@ -40,10 +40,12 @@ begin
end;
end;
procedure do_erase(p:Pchar);
procedure do_erase(p:Pchar; pchangeable: boolean);
var
oldp: pchar;
begin
DoDirSeparators(p);
oldp:=p;
DoDirSeparators(p,pchangeable);
asm
movl P,%edx
movb $0x41,%ah
@ -52,13 +54,18 @@ begin
movw %ax,inoutres
.LERASE1:
end ['eax', 'edx'];
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2:Pchar);
procedure do_rename(p1,p2:Pchar; p1changeable, p2changeable: boolean);
var
oldp1, oldp2 : pchar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
asm
movl P1, %edx
movl P2, %edi
@ -68,6 +75,10 @@ begin
movw %ax,inoutres
.LRENAME1:
end ['eax', 'edx', 'edi'];
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
function do_read (H: THandle; Addr: pointer; Len: longint): longint; assembler;
@ -254,7 +265,7 @@ begin
end;
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
@ -264,10 +275,10 @@ procedure do_open(var f;p:pchar;flags:longint);
when (flags and $10000) there is no check for close (needed for textfiles)
}
var Action: cardinal;
var
Action: cardinal;
oldp : pchar;
begin
DoDirSeparators(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
@ -309,6 +320,8 @@ begin
end;
exit;
end;
oldp:=p;
DoDirSeparators(p,pchangeable);
Action := Action or (Flags and $FF);
(* DenyNone if sharing not specified. *)
if Flags and 112 = 0 then
@ -356,6 +369,8 @@ begin
FileRec (F).Mode := fmOutput; {fool fmappend}
end;
end;
if oldp<>p then
freemem(p);
end;
{$ASMMODE INTEL}

6
rtl/gba/sysfile.inc
View File

@ -27,11 +27,11 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
begin
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
begin
end;
@ -69,7 +69,7 @@ procedure do_truncate(handle, pos: longint);
begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
begin
end;

18
rtl/go32v2/dos.pp
View File

@ -1083,8 +1083,17 @@ end;
procedure getfattr(var f;var attr : word);
{$ifndef FPC_ANSI_TEXTFILEREC}
var
r: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
begin
{$ifdef FPC_ANSI_TEXTFILEREC}
copytodos(filerec(f).name,strlen(filerec(f).name)+1);
{$else}
r:=ToSingleByteFileSystemEncodedFileName(filerec(f).name);
copytodos(pchar(r)^,length(r)+1);
{$endif}
dosregs.edx:=tb_offset;
dosregs.ds:=tb_segment;
if LFNSupport then
@ -1101,6 +1110,10 @@ end;
procedure setfattr(var f;attr : word);
{$ifndef FPC_ANSI_TEXTFILEREC}
var
r: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
begin
{ Fail for setting VolumeId. }
if ((attr and VolumeID)<>0) then
@ -1108,7 +1121,12 @@ begin
doserror:=5;
exit;
end;
{$ifdef FPC_ANSI_TEXTFILEREC}
copytodos(filerec(f).name,strlen(filerec(f).name)+1);
{$else}
r:=ToSingleByteFileSystemEncodedFileName(filerec(f).name);
copytodos(pchar(r)^,length(r)+1);
{$endif}
dosregs.edx:=tb_offset;
dosregs.ds:=tb_segment;
if LFNSupport then

31
rtl/go32v2/sysfile.inc
View File

@ -54,11 +54,13 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
var
regs : trealregs;
oldp : pchar;
begin
DoDirSeparators(p);
oldp:=p;
DoDirSeparators(p,pchangeable);
syscopytodos(longint(p),strlen(p)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
@ -71,15 +73,20 @@ begin
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
var
regs : trealregs;
oldp1, oldp2 : pchar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
if strlen(p1)+strlen(p2)+3>tb_size then
HandleError(217);
sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1);
@ -96,6 +103,10 @@ begin
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
@ -280,7 +291,7 @@ begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
@ -291,8 +302,8 @@ procedure do_open(var f;p:pchar;flags:longint);
var
regs : trealregs;
action : longint;
oldp : pchar;
begin
DoDirSeparators(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
@ -334,6 +345,8 @@ begin
end;
exit;
end;
oldp:=p;
DoDirSeparators(p,pchangeable);
{ real dos call }
syscopytodos(longint(p),strlen(p)+1);
{$ifndef RTLLITE}
@ -385,6 +398,8 @@ begin
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
if oldp<>p then
freemem(p);
exit;
end
else
@ -419,6 +434,8 @@ begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
if oldp<>p then
freemem(p);
end;

228
rtl/inc/file.inc
View File

@ -18,35 +18,85 @@
type
UnTypedFile=File;
Procedure Assign(out f:File;const Name:string);
procedure InitFile(var f : file);
begin
FillChar(f,SizeOf(FileRec),0);
FileRec(f).Handle:=UnusedHandle;
FileRec(f).mode:=fmClosed;
end;
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out f:File;const Name: UnicodeString);
{
Assign Name to file f so it can be used with the file routines
}
Begin
FillChar(f,SizeOf(FileRec),0);
FileRec(f).Handle:=UnusedHandle;
FileRec(f).mode:=fmClosed;
Move(Name[1],FileRec(f).Name,Length(Name));
InitFile(F);
{$ifdef FPC_ANSI_TEXTFILEREC}
FileRec(f).Name:=ToSingleByteFileSystemEncodedFileName(Name);
{$else FPC_ANSI_TEXTFILEREC}
FileRec(f).Name:=Name;
{$endif FPC_ANSI_TEXTFILEREC}
{ null terminate, since the name array is regularly used as p(wide)char }
FileRec(f).Name[high(FileRec(f).Name)]:=#0;
End;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:File;const Name: RawByteString);
{
Assign Name to file f so it can be used with the file routines
}
Begin
InitFile(F);
{$ifdef FPC_ANSI_TEXTFILEREC}
{ ensure the characters in the record's filename are encoded correctly }
FileRec(f).Name:=ToSingleByteFileSystemEncodedFileName(Name);
{$else FPC_ANSI_TEXTFILEREC}
FileRec(f).Name:=Name;
{$endif FPC_ANSI_TEXTFILEREC}
{ null terminate, since the name array is regularly used as p(wide)char }
FileRec(f).Name[high(FileRec(f).Name)]:=#0;
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:File;const Name: ShortString);
{
Assign Name to file f so it can be used with the file routines
}
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(f,AnsiString(Name));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
InitFile(f);
{ warning: no encoding support }
FileRec(f).Name:=Name;
{ null terminate, since the name array is regularly used as p(wide)char }
FileRec(f).Name[high(FileRec(f).Name)]:=#0;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Assign(out f:File;const p: PAnsiChar);
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(f,AnsiString(p));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
{ no use in making this the one that does the work, since the name field is
limited to 255 characters anyway }
Assign(f,strpas(p));
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Assign(out f:File;p:pchar);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,StrPas(p));
end;
Procedure Assign(out f:File;c:char);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,string(c));
end;
Procedure Assign(out f:File;const c: AnsiChar);
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(f,AnsiString(c));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
Assign(f,ShortString(c));
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Rewrite(var f:File;l:Longint);[IOCheck];
{
@ -69,7 +119,7 @@ Begin
else
Begin
{ Reopen with filemode 2, to be Tp compatible (PFV) }
Do_Open(f,PChar(@FileRec(f).Name),$1002);
Do_Open(f,PFileTextRecChar(@FileRec(f).Name),$1002,false);
FileRec(f).RecSize:=l;
End;
End;
@ -95,7 +145,7 @@ Begin
InOutRes:=2
else
Begin
Do_Open(f,PChar(@FileRec(f).Name),Filemode);
Do_Open(f,PFileTextRecChar(@FileRec(f).Name),Filemode,false);
FileRec(f).RecSize:=l;
End;
End;
@ -383,44 +433,134 @@ Begin
If InOutRes <> 0 then
exit;
If FileRec(f).mode=fmClosed Then
Do_Erase(PChar(@FileRec(f).Name));
Do_Erase(PFileTextRecChar(@FileRec(f).Name),false);
End;
Procedure Rename(var f : File;p:pchar);[IOCheck];
Procedure Rename(var f : File; const S : UnicodeString);[IOCheck];
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
var
fs: RawByteString;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Begin
If InOutRes <> 0 then
exit;
If FileRec(f).mode=fmClosed Then
Begin
Do_Rename(PChar(@FileRec(f).Name),p);
{ check error code of do_rename }
If InOutRes = 0 then
Move(p^,FileRec(f).Name,StrLen(p)+1);
End;
If (InOutRes<>0) or
(FileRec(f).mode<>fmClosed) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{ it's slightly faster to convert the unicodestring here to rawbytestring
than doing it in do_rename(), because here we still know the length }
fs:=ToSingleByteFileSystemEncodedFileName(s);
Do_Rename(PFileTextRecChar(@FileRec(f).Name),PAnsiChar(fs),false,true);
If InOutRes=0 then
FileRec(f).Name:=fs
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_Rename(PFileTextRecChar(@FileRec(f).Name),PUnicodeChar(S),false,false);
If InOutRes=0 then
{$ifdef FPC_ANSI_TEXTFILEREC}
FileRec(f).Name:=ToSingleByteFileSystemEncodedFileName(s);
{$else FPC_ANSI_TEXTFILEREC}
FileRec(f).Name:=s
{$endif FPC_ANSI_TEXTFILEREC}
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
Procedure Rename(var f : File;const s : string);[IOCheck];
Procedure Rename(var f : File;const s : RawByteString);[IOCheck];
var
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
fs: RawByteString;
pdst: PAnsiChar;
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
fs: UnicodeString;
pdst: PUnicodeChar;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable: boolean;
Begin
If (InOutRes<>0) or
(FileRec(f).mode<>fmClosed) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable:=false;
pdst:=PAnsiChar(s);
if StringCodePage(s)<>DefaultFileSystemCodePage then
begin
fs:=ToSingleByteFileSystemEncodedFileName(s);
pdst:=PAnsiChar(fs);
dstchangeable:=true;
end
else
fs:=s;
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{ it's slightly faster to convert the rawbytestring here to unicodestring
than doing it in do_rename, because here we still know the length }
fs:=unicodestring(s);
pdst:=PUnicodeChar(fs);
dstchangeable:=true;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_Rename(PFileTextRecChar(@FileRec(f).Name),pdst,false,dstchangeable);
If InOutRes=0 then
{$if defined(FPC_ANSI_TEXTFILEREC) and not defined(FPCRTL_FILESYSTEM_SINGLE_BYTE_API)}
FileRec(f).Name:=ToSingleByteFileSystemEncodedFileName(fs)
{$else FPC_ANSI_TEXTFILEREC and not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
FileRec(f).Name:=fs
{$endif FPC_ANSI_TEXTFILEREC and not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
Procedure Rename(var f : File;const s : ShortString);[IOCheck];
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Begin
Rename(f,AnsiString(s));
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
p : array[0..255] Of Char;
Begin
If InOutRes <> 0 then
exit;
Move(s[1],p,Length(s));
p[Length(s)]:=#0;
Rename(f,Pchar(@p));
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var f : File;c : char);[IOCheck];
var
p : array[0..1] Of Char;
Procedure Rename(var f:File;const p : PAnsiChar);[IOCheck];
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Begin
Rename(f,AnsiString(p));
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
len: SizeInt
Begin
If InOutRes<>0 then
exit;
If FileRec(f).mode=fmClosed Then
Begin
Do_Rename(PFileTextRecChar(@FileRec(f).Name),p,false);
{ check error code of do_rename }
If InOutRes=0 then
begin
len:=min(StrLen(p),high(FileRec(f).Name));
Move(p^,FileRec(f).Name,len);
FileRec(f).Name[len]:=#0;
end;
End;
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var f:File;const c : AnsiChar);[IOCheck];
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Begin
Rename(f,AnsiString(c));
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
p : array[0..1] Of AnsiChar;
Begin
If InOutRes <> 0 then
exit;
p[0]:=c;
p[1]:=#0;
Rename(f,Pchar(@p));
Rename(f,PAnsiChar(@p));
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}

2
rtl/inc/filerec.inc
View File

@ -35,6 +35,6 @@ type
RecSize : SizeInt;
_private : array[1..3 * SizeOf(SizeInt) + 5 * SizeOf (pointer)] of byte;
UserData : array[1..32] of byte;
name : array[0..filerecnamelength] of char;
name : array[0..filerecnamelength] of TFileTextRecChar;
End;

2
rtl/inc/objects.pp
View File

@ -1389,7 +1389,7 @@ BEGIN
Begin { Check status okay }
If (Handle = InvalidHandle) Then
Begin { File not open }
Assign(FileInfo,FName);
Assign(FileInfo,@FName);
{ Handle the mode }
if OpenMode =stCreate then
Begin

118
rtl/inc/system.inc
View File

@ -1416,13 +1416,49 @@ end;
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ Allow slash and backslash as separators }
procedure DoDirSeparators(p:Pchar);
procedure DoDirSeparators(var p: pchar; inplace: boolean = true);
var
i : longint;
len : sizeint;
newp : pchar;
begin
for i:=0 to strlen(p) do
len:=length(p);
newp:=nil;
for i:=0 to len do
if p[i] in AllowDirectorySeparators then
p[i]:=DirectorySeparator;
begin
if not inplace and
not assigned(newp) then
begin
getmem(newp,len+1);
move(p^,newp^,len+1);
p:=newp;
end;
p[i]:=DirectorySeparator;
end;
end;
procedure DoDirSeparators(var p: pwidechar; inplace: boolean = true);
var
i : longint;
len : sizeint;
newp : pwidechar;
begin
len:=length(p);
newp:=nil;
for i:=0 to len do
if (ord(p[i])<255) and
(ansichar(ord(p[i])) in AllowDirectorySeparators) then
begin
if not inplace and
not assigned(newp) then
begin
getmem(newp,(len+1)*2);
move(p^,newp^,(len+1)*2);
p:=newp;
end;
p[i]:=DirectorySeparator;
end;
end;
procedure DoDirSeparators(var p:shortstring);
@ -1480,6 +1516,82 @@ end;
{ OS dependent low level file functions }
{$ifdef FPC_HAS_FEATURE_FILEIO}
{$i sysfile.inc}
{$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{$ifdef FPC_ANSI_TEXTFILEREC}
procedure do_open(var f; p: pansichar; flags: longint; pchangeable: boolean);
var
u: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
do_open(f,pwidechar(u),flags,true);
end;
procedure do_erase(p: pansichar; pchangeable: boolean);
var
u: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
do_erase(pwidechar(u),true);
end;
procedure do_rename(src, dst: pansichar; srcchangeable, dstchangeable: boolean);
var
usrc, udst: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
widestringmanager.Ansi2UnicodeMoveProc(dst,DefaultFileSystemCodePage,udst,length(dst));
do_rename(pwidechar(usrc),pwidechar(udst),true,true);
end;
procedure do_rename(src: pansichar; dst: pwidechar; srcchangeable, dstchangeable: boolean);
var
usrc: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
do_rename(pwidechar(usrc),dst,true,dstchangeable);
end;
{$endif FPC_ANSI_TEXTFILEREC}
{$endif not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
{$ifndef FPC_ANSI_TEXTFILEREC}
procedure do_open(var f; p: pwidechar; flags: longint; pchangeable: boolean);
var
s: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
do_open(f,pansichar(s),flags,true);
end;
procedure do_erase(p: pwidechar; pchangeable: boolean);
var
s: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
do_erase(pansichar(s),true);
end;
procedure do_rename(src, dst: pwidechar; srcchangeable, dstchangeable: boolean);
var
rsrc, rdst: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
widestringmanager.Unicode2AnsiMoveProc(dst,rdst,DefaultFileSystemCodePage,length(dst));
do_rename(pansichar(rsrc),pansichar(rdst),true,true);
end;
procedure do_rename(src: pwidechar; dst: pansichar; srcchangeable, dstchangeable: boolean);
var
rsrc: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
do_rename(pansichar(rsrc),dst,true,dstchangeable);
end;
{$endif not FPC_ANSI_TEXTFILEREC}
{$endif not FPCRTL_FILESYSTEM_TWO_BYTE_API}
{$endif FPC_HAS_FEATURE_FILEIO}
{ Text file }

58
rtl/inc/systemh.inc
View File

@ -495,6 +495,12 @@ Type
TSystemCodePage = Word;
{$ifdef VER2_6}
{ the size of textrec/filerec is hardcoded in the 2.6 compiler binary }
{$define FPC_ANSI_TEXTFILEREC}
{$endif}
TFileTextRecChar = {$ifdef FPC_ANSI_TEXTFILEREC}AnsiChar{$else}UnicodeChar{$endif};
PFileTextRecChar = ^TFileTextRecChar;
TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR);
@ -1098,9 +1104,20 @@ procedure SetMultiByteRTLFileSystemCodePage(CodePage: TSystemCodePage);
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure Assign(out f:File;const Name:string);
Procedure Assign(out f:File;p:pchar);
Procedure Assign(out f:File;c:char);
Procedure Assign(out f:File;const Name: ShortString);
Procedure Assign(out f:File;const p: PAnsiChar);
Procedure Assign(out f:File;const c: AnsiChar);
Procedure Rename(var f:File;const s : ShortString);
Procedure Rename(var f:File;const p : PAnsiChar);
Procedure Rename(var f:File;const c : AnsiChar);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out f:File;const Name: UnicodeString);
Procedure Rename(var f:File;const s : UnicodeString);
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:File;const Name: RawByteString);
Procedure Rename(var f:File;const s : RawByteString);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rewrite(var f:File;l:Longint);
Procedure Rewrite(var f:File);
Procedure Reset(var f:File;l:Longint);
@ -1123,9 +1140,6 @@ Function FileSize(var f:File):Int64;
Procedure Seek(var f:File;Pos:Int64);
Function EOF(var f:File):Boolean;
Procedure Erase(var f:File);
Procedure Rename(var f:File;const s:string);
Procedure Rename(var f:File;p:pchar);
Procedure Rename(var f:File;c:char);
Procedure Truncate (var F:File);
{$endif FPC_HAS_FEATURE_FILEIO}
@ -1135,9 +1149,15 @@ Procedure Truncate (var F:File);
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure Assign(out f:TypedFile;const Name:string);
Procedure Assign(out f:TypedFile;p:pchar);
Procedure Assign(out f:TypedFile;c:char);
Procedure Assign(out f:TypedFile;const Name:shortstring);
Procedure Assign(out f:TypedFile;const p:PAnsiChar);
Procedure Assign(out f:TypedFile;const c:AnsiChar);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out f:TypedFile;const Name:unicodestring);
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:TypedFile;const Name:rawbytestring);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Reset(var f : TypedFile); [INTERNPROC: fpc_in_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
{$endif FPC_HAS_FEATURE_FILEIO}
@ -1147,18 +1167,26 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
Procedure Assign(out t:Text;const s:string);
Procedure Assign(out t:Text;p:pchar);
Procedure Assign(out t:Text;c:char);
Procedure Assign(out t:Text;const s:shortstring);
Procedure Rename(var t:Text;const s:shortstring);
Procedure Assign(out t:Text;const p:PAnsiChar);
Procedure Rename(var t:Text;const p:PAnsiChar);
Procedure Assign(out t:Text;const c:AnsiChar);
Procedure Rename(var t:Text;const c:AnsiChar);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out t:Text;const s:unicodestring);
Procedure Rename(var t:Text;const s:unicodestring);
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var t:Text;const s:rawbytestring);
Procedure Assign(out t:Text;const s:rawbytestring);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Close(var t:Text);
Procedure Rewrite(var t:Text);
Procedure Reset(var t:Text);
Procedure Append(var t:Text);
Procedure Flush(var t:Text);
Procedure Erase(var t:Text);
Procedure Rename(var t:Text;const s:string);
Procedure Rename(var t:Text;p:pchar);
Procedure Rename(var t:Text;c:char);
Function EOF(var t:Text):Boolean;
Function EOF:Boolean;
Function EOLn(var t:Text):Boolean;

209
rtl/inc/text.inc
View File

@ -57,7 +57,7 @@ Begin
exit;
end;
End;
Do_Open(t,PChar(@t.Name),Flags);
Do_Open(t,PFileTextRecChar(@t.Name),Flags,False);
t.CloseFunc:=@FileCloseFunc;
t.FlushFunc:=nil;
if t.Mode=fmInput then
@ -74,9 +74,9 @@ Begin
end;
End;
Procedure InitText(Var t : Text);
Procedure Assign(out t:Text;const s:String);
Begin
begin
FillChar(t,SizeOf(TextRec),0);
{ only set things that are not zero }
TextRec(t).Handle:=UnusedHandle;
@ -89,20 +89,74 @@ Begin
tlbsCRLF: TextRec(t).LineEnd := #13#10;
tlbsCR: TextRec(t).LineEnd := #13;
End;
Move(s[1],TextRec(t).Name,Length(s));
end;
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out t:Text;const s : UnicodeString);
begin
InitText(t);
{$ifdef FPC_ANSI_TEXTFILEREC}
TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(S);
{$else FPC_ANSI_TEXTFILEREC}
TextRec(t).Name:=S;
{$endif FPC_ANSI_TEXTFILEREC}
{ null terminate, since the name array is regularly used as p(wide)char }
TextRec(t).Name[high(TextRec(t).Name)]:=#0;
end;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out t:Text;const s: RawByteString);
Begin
InitText(t);
{$ifdef FPC_ANSI_TEXTFILEREC}
{ ensure the characters in the record's filename are encoded correctly }
TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(S);
{$else FPC_ANSI_TEXTFILEREC}
TextRec(t).Name:=S;
{$endif FPC_ANSI_TEXTFILEREC}
{ null terminate, since the name array is regularly used as p(wide)char }
TextRec(t).Name[high(TextRec(t).Name)]:=#0;
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out t:Text;const s: ShortString);
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(t,AnsiString(s));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
InitText(t);
{ warning: no encoding support }
TextRec(t).Name:=s;
{ null terminate, since the name array is regularly used as p(wide)char }
TextRec(t).Name[high(TextRec(t).Name)]:=#0;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Assign(out t:Text;p:pchar);
begin
Assign(t,StrPas(p));
end;
Procedure Assign(out t:Text;const p: PAnsiChar);
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(t,AnsiString(p));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
{ no use in making this the one that does the work, since the name field is
limited to 255 characters anyway }
Assign(t,strpas(p));
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Assign(out t:Text;c:char);
begin
Assign(t,string(c));
end;
Procedure Assign(out t:Text;const c: AnsiChar);
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(t,AnsiString(c));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
Assign(t,ShortString(c));
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Close(var t : Text);[IOCheck];
@ -204,47 +258,134 @@ Begin
If InOutRes <> 0 then
exit;
If TextRec(t).mode=fmClosed Then
Do_Erase(PChar(@TextRec(t).Name));
Do_Erase(PFileTextRecChar(@TextRec(t).Name),false);
End;
Procedure Rename(var t : text;p:pchar);[IOCheck];
Procedure Rename(var t : Text;const s : unicodestring);[IOCheck];
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
var
fs: RawByteString;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Begin
If InOutRes <> 0 then
exit;
If TextRec(t).mode=fmClosed Then
Begin
Do_Rename(PChar(@TextRec(t).Name),p);
{ check error code of do_rename }
If InOutRes = 0 then
Move(p^,TextRec(t).Name,StrLen(p)+1);
End;
If (InOutRes<>0) or
(TextRec(t).mode<>fmClosed) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{ it's slightly faster to convert the unicodestring here to rawbytestring
than doing it in do_rename(), because here we still know the length }
fs:=ToSingleByteFileSystemEncodedFileName(s);
Do_Rename(PFileTextRecChar(@TextRec(t).Name),PAnsiChar(fs),false,true);
If InOutRes=0 then
TextRec(t).Name:=fs
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_Rename(PFileTextRecChar(@TextRec(t).Name),PUnicodeChar(S),false,false);
If InOutRes=0 then
{$ifdef FPC_ANSI_TEXTTextRec}
TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(s);
{$else FPC_ANSI_TEXTFILEREC}
TextRec(t).Name:=s
{$endif FPC_ANSI_TEXTFILEREC}
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
Procedure Rename(var t : Text;const s : string);[IOCheck];
Procedure Rename(var t : Text;const s : rawbytestring);[IOCheck];
var
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
fs: RawByteString;
pdst: PAnsiChar;
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
fs: UnicodeString;
pdst: PUnicodeChar;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable: boolean;
Begin
If (InOutRes<>0) or
(TextRec(t).mode<>fmClosed) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable:=false;
pdst:=PAnsiChar(s);
if StringCodePage(s)<>DefaultFileSystemCodePage then
begin
fs:=ToSingleByteFileSystemEncodedFileName(s);
pdst:=PAnsiChar(fs);
dstchangeable:=true;
end
else
fs:=s;
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{ it's slightly faster to convert the rawbytestring here to unicodestring
than doing it in do_rename, because here we still know the length }
fs:=unicodestring(s);
pdst:=PUnicodeChar(fs);
dstchangeable:=true;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_Rename(PFileTextRecChar(@TextRec(t).Name),pdst,false,dstchangeable);
If InOutRes=0 then
{$if defined(FPC_ANSI_TEXTTextRec) and not defined(FPCRTL_FILESYSTEM_SINGLE_BYTE_API)}
TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(fs)
{$else FPC_ANSI_TEXTTextRec and not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
TextRec(t).Name:=fs
{$endif FPC_ANSI_TEXTTextRec and not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
Procedure Rename(var t : Text;const s : ShortString);[IOCheck];
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Begin
Rename(t,AnsiString(s));
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
p : array[0..255] Of Char;
Begin
If InOutRes <> 0 then
exit;
Move(s[1],p,Length(s));
p[Length(s)]:=#0;
Rename(t,Pchar(@p));
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var t : Text;c : char);[IOCheck];
var
p : array[0..1] Of Char;
Procedure Rename(var t:Text;const p:PAnsiChar);
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Begin
Rename(t,AnsiString(p));
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
len: SizeInt
Begin
If InOutRes<>0 then
exit;
If TextRec(t).mode=fmClosed Then
Begin
Do_Rename(PFileTextRecChar(@TextRec(t).Name),p,false);
{ check error code of do_rename }
If InOutRes=0 then
begin
len:=min(StrLen(p),high(TextRec(t).Name));
Move(p^,TextRec(t).Name,len);
TextRec(t).Name[len]:=#0;
end;
End;
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var t : Text;const c : AnsiChar);[IOCheck];
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Begin
Rename(t,AnsiString(c));
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
p : array[0..1] Of AnsiChar;
Begin
If InOutRes <> 0 then
exit;
p[0]:=c;
p[1]:=#0;
Rename(t,Pchar(@p));
Rename(t,PAnsiChar(@p));
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Function Eof(Var t: Text): Boolean;[IOCheck];
Begin

4
rtl/inc/textrec.inc
View File

@ -29,7 +29,7 @@ const
{$endif CPUAVR}
type
TLineEndStr = string [3];
TextBuf = array[0..TextRecBufSize-1] of char;
TextBuf = array[0..TextRecBufSize-1] of ansichar;
{ using packed makes the compiler to generate ugly code on some CPUs, further
using packed causes the compiler to handle arrays of text wrongly, see see tw0754 e.g. on arm }
TextRec = {$ifdef VER2_6} packed {$endif} Record
@ -45,7 +45,7 @@ type
flushfunc,
closefunc : codepointer;
UserData : array[1..32] of byte;
name : array[0..textrecnamelength-1] of char;
name : array[0..textrecnamelength-1] of TFileTextRecChar;
LineEnd : TLineEndStr;
buffer : textbuf;
{$ifdef FPC_HAS_CPSTRING}

52
rtl/inc/typefile.inc
View File

@ -15,48 +15,56 @@
subroutines for typed file handling
****************************************************************************}
Procedure Assign(out f:TypedFile;const Name:string);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out f:TypedFile;const Name: UnicodeString);
{
Assign Name to file f so it can be used with the file routines
}
Begin
FillChar(f,SizeOF(FileRec),0);
FileRec(f).Handle:=UnusedHandle;
FileRec(f).mode:=fmClosed;
Move(Name[1],FileRec(f).Name,Length(Name));
Assign(UnTypedFile(f),Name);
End;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:TypedFile;const Name: RawByteString);
{
Assign Name to file f so it can be used with the file routines
}
Begin
Assign(UnTypedFile(f),Name);
End;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:TypedFile;const Name: ShortString);
{
Assign Name to file f so it can be used with the file routines
}
Begin
Assign(UnTypedFile(f),Name);
End;
Procedure Assign(out f:TypedFile;p:pchar);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,StrPas(p));
Procedure Assign(out f:TypedFile;const p:PAnsiChar);
Begin
Assign(UnTypedFile(f),p);
end;
Procedure Assign(out f:TypedFile;c:char);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,string(c));
Procedure Assign(out f:TypedFile;const c:AnsiChar);
Begin
Assign(UnTypedFile(f),c);
end;
Procedure fpc_reset_typed(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias:'FPC_RESET_TYPED']; compilerproc;
Begin
If InOutRes <> 0 then
exit;
Reset(UnTypedFile(f),Size);
End;
Procedure fpc_rewrite_typed(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias:'FPC_REWRITE_TYPED']; compilerproc;
Begin
If InOutRes <> 0 then
exit;
Rewrite(UnTypedFile(f),Size);
End;

12
rtl/macos/dos.pp
View File

@ -803,7 +803,11 @@ End;
paramBlock: CInfoPBRec;
begin
DosError := PathArgToFSSpec(StrPas(filerec(f).name), spec);
{$ifdef FPC_ANSI_TEXTFILEREC}
DosError := PathArgToFSSpec(filerec(f).name, spec);
{$else}
DosError := PathArgToFSSpec(ToSingleByteFileSystemEncodedFileName(filerec(f).name), spec);
{$endif}
if (DosError = 0) or (DosError = 2) then
begin
DosError := DoFindOne(spec, paramBlock);
@ -822,7 +826,11 @@ End;
macfiletime: UInt32;
begin
DosError := PathArgToFSSpec(StrPas(filerec(f).name), spec);
{$ifdef FPC_ANSI_TEXTFILEREC}
DosError := PathArgToFSSpec(filerec(f).name, spec);
{$else}
DosError := PathArgToFSSpec(ToSingleByteFileSystemEncodedFileName(filerec(f).name), spec);
{$endif}
if (DosError = 0) or (DosError = 2) then
begin
DosError := DoFindOne(spec, paramBlock);

6
rtl/macos/sysfile.inc
View File

@ -40,7 +40,7 @@ begin
{$endif}
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
var
spec: FSSpec;
@ -63,7 +63,7 @@ begin
InOutRes:=res;
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
var
s1,s2: AnsiString;
begin
@ -196,7 +196,7 @@ begin
{$endif}
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.

32
rtl/morphos/dos.pp
View File

@ -725,7 +725,11 @@ var
begin
DosError:=0;
FTime := 0;
Str := StrPas(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
Str := strpas(filerec(f).Name);
{$else}
Str := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
DoDirSeparators(Str);
FLock := dosLock(Str, SHARED_LOCK);
IF FLock <> 0 then begin
@ -756,7 +760,11 @@ end;
FLock: longint;
Begin
new(DateStamp);
Str := StrPas(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
Str := strpas(filerec(f).Name);
{$else}
Str := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
DoDirSeparators(str);
{ Check first of all, if file exists }
FLock := dosLock(Str, SHARED_LOCK);
@ -788,7 +796,11 @@ begin
DosError:=0;
flags:=0;
New(info);
Str := StrPas(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
Str := strpas(filerec(f).Name);
{$else}
Str := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
{$endif}
DoDirSeparators(str);
{ open with shared lock to check if file exists }
MyLock:=dosLock(Str,SHARED_LOCK);
@ -825,7 +837,17 @@ procedure setfattr(var f; attr : word);
var
flags: longint;
tmpLock : longint;
{$ifndef FPC_ANSI_TEXTFILEREC}
r : rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
p : pchar;
begin
{$ifdef FPC_ANSI_TEXTFILEREC}
p := @filerec(f).Name;
{$else}
r := ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
p := pchar(r);
{$endif}
DosError:=0;
flags:=FIBF_WRITE;
@ -836,10 +858,10 @@ begin
{ converts the path (KB) }
{ create a shared lock on the file }
tmpLock:=Lock(filerec(f).name,SHARED_LOCK);
tmpLock:=Lock(p,SHARED_LOCK);
if tmpLock <> 0 then begin
Unlock(tmpLock);
if not SetProtection(filerec(f).name,flags) then DosError:=5;
if not SetProtection(p,flags) then DosError:=5;
end else
DosError:=3;
end;

6
rtl/morphos/sysfile.inc
View File

@ -171,7 +171,7 @@ begin
end;
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
var
tmpStr: array[0..255] of Char;
begin
@ -181,7 +181,7 @@ begin
dosError2InOut(IoErr);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
{ quite stack-effective code, huh? :) damn path conversions... (KB) }
var
tmpStr1: array[0..255] of Char;
@ -311,7 +311,7 @@ begin
end;
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.

30
rtl/msdos/dos.pp
View File

@ -902,9 +902,20 @@ end;
procedure getfattr(var f;var attr : word);
var
path: pchar;
{$ifndef FPC_ANSI_TEXTFILEREC}
r: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
begin
dosregs.dx:=Ofs(filerec(f).name);
dosregs.ds:=Seg(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
path:=@filerec(f).Name;
{$else}
r:=ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
path:=pchar(r);
{$endif}
dosregs.dx:=Ofs(path^);
dosregs.ds:=Seg(path^);
if LFNSupport then
begin
dosregs.ax:=$7143;
@ -919,6 +930,11 @@ end;
procedure setfattr(var f;attr : word);
var
path: pchar;
{$ifndef FPC_ANSI_TEXTFILEREC}
r: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
begin
{ Fail for setting VolumeId. }
if ((attr and VolumeID)<>0) then
@ -926,8 +942,14 @@ begin
doserror:=5;
exit;
end;
dosregs.dx:=Ofs(filerec(f).name);
dosregs.ds:=Seg(filerec(f).name);
{$ifdef FPC_ANSI_TEXTFILEREC}
path:=@filerec(f).Name;
{$else}
r:=ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
path:=pchar(r);
{$endif}
dosregs.dx:=Ofs(path);
dosregs.ds:=Seg(path);
if LFNSupport then
begin
dosregs.ax:=$7143;

31
rtl/msdos/sysfile.inc
View File

@ -54,11 +54,13 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
var
regs : Registers;
oldp : pchar;
begin
DoDirSeparators(p);
oldp:=p;
DoDirSeparators(p,pchangeable);
regs.DX:=Ofs(p^);
regs.DS:=Seg(p^);
if LFNSupport then
@ -70,15 +72,20 @@ begin
MsDos(regs);
if (regs.Flags and fCarry) <> 0 then
GetInOutRes(regs.AX);
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
var
regs : Registers;
oldp1, oldp2 : pchar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
regs.DS:=Seg(p1^);
regs.DX:=Ofs(p1^);
regs.ES:=Seg(p2^);
@ -91,6 +98,10 @@ begin
MsDos(regs);
if (regs.Flags and fCarry) <> 0 then
GetInOutRes(regs.AX);
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
@ -229,7 +240,7 @@ begin
Increase_file_handle_count:=true;
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
@ -240,8 +251,8 @@ procedure do_open(var f;p:pchar;flags:longint);
var
regs : Registers;
action : longint;
oldp : pchar;
begin
DoDirSeparators(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
@ -283,6 +294,8 @@ begin
end;
exit;
end;
oldp:=p;
DoDirSeparators(p,pchangeable);
{$ifndef RTLLITE}
if LFNSupport then
begin
@ -332,6 +345,8 @@ begin
if (regs.Flags and fCarry) <> 0 then
begin
GetInOutRes(regs.AX);
if oldp<>p then
freemem(p);
exit;
end
else
@ -366,6 +381,8 @@ begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
if oldp<>p then
freemem(p);
end;

37
rtl/nativent/sysfile.inc
View File

@ -34,7 +34,7 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pwidechar; pchangeable: boolean);
var
ntstr: TNtUnicodeString;
objattr: TObjectAttributes;
@ -42,11 +42,13 @@ var
h: THandle;
disp: TFileDispositionInformation;
res: LongInt;
oldp: pwidechar;
begin
InoutRes := 4;
DoDirSeparators(p);
oldp:=p;
DoDirSeparators(p,pchangeable);
SysPCharToNtStr(ntstr, p, 0);
SysPWideCharToNtStr(ntstr, p, 0);
SysInitializeObjectAttributes(objattr, @ntstr, 0, 0, Nil);
res := NtCreateFile(@h, NT_DELETE or NT_SYNCHRONIZE, @objattr, @iostatus, Nil,
@ -71,10 +73,12 @@ begin
SysFreeNtStr(ntstr);
Errno2InoutRes;
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pwidechar; p1changeable, p2changeable: boolean);
var
h: THandle;
objattr: TObjectAttributes;
@ -82,12 +86,14 @@ var
dest, src: TNtUnicodeString;
renameinfo: PFileRenameInformation;
res: LongInt;
oldp1, oldp2 : pwidechar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
oldp1:=p1;
oldp2:=p2;
{ check whether the destination exists first }
SysPCharToNtStr(dest, p2, 0);
DoDirSeparators(p2,p2changeable);
SysPWideCharToNtStr(dest, p2, 0);
SysInitializeObjectAttributes(objattr, @dest, 0, 0, Nil);
res := NtCreateFile(@h, 0, @objattr, @iostatus, Nil, 0,
@ -99,7 +105,8 @@ begin
errno := 5;
Errno2InoutRes;
end else begin
SysPCharToNtStr(src, p1, 0);
DoDirSeparators(p1,p1changeable);
SysPWideCharToNtStr(src, p1, 0);
SysInitializeObjectAttributes(objattr, @src, 0, 0, Nil);
res := NtCreateFile(@h, GENERIC_ALL or NT_SYNCHRONIZE or FILE_READ_ATTRIBUTES,
@ -138,6 +145,10 @@ begin
end;
SysFreeNtStr(dest);
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
@ -292,7 +303,7 @@ begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pwidechar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
@ -306,8 +317,8 @@ var
iostatus: TIoStatusBlock;
ntstr: TNtUnicodeString;
res: LongInt;
oldp : pwidechar;
begin
DoDirSeparators(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
@ -378,7 +389,9 @@ begin
exit;
end;
SysPCharToNtStr(ntstr, p, 0);
oldp:=p;
DoDirSeparators(p,pchangeable);
SysPWideCharToNtStr(ntstr, p, 0);
SysInitializeObjectAttributes(objattr, @ntstr, OBJ_INHERIT, 0, Nil);
@ -399,4 +412,6 @@ begin
errno := res;
Errno2InoutRes;
end;
if oldp<>p then
freemem(p);
end;

13
rtl/nativent/sysos.inc
View File

@ -372,6 +372,19 @@ begin
aNtStr.Buffer[i] := aText[i];
end;
procedure SysPWideCharToNtStr(var aNtStr: TNtUnicodeString; aText: PWideChar;
aLen: LongWord);
var
i: Integer;
begin
if (aLen = 0) and (aText <> Nil) and (aText^ <> #0) then
aLen := Length(aText);
aNtStr.Length := aLen * SizeOf(WideChar);
aNtStr.MaximumLength := aNtStr.Length;
aNtStr.Buffer := GetMem(aNtStr.Length);
Move(aText[0],aNtStr.Buffer[0],aLen);
end;
procedure SysUnicodeStringToNtStr(var aNtStr: TNtUnicodeString; const s: UnicodeString);
var
i: Integer;

6
rtl/nds/sysfile.inc
View File

@ -88,7 +88,7 @@ begin
InOutRes := 0;
end;
procedure do_erase(p: pchar);
procedure do_erase(p: pchar; pchangeable: boolean);
var
res: longint;
begin
@ -100,7 +100,7 @@ begin
InOutRes := 0;
end;
procedure do_rename(p1, p2: pchar);
procedure do_rename(p1, p2: pchar; p1changeable, p2changeable: boolean);
var
res: longint;
begin
@ -209,7 +209,7 @@ begin
InOutRes := 0;
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.

6
rtl/netware/sysfile.inc
View File

@ -80,7 +80,7 @@ begin
InOutRes := 0;
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
VAR res : LONGINT;
begin
res := _unlink (p);
@ -90,7 +90,7 @@ begin
InOutRes := 0;
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
VAR res : LONGINT;
begin
res := _rename (p1,p2);
@ -189,7 +189,7 @@ begin
end;
// mostly stolen from syslinux
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.

27
rtl/netwlibc/dos.pp
View File

@ -553,10 +553,21 @@ end;
procedure getfattr(var f;var attr : word);
VAR StatBuf : TStat;
var
StatBuf : TStat;
{$ifndef FPC_ANSI_TEXTFILEREC}
r: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
p: pchar;
begin
doserror := 0;
if Fpstat (@textrec(f).name, StatBuf) = 0 then
{$ifdef FPC_ANSI_TEXTFILEREC}
p := @filerec(f).name;
{$else FPC_ANSI_TEXTFILEREC}
r := ToSingleByteFileSystemEncodedFileName(filerec(f).name);
p := pchar(r);
{$endif FPC_ANSI_TEXTFILEREC}
if Fpstat (p, StatBuf) = 0 then
attr := nwattr2dosattr (StatBuf.st_mode)
else
begin
@ -570,8 +581,18 @@ procedure setfattr(var f;attr : word);
var
StatBuf : TStat;
newMode : longint;
{$ifndef FPC_ANSI_TEXTFILEREC}
r: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
p: pchar;
begin
if Fpstat (@textrec(f).name,StatBuf) = 0 then
{$ifdef FPC_ANSI_TEXTFILEREC}
p := @filerec(f).name;
{$else FPC_ANSI_TEXTFILEREC}
r := ToSingleByteFileSystemEncodedFileName(filerec(f).name);
p := pchar(r);
{$endif FPC_ANSI_TEXTFILEREC}
if Fpstat (p,StatBuf) = 0 then
begin
newmode := StatBuf.st_mode and ($FFFF0000 - M_A_RDONLY-M_A_HIDDEN-M_A_SYSTEM-M_A_ARCH); {only this can be set by dos unit}
newmode := newmode or M_A_BITS_SIGNIFICANT; {set netware attributes}

6
rtl/netwlibc/sysfile.inc
View File

@ -84,7 +84,7 @@ begin
InOutRes := 0;
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
VAR res : LONGINT;
begin
res := unlink (p);
@ -94,7 +94,7 @@ begin
InOutRes := 0;
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
VAR res : LONGINT;
begin
res := rename (p1,p2);
@ -221,7 +221,7 @@ end;
{$ifdef IOpossix}
// mostly stolen from syslinux
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.

30
rtl/os2/dos.pas
View File

@ -592,10 +592,19 @@ procedure GetFAttr (var F; var Attr: word);
var
PathInfo: TFileStatus3;
RC: cardinal;
{$ifndef FPC_ANSI_TEXTFILEREC}
R: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
P: pchar;
begin
Attr := 0;
RC := DosQueryPathInfo (@FileRec (F).Name, ilStandard,
@PathInfo, SizeOf (PathInfo));
{$ifdef FPC_ANSI_TEXTFILEREC}
P := @FileRec (F).Name;
{$else FPC_ANSI_TEXTFILEREC}
R := ToSingleByteFileSystemEncodedFileName (FileRec (F).Name);
P := PChar (R);
{$endif FPC_ANSI_TEXTFILEREC}
RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo));
DosError := integer (RC);
if RC = 0 then
Attr := PathInfo.AttrFile;
@ -606,14 +615,23 @@ procedure SetFAttr (var F; Attr: word);
var
PathInfo: TFileStatus3;
RC: cardinal;
{$ifndef FPC_ANSI_TEXTFILEREC}
R: rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
P: pchar;
begin
RC := DosQueryPathInfo (@FileRec (F).Name, ilStandard,
@PathInfo, SizeOf (PathInfo));
{$ifdef FPC_ANSI_TEXTFILEREC}
P := @FileRec (F).Name;
{$else FPC_ANSI_TEXTFILEREC}
R := ToSingleByteFileSystemEncodedFileName (FileRec (F).Name);
P := PChar (R);
{$endif FPC_ANSI_TEXTFILEREC}
RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo));
if RC = 0 then
begin
PathInfo.AttrFile := Attr;
RC := DosSetPathInfo (@FileRec (F).Name, ilStandard, @PathInfo,
SizeOf (PathInfo), doWriteThru);
RC := DosSetPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo),
doWriteThru);
end;
DosError := integer (RC);
end;

34
rtl/os2/sysfile.inc
View File

@ -31,17 +31,30 @@ begin
{$endif}
end;
procedure do_erase(p:Pchar);
procedure do_erase(p:Pchar; pchangeable: boolean);
var
oldp: pchar;
begin
DoDirSeparators(p);
oldp:=p;
DoDirSeparators(p,pchangeable);
inoutres:=DosDelete(p);
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2:Pchar);
procedure do_rename(p1,p2:Pchar; p1changeable, p2changeable: boolean);
var
oldp1, oldp2 : pchar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
inoutres:=DosMove(p1, p2);
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
function do_read(h:thandle;addr:pointer;len:longint):longint;
@ -141,7 +154,7 @@ begin
Increase_File_Handle_Count := false;
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
@ -152,9 +165,8 @@ procedure do_open(var f;p:pchar;flags:longint);
}
var
Action, Attrib, OpenFlags, FM: Cardinal;
oldp : pchar;
begin
// convert unix slashes to normal slashes
DoDirSeparators(p);
// close first if opened
if ((flags and $10000)=0) then
@ -211,6 +223,9 @@ begin
exit;
end;
oldp:=p;
// convert unix slashes to normal slashes
DoDirSeparators(p,pchangeable);
Attrib:=32 {faArchive};
InOutRes:=Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
@ -235,6 +250,9 @@ begin
end;
if oldp<>p then
freemem(p);
{$ifdef IODEBUG}
writeln('do_open,', filerec(f).handle, ',', filerec(f).name, ',', filerec(f).mode, ', InOutRes=', InOutRes);
{$endif}

6
rtl/symbian/sysfile.inc
View File

@ -31,13 +31,13 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
begin
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
begin
end;
@ -85,7 +85,7 @@ begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
begin
end;

37
rtl/unix/dos.pp
View File

@ -780,9 +780,24 @@ Procedure GetFAttr(var f; var attr : word);
Var
info : baseunix.stat;
LinAttr : longint;
p : pchar;
{$ifndef FPC_ANSI_TEXTFILEREC}
r : RawByteString;
{$endif not FPC_ANSI_TEXTFILEREC}
Begin
DosError:=0;
if FPStat(@textrec(f).name[0],info)<0 then
{$ifdef FPC_ANSI_TEXTFILEREC}
{ encoding is already correct }
p:=@textrec(f).name;
{$else}
r:=ToSingleByteFileSystemEncodedFileName(textrec(f).name);
p:=pchar(r);
{$endif}
{ use the pchar rather than the rawbytestring version so that we don't check
a second time whether the string needs to be converted to the right code
page
}
if FPStat(p,info)<0 then
begin
Attr:=0;
DosError:=3;
@ -794,7 +809,7 @@ Begin
Attr:=$10
else
Attr:=$0;
if fpAccess(@textrec(f).name[0],W_OK)<0 then
if fpAccess(p,W_OK)<0 then
Attr:=Attr or $1;
if filerec(f).name[0]='.' then
Attr:=Attr or $2;
@ -822,7 +837,10 @@ Procedure setftime(var f; time : longint);
Var
utim: utimbuf;
DT: DateTime;
p : pchar;
{$ifndef FPC_ANSI_TEXTFILEREC}
r : Rawbytestring;
{$endif not FPC_ANSI_TEXTFILEREC}
Begin
doserror:=0;
with utim do
@ -831,7 +849,18 @@ Begin
UnPackTime(Time,DT);
modtime:=DTToUnixDate(DT);
end;
if fputime(@filerec(f).name[0],@utim)<0 then
{$ifdef FPC_ANSI_TEXTFILEREC}
{ encoding is already correct }
p:=@textrec(f).name;
{$else}
r:=ToSingleByteFileSystemEncodedFileName(textrec(f).name);
p:=pchar(r);
{$endif}
{ use the pchar rather than the rawbytestring version so that we don't check
a second time whether the string needs to be converted to the right code
page
}
if fputime(p,@utim)<0 then
begin
Time:=0;
doserror:=3;

36
rtl/unix/printer.pp
View File

@ -74,12 +74,11 @@ Const
Var
Lpr : String[255]; { Contains path to lpr binary, including null char }
Procedure PrintAndDelete (f:string);
Procedure PrintAndDelete (const f: RawByteString);
var
i: pid_t;
p,pp : ppchar;
begin
f:=f+#0;
if lpr='' then
exit;
i:=fpFork;
@ -114,8 +113,17 @@ end;
Procedure OpenLstPipe ( Var F : Text);
var
r: rawbytestring;
begin
POpen (f,StrPas(textrec(f).name),'W');
{$ifdef FPC_ANSI_TEXTFILEREC}
{ encoding is already correct }
r:=textrec(f).name;
SetCodePage(r,DefaultFileSystemCodePage,false);
{$else}
r:=ToSingleByteFileSystemEncodedFileName(textrec(f).name);
{$endif}
POpen (f,r,'W');
end;
@ -123,6 +131,7 @@ end;
Procedure OpenLstFile ( Var F : Text);
var
i : cint;
r: rawbytestring;
begin
{$IFDEF PRINTERDEBUG}
writeln ('Printer : In OpenLstFile');
@ -130,8 +139,15 @@ begin
If textrec(f).mode <> fmoutput then
exit;
textrec(f).userdata[15]:=0; { set Zero length flag }
{$ifdef FPC_ANSI_TEXTFILEREC}
{ encoding is already correct }
r:=textrec(f).name;
SetCodePage(r,DefaultFileSystemCodePage,false);
{$else}
r:=ToSingleByteFileSystemEncodedFileName(textrec(f).name);
{$endif}
repeat
i:=fpOpen(StrPas(textrec(f).name),(Open_WrOnly or Open_Creat), 438);
i:=fpOpen(pansichar(r),(Open_WrOnly or Open_Creat), 438);
until (i<>-1) or (fpgeterrno<>ESysEINTR);
if i<0 then
textrec(f).mode:=fmclosed
@ -154,12 +170,20 @@ begin
{ In case length is zero, don't print : lpr would give an error }
if (textrec(f).userdata[15]=0) and (textrec(f).userdata[16]=P_TOF) then
begin
fpUnlink(StrPas(textrec(f).name));
{$IFDEF FPC_ANSI_TEXTFILEREC}
fpUnlink(pansichar(@textrec(f).name));
{$ELSE}
fpUnlink(ToSingleByteFileSystemEncodedFileName(textrec(f).name));
{$ENDIF}
exit
end;
{ Non empty : needs printing ? }
if (textrec(f).userdata[16]=P_TOF) then
PrintAndDelete (strpas(textrec(f).name));
{$IFDEF FPC_ANSI_TEXTFILEREC}
PrintAndDelete (textrec(f).name);
{$ELSE}
PrintAndDelete (ToSingleByteFileSystemEncodedFileName(textrec(f).name));
{$ENDIF}
textrec(f).mode:=fmclosed
end;

6
rtl/unix/sysfile.inc
View File

@ -22,7 +22,7 @@ Begin
until (res<>-1) or (geterrno<>ESysEINTR);
End;
Procedure Do_Erase(p:pchar);
Procedure Do_Erase(p: pchar; pchangeable: boolean);
var
fileinfo : stat;
Begin
@ -58,7 +58,7 @@ end;
Procedure Do_Rename(p1,p2:pchar);
Procedure Do_Rename(p1,p2:pchar; p1changeable, p2changeable: boolean);
Begin
If Fprename(p1,p2)<0 Then
Errno2Inoutres
@ -145,7 +145,7 @@ Begin
InOutRes:=0;
End;
Procedure Do_Open(var f;p:pchar;flags:longint);
Procedure Do_Open(var f; p: pchar; flags: longint; pchangeable: boolean);
{
FileRec and textrec have both Handle and mode as the first items so
they could use the same routine for opening/creating.

31
rtl/watcom/sysfile.inc
View File

@ -37,11 +37,13 @@ begin
GetInOutRes(lo(regs.realeax));
end;
procedure do_erase(p : pchar);
procedure do_erase(p : pchar; pchangeable: boolean);
var
regs : trealregs;
oldp : pchar;
begin
DoDirSeparators(p);
oldp:=p;
DoDirSeparators(p,pchangeable);
syscopytodos(longint(p),strlen(p)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
@ -54,14 +56,19 @@ begin
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
var
regs : trealregs;
oldp1, oldp2 : pchar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
if strlen(p1)+strlen(p2)+3>tb_size then
HandleError(217);
sysseg_move(get_ds,sizeuint(p2),dos_selector,tb,strlen(p2)+1);
@ -78,6 +85,10 @@ begin
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
function do_write(h:longint;addr:pointer;len : longint) : longint;
@ -260,7 +271,7 @@ begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
@ -272,8 +283,8 @@ var
regs : trealregs;
action : longint;
Avoid6c00 : boolean;
oldp : pchar;
begin
DoDirSeparators(p);
{ check if Extended Open/Create API is safe to use }
Avoid6c00 := lo(dos_version) < 7;
{ close first if opened }
@ -317,6 +328,8 @@ begin
end;
exit;
end;
oldp:=p;
DoDirSeparators(p,pchangeable);
{ real dos call }
syscopytodos(longint(p),strlen(p)+1);
{$ifndef RTLLITE}
@ -379,6 +392,8 @@ begin
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
if oldp<>p then
freemem(p);
exit;
end
else
@ -413,6 +428,8 @@ begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
if oldp<>p then
freemem(p);
end;
function do_isdevice(handle:THandle):boolean;

6
rtl/wii/sysfile.inc
View File

@ -29,14 +29,14 @@ begin
//_fclose (_PFILE(pointer(handle))^);
end;
procedure do_erase(p: pchar);
procedure do_erase(p: pchar; pchangeable: boolean);
begin
if FileIODevice.FileIO.DoErase <> nil then
FileIODevice.FileIO.DoErase(p);
// _unlink(p);
end;
procedure do_rename(p1, p2: pchar);
procedure do_rename(p1, p2: pchar; p1changeable, p2changeable: boolean);
begin
// _rename(p1, p2);
if FileIODevice.FileIO.DoRename <> nil then
@ -93,7 +93,7 @@ begin
FileIODevice.FileIO.DoTruncate(handle, pos);
end;
procedure do_open(var f; p: pchar; flags: longint);
procedure do_open(var f; p: pchar; flags: longint; pchangeable: boolean);
begin
(*
{ close first if opened }

16
rtl/win/dos.pp
View File

@ -612,9 +612,11 @@ end;
procedure getfattr(var f;var attr : word);
var
l : longint;
s : RawByteString;
begin
doserror:=0;
l:=GetFileAttributes(filerec(f).name);
s:=ToSingleByteFileSystemEncodedFileName(filerec(f).name);
l:=GetFileAttributes(pchar(s));
if l=longint($ffffffff) then
begin
doserror:=getlasterror;
@ -626,15 +628,19 @@ end;
procedure setfattr(var f;attr : word);
var s : RawByteString;
begin
{ Fail for setting VolumeId }
if (attr and VolumeID)<>0 then
doserror:=5
else
if SetFileAttributes(filerec(f).name,attr) then
doserror:=0
else
doserror:=getlasterror;
begin
s:=ToSingleByteFileSystemEncodedFileName(filerec(f).name);
if SetFileAttributes(pchar(s),attr) then
doserror:=0
else
doserror:=getlasterror;
end;
end;
{ change to short filename if successful win32 call PM }

41
rtl/win/sysfile.inc
View File

@ -32,31 +32,44 @@ begin
end;
procedure do_erase(p : pchar);
procedure do_erase(p: pwidechar; pchangeable: boolean);
var
oldp: pwidechar;
begin
DoDirSeparators(p);
if DeleteFile(p)=0 then
oldp:=p;
DoDirSeparators(p,pchangeable);
if DeleteFileW(p)=0 then
Begin
errno:=GetLastError;
if errno=5 then
begin
if ((GetFileAttributes(p) and FILE_ATTRIBUTE_DIRECTORY)=FILE_ATTRIBUTE_DIRECTORY) then
if ((GetFileAttributesW(p) and FILE_ATTRIBUTE_DIRECTORY)=FILE_ATTRIBUTE_DIRECTORY) then
errno:=2;
end;
Errno2InoutRes;
end;
if p<>oldp then
freemem(p);
end;
procedure do_rename(p1,p2 : pchar);
procedure do_rename(p1,p2: pwidechar; p1changeable, p2changeable: boolean);
var
oldp1,oldp2: pwidechar;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
if MoveFile(p1,p2)=0 then
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
if MoveFileW(p1,p2)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
freemem(p2);
end;
@ -191,7 +204,7 @@ begin
end;
procedure do_open(var f;p:pchar;flags:longint);
procedure do_open(var f; p: pwidechar; flags: longint; pchangeable: boolean);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
@ -207,8 +220,8 @@ Var
shflags,
oflags,cd : longint;
security : TSecurityAttributes;
oldp : pwidechar;
begin
DoDirSeparators(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
@ -223,6 +236,8 @@ begin
end;
end;
end;
oldp:=p;
DoDirSeparators(p,pchangeable);
{ reset file handle }
filerec(f).handle:=UnusedHandle;
{ convert filesharing }
@ -280,12 +295,14 @@ begin
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
{ no dirseparators can have been replaced in the empty string -> no need
to check whether we have to free p }
exit;
end;
security.nLength := Sizeof(TSecurityAttributes);
security.bInheritHandle:=true;
security.lpSecurityDescriptor:=nil;
filerec(f).handle:=CreateFile(p,oflags,shflags,@security,cd,FILE_ATTRIBUTE_NORMAL,0);
filerec(f).handle:=CreateFileW(p,oflags,shflags,@security,cd,FILE_ATTRIBUTE_NORMAL,0);
{ append mode }
if ((flags and $100)<>0) and
@ -303,4 +320,6 @@ begin
errno:=GetLastError;
Errno2InoutRes;
end;
if oldp<>p then
freemem(p);
end;

25
rtl/win/sysos.inc
View File

@ -280,29 +280,18 @@ threadvar
stdcall;external KernelDLL name 'GetFileType';
function GetProcAddress(hModule:THandle; lpProcName:pchar):pointer; stdcall; external KernelDLL name 'GetProcAddress';
{$ifdef FPC_UNICODE_RTL}
function GetFileAttributes(p : punicodechar) : dword;
stdcall;external KernelDLL name 'GetFileAttributesW';
function DeleteFile(p : punicodechar) : longint;
{ File }
function DeleteFileW(p : punicodechar) : longint;
stdcall;external KernelDLL name 'DeleteFileW';
function MoveFile(old,_new : punicodechar) : longint;
function MoveFileW(old,_new : punicodechar) : longint;
stdcall;external KernelDLL name 'MoveFileW';
function CreateFile(lpFileName:punicodechar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
function CreateFileW(lpFileName:punicodechar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):THandle;
stdcall;external KernelDLL name 'CreateFileW';
{$else}
function GetFileAttributes(p : pchar) : dword;
stdcall;external KernelDLL name 'GetFileAttributesA';
function DeleteFile(p : pchar) : longint;
stdcall;external KernelDLL name 'DeleteFileA';
function MoveFile(old,_new : pchar) : longint;
stdcall;external KernelDLL name 'MoveFileA';
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):THandle;
stdcall;external KernelDLL name 'CreateFileA';
{$endif}
function GetFileAttributesW(p : punicodechar) : dword;
stdcall;external KernelDLL name 'GetFileAttributesW';
{ Directory }
function CreateDirectoryW(name : pointer;sec : pointer) : longbool;
stdcall;external KernelDLL name 'CreateDirectoryW';

12
rtl/wince/dos.pp
View File

@ -484,7 +484,9 @@ end;
procedure getfattr(var f;var attr : word);
var
l : cardinal;
buf: array[0..MaxPathLen] of WideChar;
{$ifdef FPC_ANSI_TEXTFILEREC}
u: unicodestring;
{$endif FPC_ANSI_TEXTFILEREC}
begin
if filerec(f).name[0] = #0 then
begin
@ -494,8 +496,12 @@ begin
else
begin
doserror:=0;
AnsiToWideBuf(@filerec(f).name, -1, buf, SizeOf(buf));
l:=GetFileAttributes(buf);
{$ifdef FPC_ANSI_TEXTFILEREC}
widestringmanager.Ansi2UnicodeMoveProc(filerec(f).name,DefaultFileSystemCodePage,u,length(filerec(f).name));
l:=GetFileAttributes(pwidechar(u));
{$else}
l:=GetFileAttributes(filerec(f).name);
{$endif}
if l = $ffffffff then
begin
doserror:=Last2DosError(GetLastError);

60
rtl/wince/system.pp
View File

@ -87,12 +87,17 @@ function Win32GetCurrentThreadId:DWORD;
function TlsAlloc : DWord;
function TlsFree(dwTlsIndex : DWord) : LongBool;
function GetFileAttributes(p : pchar) : dword;
function DeleteFile(p : pchar) : longint;
function MoveFile(old,_new : pchar) : longint;
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
function GetFileAttributesW(p : pwidechar) : dword;
cdecl; external KernelDLL name 'GetFileAttributesW';
function DeleteFileW(p : pwidechar) : longint;
cdecl; external KernelDLL name 'DeleteFileW';
function MoveFileW(old,_new : pwidechar) : longint;
cdecl; external KernelDLL name 'MoveFileW';
function CreateFileW(lpFileName:pwidechar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
cdecl; external KernelDLL name 'CreateFileW';
{$ifdef CPUARM}
@ -416,53 +421,6 @@ end;
WinAPI wrappers implementation
*****************************************************************************}
function GetFileAttributesW(p : pwidechar) : dword;
cdecl; external KernelDLL name 'GetFileAttributesW';
function DeleteFileW(p : pwidechar) : longint;
cdecl; external KernelDLL name 'DeleteFileW';
function MoveFileW(old,_new : pwidechar) : longint;
cdecl; external KernelDLL name 'MoveFileW';
function CreateFileW(lpFileName:pwidechar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
cdecl; external KernelDLL name 'CreateFileW';
function GetFileAttributes(p : pchar) : dword;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(p, -1, buf, SizeOf(buf));
GetFileAttributes := GetFileAttributesW(buf);
end;
function DeleteFile(p : pchar) : longint;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(p, -1, buf, SizeOf(buf));
DeleteFile := DeleteFileW(buf);
end;
function MoveFile(old,_new : pchar) : longint;
var
buf_old, buf_new: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(old, -1, buf_old, SizeOf(buf_old));
AnsiToWideBuf(_new, -1, buf_new, SizeOf(buf_new));
MoveFile := MoveFileW(buf_old, buf_new);
end;
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(lpFileName, -1, buf, SizeOf(buf));
CreateFile := CreateFileW(buf, dwDesiredAccess, dwShareMode, lpSecurityAttributes,
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile);
end;
const
{$ifdef CPUARM}
UserKData = $FFFFC800;