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

* check whether file/text is assigned in erase/rename (mantis #25932)

Browse Source 
git-svn-id: trunk@27694 -
This commit is contained in:
Jonas Maebe 2014-04-30 18:31:22 +00:00
parent de1b8cf5d6
commit 8ac4a770a9
4 changed files with 174 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -12144,6 +12144,7 @@ tests/test/tutf82.pp svneol=native#text/plain
tests/test/tvarpropsetter1.pp svneol=native#text/plain
tests/test/tvarpropsetter2.pp svneol=native#text/plain
tests/test/tvarset1.pp svneol=native#text/plain
tests/test/tw25932.pp svneol=native#text/plain
tests/test/twarn1.pp svneol=native#text/pascal
tests/test/tweaklib1.pp svneol=native#text/plain
tests/test/tweaklib2.pp svneol=native#text/plain

54
rtl/inc/file.inc
View File

@ -430,10 +430,14 @@ End;
Procedure Erase(var f : File);[IOCheck];
Begin
If InOutRes <> 0 then
exit;
If FileRec(f).mode=fmClosed Then
Do_Erase(PFileTextRecChar(@FileRec(f).Name),false);
if InOutRes<>0 then
exit;
if FileRec(f).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
Do_Erase(PFileTextRecChar(@FileRec(f).Name),false);
End;
@ -443,9 +447,13 @@ var
fs: RawByteString;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Begin
If (InOutRes<>0) or
(FileRec(f).mode<>fmClosed) then
if InOutRes<>0 then
exit;
if FileRec(f).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
{$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 }
@ -476,9 +484,13 @@ var
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable: boolean;
Begin
If (InOutRes<>0) or
(FileRec(f).mode<>fmClosed) then
if InOutRes<>0 then
exit;
if FileRec(f).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable:=false;
pdst:=PAnsiChar(s);
@ -532,19 +544,21 @@ End;
var
len: SizeInt
Begin
If InOutRes<>0 then
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;
if FileRec(f).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
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;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}

54
rtl/inc/text.inc
View File

@ -255,10 +255,14 @@ End;
Procedure Erase(var t:Text);[IOCheck];
Begin
If InOutRes <> 0 then
exit;
If TextRec(t).mode=fmClosed Then
Do_Erase(PFileTextRecChar(@TextRec(t).Name),false);
if InOutRes<>0 then
exit;
if TextRec(t).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
Do_Erase(PFileTextRecChar(@TextRec(t).Name),false);
End;
@ -268,9 +272,13 @@ var
fs: RawByteString;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Begin
If (InOutRes<>0) or
(TextRec(t).mode<>fmClosed) then
if InOutRes<>0 then
exit;
if TextRec(t).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
{$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 }
@ -301,9 +309,13 @@ var
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable: boolean;
Begin
If (InOutRes<>0) or
(TextRec(t).mode<>fmClosed) then
if InOutRes<>0 then
exit;
if TextRec(t).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
dstchangeable:=false;
pdst:=PAnsiChar(s);
@ -356,19 +368,21 @@ End;
var
len: SizeInt
Begin
If InOutRes<>0 then
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;
if TextRec(f).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
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;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}

105
tests/test/tw25932.pp Normal file
View File

@ -0,0 +1,105 @@
{$mode delphi}
uses
sysutils;
procedure testfile;
var
f: file;
s: shortstring;
a: ansistring;
u: unicodestring;
begin
s:='a';
a:='b';
u:='c';
fillchar(f,sizeof(f),0);
try
erase(f);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
fillchar(f,sizeof(f),0);
try
rename(f,s);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
fillchar(f,sizeof(f),0);
try
rename(f,a);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
fillchar(f,sizeof(f),0);
try
rename(f,u);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
end;
procedure testtext;
var
f: text;
s: shortstring;
a: ansistring;
u: unicodestring;
begin
s:='a';
a:='b';
u:='c';
fillchar(f,sizeof(f),0);
try
erase(f);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
fillchar(f,sizeof(f),0);
try
rename(f,s);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
fillchar(f,sizeof(f),0);
try
rename(f,a);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
fillchar(f,sizeof(f),0);
try
rename(f,u);
except
on e: EInOutError do
if e.ErrorCode<>102 then
raise
end;
end;
begin
testfile;
end.