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

* Remove testsuite again

Browse Source 
git-svn-id: trunk@43431 -
This commit is contained in:
michael 2019-11-09 18:56:14 +00:00
parent 99ce957111
commit 8b89a5cc51
52 changed files with 0 additions and 14792 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
.gitattributes vendored
View File

@ -11649,57 +11649,6 @@ rtl/symbian/uiq.pas svneol=native#text/plain
rtl/symbian/uiqclasses.pas svneol=native#text/plain
rtl/symbian/uiqinc/qikapplication.inc svneol=native#text/plain
rtl/symbian/uiqinc/qikapplicationoo.inc svneol=native#text/plain
rtl/test/docompile.sh svneol=native#text/plain
rtl/test/punit.cfg svneol=native#text/plain
rtl/test/punit.pp svneol=native#text/plain
rtl/test/testpunit.pp svneol=native#text/plain
rtl/test/testpunit2.pp svneol=native#text/plain
rtl/test/testpunit3.pp svneol=native#text/plain
rtl/test/testrtl.lpi svneol=native#text/plain
rtl/test/testrtl.pp svneol=native#text/plain
rtl/test/tohelper.inc svneol=native#text/plain
rtl/test/unittest.cfg svneol=native#text/plain
rtl/test/utastrcmp.pp svneol=native#text/plain
rtl/test/utbytesof.pp svneol=native#text/plain
rtl/test/utclasses.pp svneol=native#text/plain
rtl/test/utdfexp.pp svneol=native#text/plain
rtl/test/utdirex.pp svneol=native#text/plain
rtl/test/utdos.pp svneol=native#text/plain
rtl/test/utencoding.pp svneol=native#text/plain
rtl/test/utencodingerr.pp svneol=native#text/plain
rtl/test/utenv.pp svneol=native#text/plain
rtl/test/utexec.pp svneol=native#text/plain
rtl/test/utexpfncase.pp svneol=native#text/plain
rtl/test/utextractquote.pp svneol=native#text/plain
rtl/test/utfattr.pp svneol=native#text/plain
rtl/test/utfexpand.pp svneol=native#text/plain
rtl/test/utffirst.pp svneol=native#text/plain
rtl/test/utfile.pp svneol=native#text/plain
rtl/test/utfile1.pp svneol=native#text/plain
rtl/test/utfile2.pp svneol=native#text/plain
rtl/test/utfilename.pp svneol=native#text/plain
rtl/test/utfloattostr.pp svneol=native#text/plain
rtl/test/utformat.pp svneol=native#text/plain
rtl/test/utfsearch.pp svneol=native#text/plain
rtl/test/utmath.pp svneol=native#text/plain
rtl/test/utrtl.pp svneol=native#text/plain
rtl/test/utrwsync.pp svneol=native#text/plain
rtl/test/utscanf.pp svneol=native#text/plain
rtl/test/utstrcmp.pp svneol=native#text/plain
rtl/test/utstrcopy.pp svneol=native#text/plain
rtl/test/utstringbuild.pp svneol=native#text/plain
rtl/test/utstringhelp.pp svneol=native#text/plain
rtl/test/utstrings1.pp svneol=native#text/plain
rtl/test/utstrtobool.pp svneol=native#text/plain
rtl/test/utstrtotime.pp svneol=native#text/plain
rtl/test/utsyshelpers.pp svneol=native#text/plain
rtl/test/utsysutils.pp svneol=native#text/plain
rtl/test/uttypinfo.pp svneol=native#text/plain
rtl/test/utunifile.pp svneol=native#text/plain
rtl/test/utuplow.pp svneol=native#text/plain
rtl/test/utustringbuild.pp svneol=native#text/plain
rtl/test/utverify.pp svneol=native#text/plain
rtl/test/utwstrcmp.pp svneol=native#text/plain
rtl/ucmaps/8859-1.txt svneol=native#text/plain
rtl/ucmaps/8859-10.txt svneol=native#text/plain
rtl/ucmaps/8859-11.txt svneol=native#text/plain

2
rtl/test/docompile.sh
View File

@ -1,2 +0,0 @@
#!/bin/sh
exec fpc @unittest.cfg testrtl.pp $*

1
rtl/test/punit.cfg
View File

@ -1 +0,0 @@
nosync=true

3120
rtl/test/punit.pp
View File

File diff suppressed because it is too large Load Diff

16
rtl/test/testpunit.pp
View File

@ -1,16 +0,0 @@
{$mode objfpc}
program testpunit;
uses punit;
Function DoTest : AnsiString;
begin
Result:='test failed';
end;
begin
RunTest(@DoTest);
end.

565
rtl/test/testpunit2.pp
View File

@ -1,565 +0,0 @@
{$mode objfpc}
program testpunit2;
uses punit;
Type
EError = Class(TObject);
Function DoTest1 : AnsiString;
Begin
Result:='';
Result:='Error in test';
end;
Function DoTest2 : AnsiString;
Begin
// Test OK if RequirePassed=False, but Unimplemented if RequirePassed=True !
// AssertPassed('');
Result:='';
end;
Function DoTest3 : AnsiString;
Begin
Result:='';
Fail('Must fail: Failed throug fail');
Result:='';// This is ignored
end;
Function DoTest4 : AnsiString;
Begin
Result:='';
FailExit('Must fail: Failed throug fail exception');
Result:='Nono';// This is not reached.
end;
Function DoTest5 : AnsiString;
Begin
Result:='';
Fail('Must fail: Failed throug fail');
Result:='Failed through default';// This is ignored
end;
Function DoTest6: AnsiString;
Begin
Result:='';
// Will be marked as passed.
AssertTrue('Some message',True);
Result:='';
end;
Function DoTest7: AnsiString;
Begin
Result:='';
// Will be marked as Failed.
if Not AssertTrue('Must fail: AssertTrue with false',False) then
exit;
end;
Function DoTest9: AnsiString;
Begin
Result:='';
// Will be marked as Failed.
if Not AssertEquals('Must fail: Strings equal','Expected result string','Actual result string') then
exit;
end;
Function DoTest10: AnsiString;
Var
O1,O2 : Integer;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Integers equal',O1,O2) then
exit;
end;
Function DoTest11: AnsiString;
Var
O1,O2 : Smallint;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Smallint equal',O1,O2) then
exit;
end;
Function DoTest12: AnsiString;
Var
O1,O2 : Longint;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Longint equal',O1,O2) then
exit;
end;
Function DoTest13: AnsiString;
Var
O1,O2 : Byte;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Bytes equal',O1,O2) then
exit;
end;
Function DoTest14: AnsiString;
Var
O1,O2 : Shortint;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Shortints equal',O1,O2) then
exit;
end;
Function DoTest15: AnsiString;
Var
O1,O2 : Cardinal;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Cardinals equal',O1,O2) then
exit;
end;
Function DoTest16: AnsiString;
Var
O1,O2 : Int64;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Int64s equal',O1,O2) then
exit;
end;
Function DoTest17: AnsiString;
Var
O1,O2 : QWord;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: QWords equal',O1,O2) then
exit;
end;
Function DoTest18: AnsiString;
Var
O1,O2 : Pointer;
Begin
Result:='';
O1:=Pointer(1);
O2:=Pointer(2);
// Will be marked as Failed.
if Not AssertEquals('Must fail: pointers equal',O1,O2) then
exit;
end;
Function DoTest19: AnsiString;
Var
O1,O2 : Word;
Begin
Result:='';
O1:=1;
O2:=2;
// Will be marked as Failed.
if Not AssertEquals('Must fail: Word equal',O1,O2) then
exit;
end;
Function DoTest20: AnsiString;
Begin
Result:='';
ExpectException('Must fail: Expect exception EError',EError);
end;
Function DoTest21: AnsiString;
Begin
Result:='';
ExpectException('Must fail: Expect exception EError',EError);
Raise EFail.Create('Expected');
end;
Function DoTest22: AnsiString;
Begin
Result:='';
ExpectException('Expect exception EError',EFail);
Raise EFail.Create('Expected');
end;
Function DoTest23: AnsiString;
Begin
Result:='';
AssertEquals('Must fail: Classes differ',EError,EFail);
end;
Function DoTest24: AnsiString;
Begin
Result:='';
AssertEquals('Must fail: Classes differ (expected is nil)',Nil,EFail);
end;
Function DoTest25: AnsiString;
Begin
Result:='';
AssertEquals('Must fail: Classes differ (actual is nil)',EFail,Nil);
end;
Function DoTest26: AnsiString;
Var
A,B : TObject;
Begin
Result:='';
A:=EFail.Create('');
B:=EError.Create();
try
AssertSame('Must fail: Instances differ',A,B);
finally
A.Free;
B.Free
end;
end;
Function DoTest27: AnsiString;
Var
A : TObject;
Begin
Result:='';
A:=EFail.Create('');
try
AssertSame('Must fail: Instances differ (actual nil)',A,Nil);
finally
A.Free;
end;
end;
Function DoTest28: AnsiString;
Var
A : TObject;
Begin
Result:='';
A:=EFail.Create('');
try
AssertSame('Must fail: Instances differ (expected nil)',Nil,A);
finally
A.Free;
end;
end;
Function DoTest29: AnsiString;
Var
A : TObject;
B : TObject;
Begin
Result:='';
A:=EFail.Create('');
try
B:=A;
AssertSame('Instances equal(expected nil)',B,A);
finally
A.Free;
end;
end;
Function DoTest30: AnsiString;
Var
A,B : Double;
Begin
Result:='';
A:=1.2;
B:=3.4;
AssertEquals('Must fail: Doubles not within delta',B,A);
end;
Function DoTest31: AnsiString;
Var
A,B : Double;
Begin
Result:='';
A:=1.2;
B:=1.2+(DefaultDoubleDelta/2);
AssertEquals('Doubles within delta',B,A);
end;
Function DoTest32: AnsiString;
Var
A,B : Double;
Begin
Result:='';
A:=1.2;
B:=3.4;
AssertEquals('Doubles within delta',B,A,1);
end;
Function DoTest33: AnsiString;
Var
A : Pointer;
Begin
Result:='';
A:=Nil;
AssertNull('A is nil',A);
end;
Function DoTest34: AnsiString;
Var
A : Pointer;
Begin
Result:='';
A:=Pointer(123);
AssertNull('Must fail: A is nil',A);
end;
Function DoTest35: AnsiString;
Var
A : Pointer;
Begin
Result:='';
A:=Nil;
AssertNotNull('Must fail: A is nil',A);
end;
Function DoTest36: AnsiString;
Var
A : Pointer;
Begin
Result:='';
A:=Pointer(123);
AssertNotNull('A is not nil',A);
end;
Function DoTest37: AnsiString;
Begin
Result:='';
if not AssertFalse('Condition is false',False) then
Fail('This is not supposed to happen');
end;
Function DoTest38: AnsiString;
Var
PA,PB : Pointer;
Begin
Result:='';
PA:=@DoTest36;
PB:=@DoTest37;
if not AssertDiffers('Pointers differ',PA,PB) then
Fail('This is not supposed to happen');
end;
Function DoTest39: AnsiString;
Var
PA,PB : Pointer;
Begin
Result:='';
PA:=@DoTest36;
PB:=@DoTest36;
if AssertDiffers('Must fail: pointers differ',PA,PB) then
Fail('This is not supposed to happen');
end;
Procedure DoExcept;
begin
Raise EError.Create;
end;
Procedure DoNoExcept;
begin
end;
Procedure DoFailExcept;
begin
Raise EFail.Create('err');
end;
Function DoTest40: AnsiString;
Begin
Result:='';
AssertException('Must not fail (correct exception',EError,@DoExcept);
end;
Function DoTest41: AnsiString;
Begin
Result:='';
AssertException('Must fail (no exception)',EError,@DoNoExcept);
end;
Function DoTest42: AnsiString;
Begin
Result:='';
AssertException('Must fail (Wrong exception)',EError,@DoFailExcept);
end;
Function DoTest43: AnsiString;
Begin
Result:='';
AssertNotSame('Pointers differ',EFail.Create(''),EError.Create);
end;
Function DoTest44: AnsiString;
Begin
Result:='';
if Not AssertInheritsFrom('EError is TObject',EError,TObject) then
Fail('This should not happen');
end;
Function DoTest45: AnsiString;
Begin
Result:='';
if AssertInheritsFrom('Must fail, nil parent',EError,Nil) then
Fail('This should not happen');
end;
Function DoTest46: AnsiString;
Begin
Result:='';
if AssertInheritsFrom('Must fail, nil child',Nil,EError) then
Fail('This should not happen');
end;
Function DoTest47: AnsiString;
Begin
Result:='';
AssertInheritsFrom('Instances. Must fail',EFail.Create(''),EError.Create);
end;
Begin
RequirePassed:=True;
AddTest('Test1',@DoTest1);
AddTest('Test2',@DoTest2);
AddTest('Test3',@DoTest3);
AddTest('Test4',@DoTest4);
AddTest('Test5',@DoTest5);
AddTest('Test6',@DoTest6);
AddTest('Test7',@DoTest7);
AddTest('Test8',@DoTest7)^.Active:=False;
AddTest('Test9',@DoTest9);
AddTest('Test10',@DoTest10);
AddTest('Test11',@DoTest11);
AddTest('Test12',@DoTest12);
AddTest('Test13',@DoTest13);
AddTest('Test14',@DoTest14);
AddTest('Test15',@DoTest15);
AddTest('Test16',@DoTest16);
AddTest('Test17',@DoTest17);
AddTest('Test18',@DoTest18);
AddTest('Test19',@DoTest19);
AddTest('Test20',@DoTest20);
AddTest('Test21',@DoTest21);
AddTest('Test22',@DoTest22);
AddTest('Test23',@DoTest23);
AddTest('Test24',@DoTest24);
AddTest('Test25',@DoTest25);
AddTest('Test26',@DoTest26);
AddTest('Test27',@DoTest27);
AddTest('Test28',@DoTest28);
AddTest('Test29',@DoTest29);
AddTest('Test30',@DoTest30);
AddTest('Test31',@DoTest31);
AddTest('Test32',@DoTest32);
AddTest('Test33',@DoTest33);
AddTest('Test34',@DoTest34);
AddTest('Test35',@DoTest35);
AddTest('Test36',@DoTest36);
AddTest('Test37',@DoTest37);
AddTest('Test38',@DoTest38);
AddTest('Test39',@DoTest39);
AddTest('Test40',@DoTest40);
AddTest('Test41',@DoTest41);
AddTest('Test43',@DoTest43);
AddTest('Test44',@DoTest44);
AddTest('Test45',@DoTest45);
AddTest('Test46',@DoTest46);
AddTest('Test47',@DoTest47);
RunAllSysTests;
end.

17
rtl/test/testpunit3.pp
View File

@ -1,17 +0,0 @@
{$mode objfpc}
program testpunit2;
uses punit, sysutils;
Function DoTest : AnsiString;
begin
Result:='test failed';
end;
begin
SetTimeHook(@SysUtils.Now);
RunTest(@DoTest);
end.

224
rtl/test/testrtl.lpi
View File

@ -1,224 +0,0 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<SaveOnlyProjectUnits Value="True"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<SaveJumpHistory Value="False"/>
<SaveFoldState Value="False"/>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="testrtl"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<CommandLineParams Value="--suite=SysUtils.StringBuilder"/>
</local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<CommandLineParams Value="--suite=SysUtils.StringBuilder"/>
</local>
</Mode0>
</Modes>
</RunParams>
<Units Count="39">
<Unit0>
<Filename Value="testrtl.pp"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="utstrtotime.pp"/>
<IsPartOfProject Value="True"/>
</Unit1>
<Unit2>
<Filename Value="utwstrcmp.pp"/>
<IsPartOfProject Value="True"/>
</Unit2>
<Unit3>
<Filename Value="utrtl.pp"/>
<IsPartOfProject Value="True"/>
</Unit3>
<Unit4>
<Filename Value="utstrcmp.pp"/>
<IsPartOfProject Value="True"/>
</Unit4>
<Unit5>
<Filename Value="utuplow.pp"/>
<IsPartOfProject Value="True"/>
</Unit5>
<Unit6>
<Filename Value="utunifile.pp"/>
<IsPartOfProject Value="True"/>
</Unit6>
<Unit7>
<Filename Value="utstrtobool.pp"/>
<IsPartOfProject Value="True"/>
</Unit7>
<Unit8>
<Filename Value="utscanf.pp"/>
<IsPartOfProject Value="True"/>
</Unit8>
<Unit9>
<Filename Value="utrwsync.pp"/>
<IsPartOfProject Value="True"/>
</Unit9>
<Unit10>
<Filename Value="utformat.pp"/>
<IsPartOfProject Value="True"/>
</Unit10>
<Unit11>
<Filename Value="utfloattostr.pp"/>
<IsPartOfProject Value="True"/>
</Unit11>
<Unit12>
<Filename Value="utfilename.pp"/>
<IsPartOfProject Value="True"/>
</Unit12>
<Unit13>
<Filename Value="utffirst.pp"/>
<IsPartOfProject Value="True"/>
</Unit13>
<Unit14>
<Filename Value="utfile.pp"/>
<IsPartOfProject Value="True"/>
</Unit14>
<Unit15>
<Filename Value="utfexpand.pp"/>
<IsPartOfProject Value="True"/>
</Unit15>
<Unit16>
<Filename Value="utextractquote.pp"/>
<IsPartOfProject Value="True"/>
</Unit16>
<Unit17>
<Filename Value="utexec.pp"/>
<IsPartOfProject Value="True"/>
</Unit17>
<Unit18>
<Filename Value="utexpfncase.pp"/>
<IsPartOfProject Value="True"/>
</Unit18>
<Unit19>
<Filename Value="utbytesof.pp"/>
<IsPartOfProject Value="True"/>
</Unit19>
<Unit20>
<Filename Value="utdirex.pp"/>
<IsPartOfProject Value="True"/>
</Unit20>
<Unit21>
<Filename Value="utencoding.pp"/>
<IsPartOfProject Value="True"/>
</Unit21>
<Unit22>
<Filename Value="utencodingerr.pp"/>
<IsPartOfProject Value="True"/>
</Unit22>
<Unit23>
<Filename Value="utastrcmp.pp"/>
<IsPartOfProject Value="True"/>
</Unit23>
<Unit24>
<Filename Value="utsyshelpers.pp"/>
<IsPartOfProject Value="True"/>
</Unit24>
<Unit25>
<Filename Value="utstringhelp.pp"/>
<IsPartOfProject Value="True"/>
</Unit25>
<Unit26>
<Filename Value="utfattr.pp"/>
<IsPartOfProject Value="True"/>
</Unit26>
<Unit27>
<Filename Value="utenv.pp"/>
<IsPartOfProject Value="True"/>
</Unit27>
<Unit28>
<Filename Value="utdos.pp"/>
<IsPartOfProject Value="True"/>
</Unit28>
<Unit29>
<Filename Value="utdfexp.pp"/>
<IsPartOfProject Value="True"/>
</Unit29>
<Unit30>
<Filename Value="utfsearch.pp"/>
<IsPartOfProject Value="True"/>
</Unit30>
<Unit31>
<Filename Value="utverify.pp"/>
<IsPartOfProject Value="True"/>
</Unit31>
<Unit32>
<Filename Value="utstrcopy.pp"/>
<IsPartOfProject Value="True"/>
</Unit32>
<Unit33>
<Filename Value="utstrings1.pp"/>
<IsPartOfProject Value="True"/>
</Unit33>
<Unit34>
<Filename Value="utstringbuild.pp"/>
<IsPartOfProject Value="True"/>
</Unit34>
<Unit35>
<Filename Value="syssbh.inc"/>
<IsPartOfProject Value="True"/>
</Unit35>
<Unit36>
<Filename Value="syssb.inc"/>
<IsPartOfProject Value="True"/>
</Unit36>
<Unit37>
<Filename Value="utustringbuild.pp"/>
<IsPartOfProject Value="True"/>
</Unit37>
<Unit38>
<Filename Value="uttypinfo.pp"/>
<IsPartOfProject Value="True"/>
</Unit38>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

22
rtl/test/testrtl.pp
View File

@ -1,22 +0,0 @@
{$h+}
program testrtl;
uses
{$IFDEF unix} cthreads, {$ENDIF}
punit, sysutils, utsysutils,
utstrtotime, utstrcmp, utastrcmp, utwstrcmp, utuplow, utunifile,
utstrtobool, utscanf, utrwsync, utformat, utfloattostr, utfilename,
utffirst, utfile, utfexpand,utexpfncase,utextractquote, utexec,
utbytesof, utdirex, utencoding, utencodingerr, utsyshelpers,
utstringhelp, utfattr, utenv,utdfexp,utfsearch, utverify,
utstrcopy, utstrings1, utstringbuild, utustringbuild, uttypinfo, utclasses ;
begin
SetTimeHook(@Now);
if IsExecInvocation then
Halt(Ord(Not TestExecInvocation))
else
RunAllSysTests;
end.

20
rtl/test/tohelper.inc
View File

@ -1,20 +0,0 @@
Result:='';
V:=value;
if not AssertEquals('ToString',ValueAsString,V.ToString) then
Exit;
if not AssertEquals('ToBoolean',True,V.ToBoolean) then
Exit;
V:=0;
if not AssertEquals('ToBoolean',False,V.ToBoolean) then
Exit;
V:=value;
if not AssertEquals('ToHexString',ValueAshex,V.ToHexString) then
Exit;
if not AssertEquals('ToHexString',ValueAsHexDigString,V.ToHexString(ValueAsHexDig)) then
Exit;
if not AssertEquals('ToSingle',Single(Value+0.0),V.ToSingle,0.00001) then
Exit;
if not AssertEquals('ToDouble',Double(Value+0.0),V.ToDouble,0.00001) then
Exit;
if not AssertEquals('ToExtended',Extended(Value+0.0),V.ToExtended,0.00001) then
Exit;

6
rtl/test/unittest.cfg
View File

@ -1,6 +0,0 @@
-n
-S2
-Fu../units/$fpctarget/
-vwh
-B

171
rtl/test/utastrcmp.pp
View File

@ -1,171 +0,0 @@
unit utastrcmp;
{$mode objfpc}
{$h+}
interface
uses
{$ifdef unix}
{$ifdef darwin}iosxwstr{$else}cwstring{$endif},
{$endif unix}
SysUtils;
implementation
uses punit,utrtl;
Function checka(ok : boolean; func : string; value : longint) : Boolean;
begin
Result:=AssertTrue(Func+' failed, result = '+InTToStr(Value),Ok);
end;
Function tastrcmp : string;
var
a, b: array[0..1] of char;
tmp : longint;
begin
Result:='';
a[0] := #0; a[1] := #1; //Empty string
b[0] := #0; b[1] := #0; //Empty string with different char after end
tmp:=AnsiStrComp(a, b); //should be zero because a=b
if not checka(tmp=0,'AnsiStrComp',tmp) then exit;
tmp:=AnsiStrIComp(a, b); //should be zero because a=b
if not checka(tmp=0,'AnsiStrIComp',tmp) then exit;
end;
Var
teststr: string;
Function check(b: boolean; testnr: longint) : Boolean;
begin
Result:=AssertTrue(teststr+' error nr '+IntToStr(testnr),B);
end;
function testAnsiCompareText : string;
begin
Result:='';
teststr:='AnsiCompareText';
if not Check(ansicomparetext('a', 'a') = 0, 1) then exit;
if not Check(ansicomparetext('a', 'A') = 0, 2) then exit;
if not Check(ansicomparetext('A', 'a') = 0, 3) then exit;
if not Check(ansicomparetext('a', 'b') < 0, 4) then exit;
if not Check(ansicomparetext('c', 'b') > 0, 5) then exit;
if not Check(ansicomparetext('abc', 'AbC') = 0, 6) then exit;
if not Check(ansicomparetext('0123456789', '0123456789') = 0, 7) then exit;
if not Check(ansicomparetext('', '0123456789') < 0, 8) then exit;
if not Check(ansicomparetext('AbC', '') > 0, 9) then exit;
if not Check(ansicomparetext('AbC', 'A') > 0, 10) then exit;
if not Check(ansicomparetext('AbC', 'Ab') > 0, 11) then exit;
if not Check(ansicomparetext('AbC', 'ab') > 0, 12) then exit;
if not Check(ansicomparetext('Ab'#0'C', 'ab'#0) > 0, 13) then exit;
end;
function testAnsiStrIComp : string;
begin
Result:='';
teststr:='AnsiStrIComp';
if not Check(ansistricomp('a', 'a') = 0, 1) then exit;
if not Check(ansistricomp('a', 'A') = 0, 2) then exit;
if not Check(ansistricomp('A', 'a') = 0, 3) then exit;
if not Check(ansistricomp('a', 'b') < 0, 4) then exit;
if not Check(ansistricomp('c', 'b') > 0, 5) then exit;
if not Check(ansistricomp('abc', 'AbC') = 0, 6) then exit;
if not Check(ansistricomp('0123456789', '0123456789') = 0, 7) then exit;
if not Check(ansistricomp('', '0123456789') < 0, 8) then exit;
if not Check(ansistricomp('AbC', '') > 0, 9) then exit;
if not Check(ansistricomp('AbC', 'A') > 0, 10) then exit;
if not Check(ansistricomp('AbC', 'Ab') > 0, 11) then exit;
if not Check(ansistricomp('AbC', 'ab') > 0, 12) then exit;
if not Check(ansistricomp('Ab'#0'C', 'ab'#0) = 0, 13) then exit;
end;
Function testAnsiStrLComp : string;
begin
Result:='';
teststr:='AnsiStrLComp';
if not Check (ansistrlcomp ('', '', 0) = 0, 1) then exit; { Trivial case. }
if not Check (ansistrlcomp ('a', 'a', 1) = 0, 2) then exit; { Identity. }
if not Check (ansistrlcomp ('abc', 'abc', 3) = 0, 3) then exit; { Multicharacter. }
if not Check (ansistrlcomp ('abc'#0, 'abcd', 4) < 0, 4) then exit; { Length unequal. }
if not Check (ansistrlcomp ('abcd', 'abc'#0, 4) > 0, 5) then exit;
if not Check (ansistrlcomp ('abcd', 'abce', 4) < 0, 6) then exit; { Honestly unequal. }
if not Check (ansistrlcomp ('abce', 'abcd', 4) > 0, 7) then exit;
if not Check (ansistrlcomp ('abce', 'abcd', 3) = 0, 10) then exit; { Count limited. }
if not Check (ansistrlcomp ('abce', 'abc', 3) = 0, 11) then exit; { Count = length. }
if not Check (ansistrlcomp ('abcd', 'abce', 4) < 0, 12) then exit; { Nudging limit. }
if not Check (ansistrlcomp ('abc', 'def', 0) = 0, 13) then exit; { Zero count. }
if not Check (ansistrlcomp ('abc'#0'e', 'abc'#0'd', 5) > 0, 14) then exit;
end;
function testAnsiCompareStr : string;
begin
Result:='';
teststr:='AnsiCompareStr';
if not Check (ansicomparestr ('', '') = 0, 1) then exit; { Trivial case. }
if not Check (ansicomparestr ('a', 'a') = 0, 2) then exit; { Identity. }
if not Check (ansicomparestr ('abc', 'abc') = 0, 3) then exit; { Multicharacter. }
if not Check (ansicomparestr ('abc', 'abcd') < 0, 4) then exit; { Length mismatches. }
if not Check (ansicomparestr ('abcd', 'abc') > 0, 5) then exit;
if not Check (ansicomparestr ('abcd', 'abce') < 0, 6) then exit; { Honest miscompares. }
if not Check (ansicomparestr ('abce', 'abcd') > 0, 7) then exit;
if not Check (ansicomparestr ('abc'#0'e', 'abc'#0'd') > 0, 8) then exit;
end;
function testAnsiStrComp : string;
begin
Result:='';
teststr:='AnsiStrComp';
if not Check (ansistrcomp ('', '') = 0, 1) then exit; { Trivial case. }
if not Check (ansistrcomp ('a', 'a') = 0, 2) then exit; { Identity. }
if not Check (ansistrcomp ('abc', 'abc') = 0, 3) then exit; { Multicharacter. }
if not Check (ansistrcomp ('abc', 'abcd') < 0, 4) then exit; { Length mismatches. }
if not Check (ansistrcomp ('abcd', 'abc') > 0, 5) then exit;
if not Check (ansistrcomp ('abcd', 'abce') < 0, 6) then exit; { Honest miscompares. }
if not Check (ansistrcomp ('abce', 'abcd') > 0, 7) then exit;
if not Check (ansistrcomp ('abc'#0'e', 'abc'#0'd') = 0, 8) then exit;
end;
Function testAnsiStrLIComp : string;
begin
Result:='';
teststr:='AnsiStrLIComp';
if not Check(ansistrlicomp('a', 'a', 1) = 0, 1) then exit;
if not Check(ansistrlicomp('a', 'A', 1) = 0, 2) then exit;
if not Check(ansistrlicomp('A', 'a', 1) = 0, 3) then exit;
if not Check(ansistrlicomp('a', 'b', 1) < 0, 4) then exit;
if not Check(ansistrlicomp('c', 'b', 1) > 0, 5) then exit;
if not Check(ansistrlicomp('abc', 'AbC', 3) = 0, 6) then exit;
if not Check(ansistrlicomp('0123456789', '0123456789', 10) = 0, 7) then exit;
if not Check(ansistrlicomp(#0'123456789', #0'123456799', 10) < 0, 8) then exit;
if not Check(ansistrlicomp(#0'bD', #0'bC', 3) > 0, 9) then exit;
if not Check(ansistrlicomp('AbC', 'A'#0#0,3) > 0, 10) then exit;
if not Check(ansistrlicomp('AbC', 'Ab'#0, 3) > 0, 11) then exit;
if not Check(ansistrlicomp('AbC', 'ab'#0, 3) > 0, 12) then exit;
if not Check(ansistrlicomp('0123456789', 'AbC', 0) = 0, 13) then exit;
if not Check(ansistrlicomp('AbC', 'abc', 1) = 0, 14) then exit;
if not Check(ansistrlicomp('AbC', 'abc', 2) = 0, 15) then exit;
if not Check(ansistrlicomp('AbC', 'abc', 3) = 0, 16) then exit;
if not Check(ansistrlicomp('AbC', 'abcd', 3) = 0, 17) then exit;
if not Check(ansistrlicomp('AbCc', 'abcd', 4) < 0, 18) then exit;
if not Check(ansistrlicomp('ADC', 'abcd', 1) = 0, 19) then exit;
if not Check(ansistrlicomp('ADC', 'abcd', 2) > 0, 20) then exit;
if not Check(ansistrlicomp('abc'#0'e', 'abc'#0'd', 5) > 0, 21) then exit;
end;
begin
SysutilsTest('testAnsiCompareText',@testAnsiCompareText);
SysutilsTest('testAnsiStrIComp',@testAnsiStrIComp);
SysutilsTest('testAnsiStrLComp',@testAnsiStrLComp);
SysutilsTest('testAnsiCompareStr',@testAnsiCompareStr);
SysutilsTest('testAnsiStrComp',@testAnsiStrComp);
SysutilsTest('testAnsiStrLIComp',@testAnsiStrLIComp);
end.

76
rtl/test/utbytesof.pp
View File

@ -1,76 +0,0 @@
unit utbytesof;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes;
Implementation
uses punit,utrtl;
function CheckBytes(const B: TBytes): Boolean;
const
Etalon: array[0..3] of Byte = (84, 101, 115, 116);
var
I: Integer;
begin
Result := Length(B) <= Length(Etalon);
if Result then
for I := Low(B) to High(B) do
Result := Result and (B[I] = Etalon[I]);
end;
function CheckWideBytes(const B: TBytes): Boolean;
const
Etalon: array[0..7] of Byte = (
{$ifdef FPC_BIG_ENDIAN}
00, 84, 00, 101, 00, 115, 00, 116
{$else}
84, 00, 101, 00, 115, 00, 116, 00
{$endif}
);
var
I: Integer;
begin
Result := Length(B) <= Length(Etalon);
if Result then
for I := Low(B) to High(B) do
Result := Result and (B[I] = Etalon[I]);
end;
Function CheckBytesOf : AnsiString;
var
S: AnsiString;
U: UnicodeString;
B: TBytes;
begin
Result:='';
S := 'Test';
U := S;
B := BytesOf(S);
if not CheckBytes(B) then
Exit('Error at 1');
if StringOf(B) <> U then
Exit('Error at 2');
B := BytesOf(S[1]);
if not CheckBytes(B) then
Exit('Error at 3');
B := BytesOf(U);
if not CheckBytes(B) then
Exit('Error at 4');
B := BytesOf(U[1]);
if not CheckBytes(B) then
Exit('Error at 5');
B := WideBytesOf(U);
if not CheckWideBytes(B) then
Exit('Error at 6');
if WideStringOf(B) <> U then
Exit('Error at 7');
end;
begin
SysUtilsTest('BytesOf',@CheckBytesOf);
end.

1390
rtl/test/utclasses.pp
View File

File diff suppressed because it is too large Load Diff

557
rtl/test/utdfexp.pp
View File

@ -1,557 +0,0 @@
{ %skiptarget=wince }
{
This file is part of the Free Pascal test suite.
Copyright (c) 1999-2004 by the Free Pascal development team.
Test for possible bugs in Dos.FExpand
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
unit utdfexp;
interface
uses punit, utrtl;
{$DEFINE DEBUG}
(* Defining DEBUG causes all the source and target strings *)
(* to be written to the console to make debugging easier. *)
{ $DEFINE DIRECT}
(* Defining DIRECT causes direct embedding of fexpand.inc instead *)
(* of using FExpand implementation in (previously compiled) unit Dos. *)
implementation
uses
Dos;
{$IFDEF DIRECT}
(* For testing purposes on non-native platforms *)
{$DEFINE VOLUMES}
{$DEFINE NODOTS}
{ $DEFINE AMIGA}
{ $DEFINE UNIX}
{$DEFINE MACOS}
{ $DEFINE FPC_FEXPAND_DRIVES}
{ $DEFINE FPC_FEXPAND_UNC}
{$DEFINE FPC_FEXPAND_VOLUMES}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{ $DEFINE FPC_FEXPAND_DIRSEP_IS_UPDIR}
{$DEFINE FPC_FEXPAND_NO_DOTS_UPDIR}
{ $DEFINE FPC_FEXPAND_NO_CURDIR}
{ $DEFINE FPC_FEXPAND_TILDE}
{ $DEFINE FPC_FEXPAND_MULTIPLE_UPDIR}
{$DEFINE FPC_FEXPAND_DIRSEP_IS_CURDIR}
{ $DEFINE FPC_FEXPAND_GETENV_PCHAR}
{$ENDIF DIRECT}
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF UNIX}
{$ENDIF LINUX}
{$IFDEF AMIGA}
{$IFNDEF HASAMIGA}
{$DEFINE HASAMIGA}
{$ENDIF HASAMIGA}
{$ENDIF AMIGA}
{$IFDEF HASAMIGA}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$DEFINE NODOTS}
{$ENDIF HASAMIGA}
{$IFDEF NETWARE}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$ENDIF NETWARE}
{$IFDEF UNIX}
{$DEFINE NODRIVEC}
{$ENDIF UNIX}
{$IFDEF MACOS}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$DEFINE NODOTS}
{$ENDIF MACOS}
const
{$IFNDEF NODRIVEC}
CC = 'C:';
{$ENDIF NODRIVEC}
{$IFNDEF FPC}
FileNameCasePreserving = false;
DirectorySeparator = '\';
DirectorySeparator2 = '\';
DirSep = '\';
CDrive = 'C:';
DriveSep = ':';
{$ELSE FPC}
(* Used for ChDir/MkDir *)
DirectorySeparator2 = System.DirectorySeparator;
{$IFDEF DIRECT}
{$IFDEF MACOS}
DirectorySeparator = ':';
LFNSupport = true;
FileNameCasePreserving = true;
{$ELSE MACOS}
{$IFDEF UNIX}
DirectorySeparator = '/';
DriveSeparator = '/';
FileNameCasePreserving = true;
{$ELSE UNIX}
{$IFDEF HASAMIGA}
DirectorySeparator = '/';
FileNameCasePreserving = true;
{$ELSE HASAMIGA}
DirectorySeparator = '\';
FileNameCasePreserving = false;
{$ENDIF HASAMIGA}
{$ENDIF UNIX}
{$ENDIF MACOS}
{$ENDIF DIRECT}
DirSep = DirectorySeparator;
{$IFDEF MACOS}
DriveSep = '';
{$ELSE MACOS}
DriveSep = DriveSeparator;
{$ENDIF MACOS}
{$IFDEF UNIX}
CDrive = '';
{$ELSE UNIX}
{$IFDEF MACOS}
CDrive = 'C';
{$ELSE MACOS}
{$IFDEF HASAMIGA}
CDrive = 'C';
{$ELSE HASAMIGA}
CDrive = 'C:';
{$ENDIF HASAMIGA}
{$ENDIF MACOS}
{$ENDIF UNIX}
{$ENDIF FPC}
TestFileName = 'testfile.tst';
TestDir1Name = 'TESTDIR1';
TestDir2Name = 'TESTDIR2';
{$IFDEF DIRECT}
procedure XToDirect (var S: string);
var
I: byte;
begin
if DirectorySeparator2 <> DirectorySeparator then
for I := 1 to Length (S) do
if S [I] = DirectorySeparator2 then
S [I] := DirectorySeparator;
{$IFNDEF FPC_FEXPAND_DRIVES}
if DriveSeparator = DirectorySeparator then
I := Pos (DirectorySeparator + DirectorySeparator, S)
else
I := Pos (DriveSeparator, S);
if I <> 0 then
Delete (S, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
end;
procedure GetDir (Drive: byte; var Directory: string);
begin
System.GetDir (Drive, Directory);
XToDirect (Directory);
end;
{$I fexpand.inc}
{$ENDIF DIRECT}
var
{$IFNDEF NODRIVEC}
CDir,
{$endif}
TestDir, TestDir0, OrigDir, CurDir, S: DirStr;
TestDrive: string [2];
F: file;
function Translate (S: PathStr): PathStr;
var
I: byte;
begin
{$IFDEF UNIX}
if (Length (S) > 1) and (S [2] = ':') then Delete (S, 1, 2);
{$ELSE UNIX}
for I := 1 to Length (S) do if S [I] = '/' then S [I] := DirSep;
if (Length (S) > 1) and (S [1] in ['a'..'z']) and (S[2]=DriveSep) then
S [1] := UpCase (S [1]);
{$ENDIF UNIX}
if not (FileNameCasePreserving) then
for I := 1 to Length (S) do S [I] := UpCase (S [I]);
Translate := S;
end;
Function Check (ID : Integer; Src, Rslt: PathStr) : Boolean;
var
Rslt2: PathStr;
S : string;
begin
{$IFDEF DEBUG}
if ShowDebugOutput then
WriteLn (ID,' : ',Src, '=>', Rslt);
{$ENDIF DEBUG}
Rslt := Translate (Rslt);
Rslt2 := FExpand (Src);
{$IFDEF DIRECT}
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, Rslt2);
if I <> 0 then
Delete (Rslt2, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
{$IFNDEF UNIX}
if (Length (Rslt2) > 1) and (Rslt2 [1] in ['a'..'z']) and (Rslt2[2]=DriveSep) then
Rslt2 [1] := UpCase (Rslt2 [1]);
{$ENDIF NDEF UNIX}
Str(ID,S);
Check:=AssertEquals(S+': FExpand ('+Src+ ')', Rslt,Rslt2);
end;
Function DoTest : TTestString;
begin
Result:='';
{$IFDEF DIRECT}
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, CurDir);
if I <> 0 then
Delete (CurDir, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
{$IFNDEF NODRIVEC}
GetDir (3, CDir);
{$ENDIF NODRIVEC}
if not Check (1,' ', CurDir + DirSep + ' ') then exit;
{$IFDEF HASAMIGA}
if not Check (2, '', CurDir) then exit;
{$ELSE HASAMIGA}
if not Check (3,'', CurDir + DirSep) then exit;
{$ENDIF HASAMIGA}
{$IFDEF MACOS}
if not Check (4,':', CurDir + DirSep) then exit;
{$ELSE MACOS}
if not Check (5,'.', CurDir) then exit;
{$ENDIF MACOS}
{$IFNDEF NODRIVEC}
if CDir [Length (CDir)] = DirSep then
begin
if not Check (6,'c:anything', CDir + 'anything') then
exit,
end
else
if not Check (7,'c:anything', CDir + DirSep + 'anything') then exit;
if not Check (8,CC + DirSep, CDrive + DirSep) then exit;
{$IFDEF NODOTS}
if not Check (9,'C:.', 'C:.') then exit;
if not Check (10,CC + DirSep + '.', CDrive + DirSep + '.') then exit;
if not Check (CC + DirSep + '..', CDrive + DirSep + '..') then exit;
{$ELSE NODOTS}
if not Check (11,'C:.', CDir) then exit;
if not Check (12,CC + DirSep + '.', CDrive + DirSep) then exit;
if not Check (13,CC + DirSep + '..', CDrive + DirSep) then exit;
{$ENDIF NODOTS}
if not Check (14,CC + DirSep + 'DOS', CDrive + DirSep + 'DOS') then exit;
{$IFNDEF NODOTS}
if not Check (15,CC + DirSep + '..' + DirSep + 'DOS', CDrive + DirSep + 'DOS') then exit;
{$ENDIF NODOTS}
if not Check (16,CC + DirSep + 'DOS.', CDrive + DirSep + 'DOS.') then exit;
{$IFDEF HASAMIGA} (* This has no effect - AMIGA has NODRIVEC defined... *)
if not Check (17,CC + DirSep + 'DOS' + DirSep, CDrive + DirSep) then exit;
{$ELSE HASAMIGA}
if not Check (18,CC + DirSep + 'DOS' + DirSep, CDrive + DirSep + 'DOS' + DirSep) then exit;
{$ENDIF HASAMIGA}
{$IFNDEF NODOTS}
if not Check (19,CC + DirSep + 'DOS' + DirSep + '.', CDrive + DirSep + 'DOS') then exit;
if not Check (20,CC + DirSep + 'DOS' + DirSep + '..', CDrive + DirSep) then exit;
if not Check (21,CC + DirSep + 'DOS' + DirSep + '..' + DirSep, CDrive + DirSep) then exit;
if not Check (22,CC + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..', CDrive +
DirSep + 'DOS') then exit;
if not Check (23,ID,'C:' + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..' + DirSep,
CDrive + DirSep + 'DOS' + DirSep) then exit;
{$ENDIF NODOTS}
{$ENDIF NODRIVEC}
{$IFNDEF MACOS}
{$IFDEF HASAMIGA}
if not Check (24,DirSep, TestDir + TestDir1Name) then exit;
if not Check (25,DirSep + DirSep + TestFileName, TestDir + TestFileName) then exit;
if not Check (26,DirSep + 'DOS', TestDir + TestDir1Name + DirSep + 'DOS') then exit;
{$ELSE HASAMIGA}
if not Check (27,DirSep, TestDrive + DirSep) then exit;
if not Check (28,DirSep + '.', TestDrive + DirSep) then exit;
if not Check (29,DirSep + '..', TestDrive + DirSep)then exit;
if not Check (30,DirSep + 'DOS', TestDrive + DirSep + 'DOS') then exit;
{$ENDIF HASAMIGA}
{$ENDIF MACOS}
if not Check (31,'d', CurDir + DirSep + 'd')then exit;
{$IFDEF MACOS}
if not Check (32,DirSep + 'd', CurDir + DirSep + 'd') then exit;
{$ELSE MACOS}
{$IFNDEF NODOTS}
if not Check (33,'.' + DirSep + 'd', CurDir + DirSep + 'd') then exit;
{$ENDIF NODOTS}
{$ENDIF MACOS}
if not Check (34,'d' + DirSep + TestFileName, CurDir + DirSep + 'd' + DirSep + TestFileName) then exit;
if not Check (35,' d', CurDir + DirSep + ' d') then exit;
if not Check (36,'dd', CurDir + DirSep + 'dd') then exit;
{$IFDEF MACOS}
if not Check (37,DirSep + 'dd' + DirSep + 'dd', CurDir + DirSep + 'dd' + DirSep + 'dd') then exit;
if not Check (38,'dd' + DirSep + 'dd', 'dd' + DirSep + 'dd') then exit;
{$ELSE MACOS}
if not Check (39,'dd' + DirSep + 'dd', CurDir + DirSep + 'dd' + DirSep + 'dd') then exit;
{$ENDIF MACOS}
if not Check (40,'ddd', CurDir + DirSep + 'ddd') then exit;
{$IFDEF MACOS}
if not Check (41,'dddd' + DirSep + 'eeee.ffff', 'dddd' + DirSep + 'eeee.ffff') then exit;
{$ELSE MACOS}
if not Check (42,'dddd' + DirSep + 'eeee.ffff', CurDir + DirSep + 'dddd' + DirSep
+ 'eeee.ffff') then exit;
{$ENDIF MACOS}
if not Check (43,'.special', CurDir + DirSep + '.special') then exit;
if not Check (44,'..special', CurDir + DirSep + '..special') then exit;
if not Check (45,'special..', CurDir + DirSep + 'special..') then exit;
{$IFDEF HASAMIGA}
if not Check (46,'special.' + DirSep, CurDir + DirSep + 'special.' + DirSep) then exit;
{$ELSE HASAMIGA}
{$IFDEF MACOS}
if not Check (47,'special.' + DirSep, 'special.' + DirSep) then exit;
{$ELSE MACOS}
if not Check (48,'special.' + DirSep, CurDir + DirSep + 'special.' + DirSep) then exit;
{$ENDIF MACOS}
{$ENDIF HASAMIGA}
{$IFDEF MACOS}
if not Check (49,DirSep + DirSep, TestDir + TestDir1Name + DirSep) then exit;
if not Check (50,DirSep + DirSep + TestFileName, TestDir + TestDir1Name + DirSep
+ TestFileName) then exit;
{$ELSE MACOS}
if not Check (51,DirSep + '.special', TestDrive + DirSep + '.special') then exit;
{$IFNDEF NODOTS}
if not Check (52,'..', TestDir + TestDir1Name) then exit;
if not Check (53,'.' + DirSep + '..', TestDir + TestDir1Name) then exit;
if not Check (54,'..' + DirSep + '.', TestDir + TestDir1Name) then exit;
{$ENDIF NODOTS}
{$ENDIF MACOS}
{$IFDEF NETWARE}
if not Check (55,'...', TestDir) then exit;
{$ELSE NETWARE}
if not Check (56,'...', CurDir + DirSep + '...') then exit;
{$ENDIF NETWARE}
if not Check (57,TestFileName, CurDir + DirSep + TestFileName) then exit;
{$IFDEF UNIX}
S := GetEnv ('HOME');
{ On m68k netbsd at least, HOME contains a final slash
remove it PM }
if (Length (S) > 1) and (S [Length (S)] = DirSep) then
S:=Copy(S,1,Length(S)-1);
if Length (S) = 0 then
begin
if not Check (58,'~', CurDir) then exit;
if not Check (59,'~' + DirSep + '.', DirSep) then exit;
end
else
begin
if not Check (60,'~', S) then exit;
if not Check (61,'~' + DirSep + '.', S) then exit;
end;
if (Length (S) > 0) and (S [Length (S)] <> DirSep) then
S := S + DirSep;
if not Check (62,'~NobodyWithThisNameShouldEverExist.test/nothing', CurDir + DirSep +
'~NobodyWithThisNameShouldEverExist.test/nothing') then exit;
if not Check (63,'/tmp/~NoSuchUserAgain', '/tmp/~NoSuchUserAgain') then exit;
if Length (S) = 0 then
begin
if not Check (64,'~' + DirSep, DirSep) then exit;
if not Check (65,'~' + DirSep + '.' + DirSep, DirSep) then exit;
if not Check (66,'~' + DirSep + 'directory' + DirSep + 'another',
DirSep + 'directory' + DirSep + 'another') then exit;
end
else
begin
if not Check (67,'~' + DirSep, S) then exit;
if not Check (68,'~' + DirSep + '.' + DirSep, S) then exit;
if not Check (69,'~' + DirSep + 'directory' + DirSep + 'another',
S + 'directory' + DirSep + 'another') then exit;
end;
{$ELSE UNIX}
{$IFNDEF NODRIVEC}
if not Check (70,TestDrive + '..', TestDir + TestDir1Name) then exit;
if not Check (71,TestDrive + '..' + DirSep, TestDir + TestDir1Name + DirSep) then exit;
if not Check (72,TestDrive + '.' + DirSep + '.', CurDir) then exit;
if not Check (73,TestDrive + '.' + DirSep + '..', TestDir + TestDir1Name) then exit;
{$I-}
(*
{ $ ifndef unix }
{ avoid a and b drives for
no unix systems to reduce the
probablility of getting an alert message box }
{ This should not be needed - unit popuperr should solve this?! TH }
I := 3;
{$else unix} *)
I := 1;
{ $ endif unix}
repeat
S := '';
GetDir (I, S);
IOR := IOResult;
if IOR = 0 then Inc (I);
until (I > 26) or (IOR <> 0);
if I <= 26 then
begin
S := Chr (I + 64) + ':ddd';
if not Check (74,S, Chr (I + 64) + ':' + DirSep + 'ddd') then exit;
end else
if ShowDebugOutput then
WriteLn ('Sorry, cannot test FExpand behaviour for incorrect drives here.');
{$I+}
{$IFDEF FPC}
if not Check (75,'d\d/d', CurDir + DirSep + 'd' + DirSep + 'd' + DirSep + 'd') then exit;
if not Check (76,'\\server\share\directory', '\\server\share\directory') then exit;
if not Check (77,'\\server\share\directory1\directory2\..',
'\\server\share\directory1') then exit;
if not Check (78,'\\', '\\') then exit;
if not Check (79,'\\.', '\\.\') then exit;
if not Check (80,'\\.\', '\\.\') then exit;
if not Check (81,'\\.\.', '\\.\.') then exit;
if not Check (82,'\\.\..', '\\.\..') then exit;
if not Check (83,'\\.\...', '\\.\...') then exit;
if not Check (84,'\\.\TEST', '\\.\TEST') then exit;
if not Check (85,'\\..\', '\\..\') then exit;
if not Check (86,'\\..\TEST', '\\..\TEST') then exit;
if not Check (87,'\\..\TEST\.', '\\..\TEST') then exit;
if not Check (88,'\\..\TEST1\TEST2\..', '\\..\TEST1') then exit;
if not Check (89,'\\..\TEST\..', '\\..\TEST') then exit;
if not Check (90,'\\..\TEST\..\..', '\\..\TEST') then exit;
{$ENDIF FPC}
{$ENDIF NODRIVEC}
{$ENDIF UNIX}
{$IFDEF VOLUMES}
{$IFDEF HASAMIGA}
if not Check (91,'VolName' + DriveSep + 'DIR1', 'VolName' + DriveSep + 'DIR1') then exit;
{$ELSE HASAMIGA}
if not Check (92,'VolName' + DriveSep + DirSep + 'DIR1', 'VolName' + DriveSep + DirSep + 'DIR1') then exit;
{$ENDIF HASAMIGA}
{$IFNDEF NODOTS}
if not Check (93,'VolName' + DriveSep + DirSep + 'DIR1' + DirSep + '..', 'VolName' + DriveSep + DirSep) then exit;
if not Check (94,'VolName' + DriveSep + DirSep + 'DIR1' + DirSep + '..' + DirSep + '..',
'VolName' + DriveSep + DirSep) then exit;
if not Check (95,'VolName' + DriveSep + DirSep + '.', 'VolName:' + DirSep) then exit;
if not Check (96,'VolName' + DriveSep + DirSep + '..', 'VolName:' + DirSep) then exit;
if not Check (97,'VolName' + DriveSep + DirSep + '..' + DirSep, 'VolName' + DriveSep + DirSep) then exit;
{$ENDIF NODOTS}
{$IFDEF NETWARE}
if not Check (98,'SrvName\VolName' + DriveSep + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName' +
DriveSep + DirSep + 'TEST') then exit;
if not Check (99,'SrvName/VolName' + DriveSep + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName' +
DriveSep + DirSep + 'TEST') then exit;
{$ENDIF NETWARE}
{$IFDEF HASAMIGA}
{$IFDEF NODOTS}
if not Check (100,'.', CurDir + DirSep + '.') then exit;
{$ELSE NODOTS}
if not Check (101,'.', CurDir) then exit;
{$ENDIF NODOTS}
{$ENDIF HASAMIGA}
{$ENDIF VOLUMES}
end;
Function TestDosFExpand : TTestString;
begin
Result:='';
TestDir:=SysGetSetting('fexpanddir');
if (TestDir='') then
begin
if ShowDebugOutput then
begin
WriteLn ('Warning: Parameter missing!');
WriteLN('Full path to a directory with write access' +
{$IFNDEF UNIX}
{$IFNDEF VOLUMES}
#13#10'(preferably not on a C: drive)' +
{$ENDIF VOLUMES}
{$ENDIF UNIX}
' expected.');
WriteLn ('Trying to use the current directory instead ' +
{$IFDEF UNIX}
'(not quite ideal).');
{$ELSE UNIX}
'(problems might arise).');
{$ENDIF UNIX}
end;
// Get current dir
{$IFDEF DIRECT}System.{$ENDIF DIRECT}GetDir(0,TestDir);
end;
if TestDir[Length(TestDir)]<>DirectorySeparator2 then
TestDir := TestDir + DirectorySeparator2;
{$IFDEF DIRECT}System.{$ENDIF DIRECT}GetDir (0,OrigDir);
{$IFDEF NODRIVEC}
TestDrive := '';
{$ELSE NODRIVEC}
TestDrive := Copy (TestDir, 1, 2);
GetDir ((Ord (TestDir [1]) and not ($20)) - 64, OrigTstDir);
{$ENDIF NODRIVEC}
{$I-}
MkDir (TestDir + TestDir1Name);
if IOResult <> 0 then ;
MkDir (TestDir + TestDir1Name + DirectorySeparator2 + TestDir2Name);
if IOResult <> 0 then ;
{$I+}
ChDir (TestDir + TestDir1Name + DirectorySeparator2 + TestDir2Name);
{$I-}
TestDir0 := TestDir;
{$IFDEF DIRECT}
XToDirect (TestDir);
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, TestDir);
if I <> 0 then
Delete (TestDir, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
Assign (F, TestFileName);
Rewrite (F);
Close (F);
if IOResult <> 0 then ;
{$IFNDEF DIRECT}
Assign (F, FExpand (TestFileName));
{$ENDIF DIRECT}
{$I+}
GetDir (0, CurDir);
// Do the actual tests.
// The test exits at the first error, so we put it in a subroutine to be able to clean up.
Result:=DoTest;
// Clean up
Erase (F);
{$IFNDEF NODRIVEC}
ChDir (OrigTstDir);
{$ENDIF NODRIVEC}
ChDir (OrigDir);
RmDir (TestDir0 + TestDir1Name + DirectorySeparator2 + TestDir2Name);
RmDir (TestDir0 + TestDir1Name);
end;
begin
AddTest('DosFExpand',@TestDosFExpand,EnsureSuite('Dos'));
end.

156
rtl/test/utdirex.pp
View File

@ -1,156 +0,0 @@
unit utdirex;
interface
{$mode objfpc}
{$H+}
uses
sysutils;
implementation
uses punit,utrtl;
{$I+}
const
AllowOneTrailingSeparator: boolean = false;
AllowMultipleTrailingSeparators: boolean = false;
Function TestDirectoryExists(Test : Integer;Const DirName : string; ExpectedResult : boolean) : Boolean;
begin
Result:=AssertEquals('Test '+IntToStr(Test),ExpectedResult,Sysutils.DirectoryExists (DirName));
end;
Function TestParents(BaseN : Integer;var dir : string) : Boolean;
var
sep_pos,maxpos,i : longint;
N : integer;
begin
Result:=True;
N:=0;
while Result do
begin
Inc(N);
sep_pos:=0;
for i:=length(dir) downto 1 do
if dir[i] in AllowDirectorySeparators then
begin
sep_pos:=i;
break;
end;
if (sep_pos=0) then
exit;
maxpos:=sep_pos;
dir:=copy(dir,1,maxpos);
Result:=TestDirectoryExists(BaseN+2*N,dir,AllowOneTrailingSeparator);
if Result and (length(dir)>1) then
begin
dir:=copy(dir,1,maxpos-1);
Result:=TestDirectoryExists(BaseN+2*N+1,dir,true);
end
else
exit;
end;
end;
Function DoTestDirectoryExists : AnsiString;
var
dir,dir1,dir2,StoredDir : string;
P: shortstring;
ch : char;
begin
Result:='';
StoredDir:='';
P:=ExtractFilePath(paramstr(0));
if ShowDebugOutput then
begin
Writeln('Path="',P,'"');
Writeln('DirectorySeparator="',DirectorySeparator,'"');
Write('AllowDirectorySeparators="');
for ch:=low(char) to high(char) do
if ch in AllowDirectorySeparators then
Write(ch);
Writeln('"');
end;
{ The following would be already tested at the beginning of TestParents
TestDirectoryExists(P,true);
}
{ The following check wouldn't work correctly if running the test executable
from a root drive - not a typical case, but still worth mentioning... }
if DirectoryExists(P) then
AllowOneTrailingSeparator:=true
else if ShowDebugOutput then
WriteLn ('Warning: Some code may expect support for a trailing directory separator!');
if DirectoryExists(P+DirectorySeparator) then
AllowMultipleTrailingSeparators:=true;
dir:=P;
if ShowDebugOutput then
Writeln('Calling TestParents with dir="',dir,'"');
TestParents(100,dir);
dir:=P;
{$IFDEF MACOS}
{$WARNING The following test is wrong for Mac OS!}
{$ENDIF MACOS}
{$IFDEF AMIGA}
{$WARNING The following test is wrong for Amiga (volumes are not detected properly)!}
{$ENDIF AMIGA}
{$IFDEF NETWARE}
{$WARNING The following test is wrong for Amiga (volumes are not detected properly)!}
{$ENDIF NETWARE}
{$IFNDEF UNIX}
if (length(dir)>2) and (dir[2]= DriveSeparator) and (dir[3]=DirectorySeparator) then
begin
GetDir(0,StoredDir);
ChDir(Copy(Dir,1,3));
if ShowDebugOutput then
Writeln('Calling TestParents with dir="',dir,'" from directory '
+ Copy (Dir, 1, 3) + ' (root)');
TestParents(200,dir);
ChDir(StoredDir);
end;
{$ELSE UNIX}
GetDir(0,StoredDir);
ChDir(DirectorySeparator);
if ShowDebugOutput then
Writeln('Calling TestParents with dir="',dir,'" from directory '
+ DirectorySeparator + ' (root)');
if not TestParents(200,dir) then exit;
ChDir(StoredDir);
{$ENDIF UNIX}
dir:=P+'_Dummy';
if not TestDirectoryExists(1,dir,false) then exit;
dir1:=P+'_Dummy'+DirectorySeparator;
if not TestDirectoryExists(2,dir1,false) then exit;
mkdir(dir);
if not TestDirectoryExists(3,dir,true) then exit;
if not TestDirectoryExists(4,dir1,AllowOneTrailingSeparator) then exit;
{ Check that using two directory separators fails }
if not TestDirectoryExists(5,dir1+DirectorySeparator,AllowMultipleTrailingSeparators) then exit;
if ('/' in AllowDirectorySeparators) and ('/' <> DirectorySeparator) then
begin
if not TestDirectoryExists(6,dir+'/',AllowOneTrailingSeparator) then exit;
if not TestDirectoryExists(7,dir1+'/',AllowMultipleTrailingSeparators) then exit;
if not TestDirectoryExists(8,dir1+'//',AllowMultipleTrailingSeparators) then exit;
end;
if not TestDirectoryExists (9,dir1 + DirectorySeparator + DirectorySeparator, AllowMultipleTrailingSeparators) then exit;
dir2:=dir1+'_Dummy2';
if not TestDirectoryExists(10,dir2,false) then exit;
mkdir(dir2);
if not TestDirectoryExists(11,dir2,true) then exit;
rmdir(dir2);
rmdir(dir);
if not TestDirectoryExists(12,dir,false) then exit;
if not TestDirectoryExists(13,dir1,false) then exit;
end;
begin
SysUtilsTest('TestDirectoryExists',@DoTestDirectoryExists);
end.

46
rtl/test/utdos.pp
View File

@ -1,46 +0,0 @@
unit utdos;
{$mode objfpc}
interface
uses
Classes, SysUtils;
{ verifies that the DOSError variable is equal to }
{ the value requested. }
Function CheckDosError(Msg : String; err: Integer) : Boolean;
implementation
uses dos, punit;
Function CheckDosError(Msg : String; err: Integer) : Boolean;
var
x : integer;
s :string;
Begin
x := DosError;
case x of
0 : s := '(0): No Error.';
2 : s := '(2): File not found.';
3 : s := '(3): Path not found.';
5 : s := '(5): Access Denied.';
6 : s := '(6): Invalid File Handle.';
8 : s := '(8): Not enough memory.';
10 : s := '(10) : Invalid Environment.';
11 : s := '(11) : Invalid format.';
18 : s := '(18) : No more files.';
else
begin
Str (X, S);
s := '(' + s + ') - INVALID DOSERROR';
end
end;
Result:=AssertEquals(Msg+': Value of DOSError ('+S+')',Err,X);
end;
end.

157
rtl/test/utencoding.pp
View File

@ -1,157 +0,0 @@
unit utencoding;
{$mode delphi}{$H+}
{$codepage cp1251}
interface
uses
SysUtils, Classes;
implementation
uses punit, utrtl;
function CheckCodePage(const B: TBytes; AEncoding: TEncoding): Boolean;
var
DetectedEncoding: TEncoding;
begin
DetectedEncoding := nil;
Result :=
(TEncoding.GetBufferEncoding(B, DetectedEncoding) <> 0) and
(DetectedEncoding = AEncoding);
end;
Function DoEncodingTest : AnsiString;
const
UTF8Bytes: array[0..18] of byte = ($EF,$BB,$BF,$D0,$9F,$D1,$80,$D0,$BE,$D0,$B2,$D0,$B5,$D1,$80,$D0,$BA,$D0,$B0);
UTF16Bytes: array[0..17] of byte = ($FF,$FE,$1F,$04,$40,$04,$3E,$04,$32,$04,$35,$04,$40,$04,$3A,$04,$30,$04);
UTF16BEBytes: array[0..17] of byte = ($FE,$FF,$04,$1F,$04,$40,$04,$3E,$04,$32,$04,$35,$04,$40,$04,$3A,$04,$30);
type
TCp1251String = type AnsiString(1251);
TCp866String = type AnsiString(866);
var
Cp866Encoding,
Cp1251Encoding: TEncoding;
Bytes: TBytes;
Cp1251String,
Cp1251String2: TCp1251String;
Cp866String: Tcp866String;
S: AnsiString;
U8: UTF8String;
U1, U2: UnicodeString;
begin
Result:='';
// 1. check various conversions
Cp866Encoding := TEncoding.GetEncoding('IBM866');
Cp1251Encoding := TEncoding.GetEncoding('windows-1251');
Cp1251String := 'Ïðèâåò çåìëÿíå!';
Cp866String := Cp1251String;
Bytes := Cp1251Encoding.GetBytes(Cp1251String);
Bytes := TEncoding.Convert(Cp1251Encoding, Cp866Encoding, Bytes);
SetString(S, PAnsiChar(Bytes), Length(Bytes));
if not CompareMem(Pointer(S), Pointer(Cp866String), Length(S)) then
Exit('Error at 1');
if StringCodePage(S)<>CP_ACP then
Exit('Error at 11');
Cp1251String2:=Cp1251String;
SetString(Cp1251String,pchar(Cp1251String2),length(Cp1251String2));
if StringCodePage(Cp1251String)<>1251 then
Exit('Error at 12');
U1 := Cp866Encoding.GetString(Bytes);
U2 := TEncoding.Unicode.GetString(TEncoding.Convert(Cp866Encoding, TEncoding.Unicode, Bytes));
if U1 <> U2 then
Exit('Error at 2');
U1 := TEncoding.BigEndianUnicode.GetString(TEncoding.Convert(Cp866Encoding, TEncoding.BigEndianUnicode, Bytes));
if U1 <> U2 then
Exit('Error at 3');
Bytes := TEncoding.Convert(Cp866Encoding, TEncoding.UTF8, Bytes);
U8 := Cp866String;
if not CompareMem(Pointer(U8), @Bytes[0], Length(U8)) then
Exit('Error at 4');
// 2. check misc functions
if not (TEncoding.IsStandardEncoding(TEncoding.Unicode) or TEncoding.IsStandardEncoding(TEncoding.UTF8) or TEncoding.IsStandardEncoding(TEncoding.UTF7)) or
TEncoding.IsStandardEncoding(Cp866Encoding) or TEncoding.IsStandardEncoding(Cp1251Encoding) then
Exit('Error at 5');
if Cp866Encoding.EncodingName = '' then
Exit('Error at 6')
else if ShowDebugOutput then
WriteLn(Cp866Encoding.EncodingName);
if TEncoding.Default.CodePage <> DefaultSystemCodePage then
Exit('Error at 7');
// 3. check codepage detection
SetLength(Bytes, Length(UTF8Bytes));
Move(UTF8Bytes[0], Bytes[0], Length(UTF8Bytes));
if not CheckCodePage(Bytes, TEncoding.UTF8) then
Exit('Error at 8');
SetLength(Bytes, Length(UTF16Bytes));
Move(UTF16Bytes[0], Bytes[0], Length(UTF16Bytes));
if not CheckCodePage(Bytes, TEncoding.Unicode) then
Exit('Error at 9');
SetLength(Bytes, Length(UTF16BEBytes));
Move(UTF16BEBytes[0], Bytes[0], Length(UTF16BEBytes));
if not CheckCodePage(Bytes, TEncoding.BigEndianUnicode) then
Exit('Error at 10');
Cp866Encoding.Free;
Cp1251Encoding.Free;
Result:='';
end;
Function DoEncodingTest2 : AnsiString;
var
ACP,StartDefaultSystemCodePage: TSystemCodePage;
begin
StartDefaultSystemCodePage := DefaultSystemCodePage;
ACP:=TEncoding.ANSI.CodePage;
try
// test creating ANSI when DefaultSystemCodePage is set to non-ANSI
if DefaultSystemCodePage<>CP_UTF8 then
DefaultSystemCodePage := CP_UTF8
else
DefaultSystemCodePage := 1250;
if TEncoding.ANSI.CodePage<>ACP then
Exit('AnsiCodePage changed when setting DefaultSystemCodePage to non-initial value');
// test default
DefaultSystemCodePage := StartDefaultSystemCodePage;
if TEncoding.ANSI.CodePage<>TEncoding.SystemEncoding.CodePage then
Exit('Ansi codepage not set to UTF8');
// try utf-8
DefaultSystemCodePage := CP_UTF8;
if TEncoding.ANSI.CodePage<>ACP then
Exit('AnsiCodePage changed when setting DefaultSystemCodePage to UTF8');
if TEncoding.SystemEncoding.CodePage<>DefaultSystemCodePage then
Exit('SystemEncoding differs from defaultsystemcodepage');
// try a different single-byte encoding
if StartDefaultSystemCodePage=1250 then
DefaultSystemCodePage := 1251
else
DefaultSystemCodePage := 1250;
if TEncoding.ANSI.CodePage<>ACP then
Exit('Ansicodepage changed when setting defaultsystemcodepage to different single-byte codepage');
if TEncoding.SystemEncoding.CodePage<>DefaultSystemCodePage then
Exit('SystemEncoding not correctly set after changing to different single-byte codepage');
// try start again
DefaultSystemCodePage := StartDefaultSystemCodePage;
if TEncoding.SystemEncoding.CodePage<>DefaultSystemCodePage then
Exit('Systemencoding codepage not set correct when changing back to original');
finally
DefaultSystemCodePage:=StartDefaultSystemCodePage;
end;
end;
begin
SysUtilsTest('EncodingTest',@DoEncodingTest);
SysUtilsTest('EncodingTest2',@DoEncodingTest2);
end.Encodin

75
rtl/test/utencodingerr.pp
View File

@ -1,75 +0,0 @@
unit utencodingerr;
{$mode delphi}
{$H+}
interface
uses
SysUtils;
implementation
uses punit, utrtl;
Procedure DumpException(E : Exception);
begin
If ShowDebugOutput then
Writeln(E.ClassName, ' ', E.Message);
end;
Function encodingerrors : AnsiString;
var
S: String;
Bytes: TBytes;
begin
Result:='';
S := '';
Bytes:=Nil;
SetLength(Bytes, 0);
try
// invalid source array?
TEncoding.UTF8.GetBytes(S, 1, -1, Bytes, 0);
Exit('Error on 1');
except on E: Exception do
DumpException(E);
end;
S := 'Test';
try
// delphi raises a message "Invalid source array" while the problem is in
// destination array in real
TEncoding.UTF8.GetBytes(S, 0, 2, Bytes, 0);
Exit('Error on 2');
except on E: Exception do
DumpException(E);
end;
SetLength(Bytes, 1);
try
// invalid count
TEncoding.UTF8.GetBytes(S, 5, 2, Bytes, 0);
Exit('Error on 3');
except on E: Exception do
DumpException(E);
end;
try
// character index out of bounds
TEncoding.UTF8.GetBytes(S, 0, 2, Bytes, 0);
Exit('Error on 4');
except on E: Exception do
DumpException(E);
end;
try
// invalid destination index
TEncoding.UTF8.GetBytes(S, 1, 2, Bytes, -1);
Exit('Error on 5');
except on E: Exception do
DumpException(E);
end;
end;
initialization
SysUtilsTest('utencodingerr',@encodingerrors);
end.

82
rtl/test/utenv.pp
View File

@ -1,82 +0,0 @@
{******************************************}
{ Used to check the DOS unit }
{------------------------------------------}
{ TestEncCount routine testing }
{******************************************}
{$mode objfpc}
unit utenv;
interface
uses punit, utrtl;
implementation
uses dos, utdos;
Function TestEnvCount : TTestString;
Var
I: Integer;
E,S : string;
Begin
Result:='';
if ShowDebugOutput then
begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' ENVCOUNT/ENVSTR ');
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: Environment variables should be of the form VAR=VALUE ');
WriteLn(' Note: Non valid indexes should return empty strings. ');
WriteLn(' Note: Index 0 points to an empty string ');
WriteLn('----------------------------------------------------------------------');
end;
if not CheckDosError('Initial value',0) then exit;
{*------------------------- NOTE -------------------------------------*}
{* Variables should be of the form VAR=VALUE *}
{*--------------------------------------------------------------------*}
if not AssertTrue('Have environment',EnvCount>0) then exit;
if ShowDebugOutput then
begin
WriteLn('Number of environment variables : ',EnvCount);
WriteLn('CURRENT ENVIRONMENT');
end;
For I:=1 to EnvCount do
begin
Str(I,S);
E:=EnvStr(i);
if not CheckDosError('After getting valid environment variable '+S,0) then exit;
if not AssertTrue('Environment var '+S+' is not empty',E<>'') then exit;
if ShowDebugOutput then
WriteLn(E);
end;
if ShowDebugOutput then
begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: The next few lines should be empty strings, as they are ');
WriteLn(' invalid environment indexes. ');
WriteLn('----------------------------------------------------------------------');
end;
For i:=-5 to 0 do
begin
Str(I,S);
E:=EnvStr(i);
if not CheckDosError('After getting valid environment variable '+S,0) then exit;
if not AssertTrue('Invalid environment var '+S+' is empty',E='') then exit;
if ShowDebugOutput then
WriteLn(E);
end;
For i:=EnvCount+10 to EnvCount+20 do
begin
Str(I,S);
E:=EnvStr(i);
if not CheckDosError('After getting valid environment variable '+S,0) then exit;
if not AssertTrue('Invalid environment var '+S+' is empty',E='') then exit;
if ShowDebugOutput then
WriteLn(E);
end;
end;
Begin
AddTest('TestEnvCount',@TestEnvCount,EnsureSuite('Dos'));
end.

74
rtl/test/utexec.pp
View File

@ -1,74 +0,0 @@
{$mode objfpc}
{$h+}
unit utexec;
interface
uses
sysutils;
Function IsExecInvocation : Boolean;
Function TestExecInvocation : Boolean;
Implementation
uses punit, utrtl;
const
comparestr='-Fu/usr/local/lib/fpc/1.0.10/units/freebsd/rtl/*';
Function IsExecInvocation : Boolean;
begin
Result:=ParamStr(1)=comparestr
end;
Function TestExecInvocation : Boolean;
var
i : Longint;
begin
I:=1;
Result:=True;
While Result and (I<=11) do
begin
Result:=ParamStr(i)=comparestr;
Inc(i);
end;
Result:=Result and (paramstr(12)='');
end;
Function TestExecuteProcess : String;
var
cmd,cmdline : String;
i : Longint;
begin
AllowDirectorySeparators:=['/','\'];
cmd:=ExtractFileName(Paramstr(0));
{$ifdef unix}
cmd:='./'+cmd;
{$endif}
cmdline:='';
for i:=0 to 10 do
begin
if Cmdline<>'' then
CmdLine:=CmdLine+' ';
cmdline:=cmdline+comparestr;
end;
if Not AssertEquals('Failed to execute test command',0,ExecuteProcess(cmd,cmdline)) Then exit;
// test illegal command
try
ExecuteProcess('afsdfdas',cmdline);
Result:='Failed to raise exception for unknown command';
except
Result:=''
end;
end;
begin
SysUtilsTest('TestExecuteProcess',@TestExecuteProcess);
end.

140
rtl/test/utexpfncase.pp
View File

@ -1,140 +0,0 @@
unit utexpfncase;
interface
{$MODE OBJFPC}
{$H+}
{$DEFINE FPCTEST}
uses SysUtils;
implementation
uses punit, utrtl;
const
TestFilesNumber = 3;
{$IFDEF UNIX}
MinPathLength = 1;
{$ELSE UNIX}
MinPathLength = 3;
{$ENDIF UNIX}
type
TTestFiles = array [1..TestFilesNumber] of shortstring;
const
TestFiles: TTestFiles = ('testFile1.tst', 'testFile2.tst', 'TestFile2.tst');
Procedure TestExpFNC (const FN1, ExpReturn: string; ExpMatch: TFilenameCaseMatch);
var
FN2: string;
Match: TFilenameCaseMatch;
N1,N2 : String;
begin
Str(expmatch,N1);
FN2 := ExpandFileNameCase (FN1, Match);
if (Match <> ExpMatch) or ((ExpReturn <> '') and (FN2 <> ExpReturn) and
((Match <> mkAmbiguous) or not (FileNameCaseSensitive) or
(UpperCase (FN2) <> UpperCase (ExpReturn)))) then
begin
Str(Match,N2);
FailExit('Error: Input = '+ FN1+ ', Output = '+ FN2+ ' (expected '+ExpReturn+'), MatchFound = '+N2+' (expected '+ N1+ ')');
end;
end;
Procedure DoTestExpandFilename(TempDir : String);
var
I: byte;
TestDir: string;
begin
for I := 1 to TestFilesNumber do
FileClose (FileCreate (TestFiles [I]));
TestExpFNC ('*File1.tst', ExpandFileName ('testFile1.tst'), mkExactMatch);
if FileNameCaseSensitive then
TestExpFNC ('TestFile1.tst', ExpandFileName ('testFile1.tst'), mkSingleMatch)
else
TestExpFNC ('TestFile1.tst', ExpandFileName ('testFile1.tst'), mkExactMatch);
TestExpFNC ('testFile1.tst', ExpandFileName ('testFile1.tst'), mkExactMatch);
TestExpFNC ('testFile2.tst', ExpandFileName ('testFile2.tst'), mkExactMatch);
if FileNameCaseSensitive then
TestExpFNC ('TestFile2.tst', ExpandFileName ('TestFile2.tst'), mkExactMatch)
else
TestExpFNC ('TestFile2.tst', ExpandFileName ('testFile2.tst'), mkExactMatch);
if FileNameCaseSensitive then
TestExpFNC ('testfile2.tst', ExpandFileName ('testFile2.tst'), mkAmbiguous)
else
TestExpFNC ('testfile2.tst', ExpandFileName ('testFile2.tst'), mkExactMatch);
(* Return value depends on ordering of files in the particular filesystem used thus not checked *)
TestExpFNC ('*File2.tst', '', mkExactMatch);
if FileNameCaseSensitive then
TestExpFNC ('*File*.tst', '', mkExactMatch)
else
TestExpFNC ('*File*.tst', '', mkExactMatch);
TestExpFNC ('..' + DirectorySeparator + '*' + DirectorySeparator + '*File*.tst',
ExpandFileName ('..' + DirectorySeparator + '*' + DirectorySeparator + '*File*.tst'),
mkNone);
I := Length (TempDir);
TestDir := TempDir;
while (I > 1) and not (TempDir [I] in ['a'..'z','A'..'Z']) do
Dec (I);
if I > 0 then
begin
if TestDir [I] in ['a'..'z'] then
TestDir [I] := char (Ord (TestDir [I]) and not $20)
else
TestDir [I] := char (Ord (TestDir [I]) or $20);
end
else
WriteLn ('Warning: Cannot perform all required tests; please set TEMP!');
if FileNameCaseSensitive then
TestExpFNC (TestDir + DirectorySeparator + 'testFile1.tst',
ExpandFileName (TempDir + DirectorySeparator + 'testFile1.tst'), mkSingleMatch)
else
TestExpFNC (TestDir + DirectorySeparator + 'testFile1.tst',
ExpandFileName (TestDir + DirectorySeparator + 'testFile1.tst'), mkExactMatch);
if FileNameCaseSensitive then
TestExpFNC (TestDir + DirectorySeparator + 'testfile1.tst',
ExpandFileName (TempDir + DirectorySeparator + 'testFile1.tst'), mkSingleMatch)
else
TestExpFNC (TestDir + DirectorySeparator + 'testfile1.tst',
ExpandFileName (TestDir + DirectorySeparator + 'testFile1.tst'), mkExactMatch);
for I := 1 to TestFilesNumber do
if not (DeleteFile (TestFiles [I])) then
begin
if FileNameCaseSensitive or (I <> 3) then
WriteLn ('Warning: Deletion of ', TestFiles [I], ' (file #', I, ') failed - possibly due to case insensitive file system!');
end;
end;
Function TestExpandFilename : String;
var
TempDir : string;
CurDir: string;
begin
Result:='';
TempDir := ExpandFilename (GetTempDir);
if (Length (TempDir) > MinPathLength) and
(TempDir [Length (TempDir)] in AllowDirectorySeparators) then
TempDir := LeftStr (TempDir, Length (TempDir) - 1);
CurDir := GetCurrentDir;
Try
SetCurrentDir (TempDir);
DoTestExpandFilename(TempDir);
finally
SetCurrentDir(CurDir);
end;
end;
begin
SysUtilsTest('TestExpandFileNameCase',@TestExpandFilename);
end.

45
rtl/test/utextractquote.pp
View File

@ -1,45 +0,0 @@
unit utextractquote;
interface
// test AnsiExtractQuotedStr
{$mode objfpc}
{$h+}
Uses SysUtils;
implementation
uses punit, utrtl;
Function TestAnsiExtractQuotedStr : String;
Function dotest(str,val2,val3:string) : Boolean;
var
p : pchar;
s2 : string;
begin
p:=pchar(Str);
s2:=AnsiExtractQuotedStr(p,'"');
Result:=AssertEquals('Testing >'+Str+'< return value',val2,S2);
if Not Result then exit;
Result:=AssertEquals('Testing >'+Str+'< left value',val3,ansistring(p));
end;
begin
Result:='';
if not dotest('"test1""test2"','test1"test2','') then exit;
if not dotest('"test1" "test2"','test1',' "test2"') then exit;
if not dotest('"test1 test2"','test1 test2','') then exit;
if not dotest('"test1 test2','test1 test2','') then exit;
if not dotest('','','') then exit;
if not dotest('"','','') then exit;
if not dotest('""','','') then exit;
if not dotest('"x"','x','') then exit;
end;
begin
SysUtilsTest('TestAnsiExtractQuotedStr',@TestAnsiExtractQuotedStr);
end.

305
rtl/test/utfattr.pp
View File

@ -1,305 +0,0 @@
{******************************************}
{ Used to check the DOS unit }
{------------------------------------------}
{ SetFAttr / GetFAttr testing }
{******************************************}
{$mode objfpc}
unit utfattr;
interface
uses punit, utrtl;
implementation
uses dos, utdos;
{$IFDEF MSDOS}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF DPMI}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF GO32V1}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF GO32V2}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF OS2}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF WIN32}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF ATARI}
{$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF WINCE}
{$DEFINE EXTATTR}
{$ENDIF}
CONST
{ what is the root path }
{$ifdef UNIX}
RootPath = '/';
{$else UNIX}
{$ifdef WINCE}
RootPath = '\';
{$else WINCE}
RootPath = 'C:\';
{$endif WINCE}
{$ENDIF}
Week:Array[0..6] of String =
('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
TestFName = 'TESTDOS.DAT'; { CASE SENSITIVE DON'T TOUCH! }
TestFName1 = 'TESTFILE'; { CASE SENSITIVE DON'T TOUCH! }
TestDir = 'MYDIR'; { CASE SENSITIVE DON'T TOUCH! }
{$IFDEF TP}
DirectorySeparator = '\';
{$ENDIF}
Function TestFAttr1 : TTestString;
Var
F: File;
Attr: Word;
m,s: string;
Begin
Result:='';
Attr:=0;
S:='';
M:='Opening an invalid file...';
if ShowDebugOutput then
WriteLn(M);
Assign(f,'');
GetFAttr(f,Attr);
if not CheckDosError(M,3) then exit;
Assign(f,TestFName);
M:='Trying to open a valid file...';
if ShowDebugOutput then
WriteLn(M+'Success!');
GetFAttr(f,Attr);
if not CheckDosError(M,0) then exit;
{$ifndef wince}
M:='Trying to open the current directory file...';
if ShowDebugOutput then
Write(M);
Assign(f,'.');
GetFAttr(f,Attr);
if Not AssertTrue(M+'Not directory',(attr and Directory)<>0) then
Exit;
if ShowDebugOutput then
Writeln('Success');
if not CheckDosError(M,0) then exit;
M:='Trying to open the parent directory file...';
if ShowDebugOutput then
Write(M);
Assign(f,'..');
GetFAttr(f,Attr);
if not AssertTrue(M+'Not directory',(attr and Directory)<> 0) then
exit;
if ShowDebugOutput then
WriteLn('Success!');
if not CheckDosError(M,0) then exit;
{$endif wince}
{ This is completely platform dependent
M:='Trying to open the parent directory file when in root...';
if ShowDebugOutput then
Write(M);
Getdir(0,s);
ChDir(RootPath);
Assign(f,'..');
GetFAttr(f,Attr);
ChDir(s);
if not CheckDosError(M,3) then exit;
if ShowDebugOutput then
WriteLn('Success!');
}
{$ifdef go32v2}
{ Should normally fail, because of end directory separator. This is
allowed under unixes so the test is go32v2 only }
M:='Trying to open a directory file...Success!';
if ShowDebugOutput then
WriteLn(M);
GetDir(0,s);
Assign(f,s+DirectorySeparator);
GetFAttr(f, Attr);
if not CheckDosError(M,3) then exit;
{$endif}
M:='Trying to open a directory file...';
if ShowDebugOutput then
Write(M);
{$ifdef wince}
s:='\windows';
{$else}
GetDir(0,s);
{$endif wince}
Assign(f,s);
GetFAttr(f, Attr);
if not AssertTrue(M+'Not directory',(attr and Directory)<> 0) then
exit;
if ShowDebugOutput then
WriteLn('Success!');
CheckDosError(M,0);
end;
Function TestFAttr : TTestString;
Var
F: File;
Attr: Word;
s: string;
Begin
Result:='';
Attr:=0;
S:='';
Assign(f, TestFname);
{----------------------------------------------------------------}
{ This routine causes problems, because it all depends on the }
{ operating system. It is assumed here that HIDDEN is available }
{ to all operating systems. }
{----------------------------------------------------------------}
s:='Setting read-only attribute on '+TestFName+'...';
SetFAttr(f,ReadOnly);
if not CheckDosError(S,0) then exit;
{$IFDEF EXTATTR}
GetFAttr(f,Attr);
if not CheckDosError(S,0) then exit;
if not AssertTrue(S+'Read-only attribute set.',Attr and ReadOnly<> 0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.')
{ file should no longer be read only }
s:='Removing read-only attribute...';
SetFAttr(f,Archive);
if not CheckDosError(S,0) then exit;
GetFAttr(f,Attr);
if not CheckDosError(S,0) then exit;
if not AssertTrue(S+'Read-only attribute still set.',Attr and ReadOnly=0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.');
{$ENDIF}
s:='Setting hidden attribute on '+TestFName+'...';
SetFAttr(f,Hidden);
CheckDosError(S,0);
{$IFDEF EXTATTR}
GetFAttr(f,Attr);
CheckDosError(0);
if not AssertTrue(S+'Hidden attribute set.',Attr and Hidden<> 0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.');
{ file should no longer be read only }
s:='Removing hidden attribute...';
SetFAttr(f,Archive);
CheckDosError(S,0);
GetFAttr(f,Attr);
CheckDosError(S,0);
if not AssertTrue(S+'Hidden attribute still set.',Attr and Hidden=0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.');
{$ENDIF}
{$IFDEF EXTATTR}
s:='Setting system attribute on '+TestFName+'...';
SetFAttr(f,SysFile);
CheckDosError(S,0);
GetFAttr(f,Attr);
CheckDosError(S,0);
if not AssertTrue(S+'System attribute set.',Attr and SysFile<> 0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.')
{ file should no longer be read only }
s:='Removing Sysfile attribute...';
SetFAttr(f,0);
CheckDosError(0);
GetFAttr(f,Attr);
CheckDosError(0);
if not AssertTrue(S+'System attribute set.',Attr and SysFile= 0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.');
{$ENDIF}
{
s:='Setting Directory attribute on '+TestFName+'...';
SetFAttr(f,Directory);
CheckDosError(S,5);
GetFAttr(f,Attr);
CheckDosError(S,0);
if Not AssertTrue(s+'Directory Attribute set.',(Attr and Directory)=0) then exit;
if ShowDebugOutput then
WriteLn(s+'Success.');
}
{**********************************************************************}
{********************** TURBO PASCAL BUG ******************************}
{ The File is not a volume name, and DosError = 0, which is incorrect }
{ it shoulf not be so in FPC. }
{**********************************************************************}
{********************** TURBO PASCAL BUG ******************************}
s:='Setting Volume attribute on '+TestFName+'...';
SetFAttr(f,VolumeID);
{$ifndef tp}
CheckDosError(S,5);
{$else}
CheckDosError(S,0);
{$endif}
GetFAttr(f,Attr);
CheckDosError(S,0);
if not AssertTrue(s+'Volume Attribute set.',Attr and VolumeID=0) then
if ShowDebugOutput then
WriteLn(s+'Success.');
end;
Function DoneFattr : TTestString;
var
f: file;
begin
Result:='';
RmDir(TestDir);
Assign(f,TestFname);
Erase(f);
Assign(f,TestFname1);
Erase(f);
end;
Function InitFattr : TTestString;
var
f: file;
Begin
Result:='';
{$IFDEF MACOS}
pathTranslation:= true;
{$ENDIF}
if ShowDebugoutput then
WriteLn('File should never be executed in root path!');
Assign(f,TestFName);
Rewrite(f,1);
BlockWrite(f,Week,sizeof(Week));
Close(f);
Assign(f,TestFName1);
Rewrite(f,1);
Close(F);
MkDir(TestDir);
end;
Procedure RegisterFattrTests;
Var
P : PSuite;
begin
P:=AddSuite('Fattr',@InitFattr,@DonefAttr,EnsureSuite('Dos'));
AddTest('testfattr1',@testfattr1,P);
AddTest('testfattr',@testfattr,P);
end;
initialization
RegisterFattrTests;
end.

476
rtl/test/utfexpand.pp
View File

@ -1,476 +0,0 @@
unit utfexpand;
{$mode objfpc}
{$h+}
interface
{ %target=linux,freebsd,openbsd,netbsd,win32,win64,darwin,haiku,morphos }
{
This file is part of the Free Pascal test suite.
Copyright (c) 1999-2004 by the Free Pascal development team.
Test for possible bugs in SysUtils.ExpandFileName
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$codepage utf8}
{ $DEFINE DEBUG}
(* Defining DEBUG causes all the source and target strings *)
(* to be written to the console to make debugging easier. *)
uses
{$ifdef unix}
{$ifdef darwin}iosxwstr{$else}cwstring{$endif},
{$endif}
SysUtils;
implementation
uses punit, utrtl;
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF UNIX}
{$ENDIF LINUX}
{$IFDEF AMIGA}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$ENDIF AMIGA}
{$IFDEF NETWARE}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$ENDIF NETWARE}
{$IFDEF UNIX}
{$DEFINE NODRIVEC}
{$ENDIF UNIX}
{$IFDEF MACOS}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$DEFINE NODOTS}
{$ENDIF MACOS}
const
{$IFNDEF NODRIVEC}
CC = UTF8String('C:');
{$ENDIF NODRIVEC}
{$IFNDEF FPC}
FileNameCasePreserving = false;
DirectorySeparator = '\';
DirectorySeparator2 = '\';
DirSep = '\';
CDrive = 'C:';
DriveSep = ':';
{$ELSE FPC}
(* Used for ChDir/MkDir *)
DirectorySeparator2 = UTF8String(System.DirectorySeparator);
{$IFDEF DIRECT}
{$IFDEF MACOS}
DirectorySeparator = UTF8String(':');
LFNSupport = true;
FileNameCasePreserving = true;
{$ELSE MACOS}
{$IFDEF UNIX}
DirectorySeparator = UTF8String('/');
DriveSeparator = UTF8String('/');
FileNameCasePreserving = true;
{$ELSE UNIX}
{$IFDEF AMIGA}
DirectorySeparator = UTF8String(':');
FileNameCasePreserving = true;
{$ELSE AMIGA}
DirectorySeparator = UTF8String('\');
FileNameCasePreserving = false;
{$ENDIF AMIGA}
{$ENDIF UNIX}
{$ENDIF MACOS}
{$ENDIF DIRECT}
DirSep = UTF8String(DirectorySeparator);
{$IFDEF MACOS}
DriveSep = '';
{$ELSE MACOS}
{$IFDEF AMIGA}
DriveSep = '';
{$ELSE AMIGA}
DriveSep = DriveSeparator;
{$ENDIF AMIGA}
{$ENDIF MACOS}
{$IFDEF UNIX}
CDrive = '';
{$ELSE UNIX}
{$IFDEF MACOS}
CDrive = UTF8String('C');
{$ELSE MACOS}
{$IFDEF AMIGA}
CDrive = UTF8String('C');
{$ELSE AMIGA}
CDrive = UTF8String('C:');
{$ENDIF AMIGA}
{$ENDIF MACOS}
{$ENDIF UNIX}
{$ENDIF FPC}
TestFileName = UTF8String('™estfilê.™st');
TestDir1Name = UTF8String('TÊS™DIR1');
TestDir2Name = UTF8String('TE∑™DIR2');
var
{$IFNDEF NODRIVEC}
CDir,
{$endif}
TestDir, TestDir0, OrigDir, CurDir, S: UTF8String;
TestDrive: UTF8String;
F: file;
function Translate (S: rawbytestring): rawbytestring;
var
I: byte;
begin
{$IFDEF UNIX}
if (Length (S) > 1) and (S [2] = ':') then Delete (S, 1, 2);
{$ELSE UNIX}
for I := 1 to Length (S) do if S [I] = '/' then S [I] := DirSep[1];
if (Length (S) > 1) and (S [1] in ['a'..'z']) and (S[2]=DriveSep) then
S [1] := UpCase (S [1]);
{$ENDIF UNIX}
if not (FileNameCasePreserving) then
for I := 1 to Length (S) do S [I] := UpCase (S [I]);
Translate := S;
end;
procedure Check (Src, Rslt: rawbytestring);
var
Rslt2: rawbytestring;
begin
{$IFDEF DEBUG}
WriteLn (Src, '=>', Rslt);
{$ENDIF DEBUG}
Rslt := Translate (Rslt);
Rslt2 := ExpandFileName (Src);
{$IFDEF DIRECT}
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, Rslt2);
if I <> 0 then
Delete (Rslt2, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
{$IFNDEF UNIX}
if (Length (Rslt2) > 1) and (Rslt2 [1] in ['a'..'z']) and (Rslt2[2]=DriveSep) then
Rslt2 [1] := UpCase (Rslt2 [1]);
{$ENDIF NDEF UNIX}
if Rslt <> Rslt2 then
FailExit('Error: ExpandFileName ('+Src+ ') should be "'+Rslt+'", not "'+Rslt2+'"');
end;
Function DoTestFexpand : AnsiString;
begin
Result:='';
Assign (F, TestFileName);
Rewrite (F);
Close (F);
if IOResult <> 0 then ;
{ prevent conversion of TestFileName to ansi code page in case of
ExpandFileName(ansistring) }
Assign (F, ExpandFileName (RawByteString(TestFileName)));
{$I+}
GetDir (0, CurDir);
{$IFNDEF NODRIVEC}
GetDir (3, CDir);
{$ENDIF NODRIVEC}
Check (' ', CurDir + DirSep + ' ');
{$IFDEF AMIGA}
Check ('', CurDir);
{$ELSE AMIGA}
Check ('', CurDir + DirSep);
{$ENDIF AMIGA}
{$IFDEF MACOS}
Check (':', CurDir + DirSep);
{$ELSE MACOS}
Check ('.', CurDir);
{$ENDIF MACOS}
{$IFNDEF NODRIVEC}
if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
else Check ('c:anything', CDir + DirSep + 'anything');
Check (CC + DirSep, CDrive + DirSep);
{$IFDEF NODOTS}
Check ('C:.', 'C:.');
Check (CC + DirSep + '.', CDrive + DirSep + '.');
Check (CC + DirSep + '..', CDrive + DirSep + '..');
{$ELSE NODOTS}
Check ('C:.', CDir);
Check (CC + DirSep + '.', CDrive + DirSep);
Check (CC + DirSep + '..', CDrive + DirSep);
{$ENDIF NODOTS}
Check (CC + DirSep + UTF8String('∂œ∑'), CDrive + DirSep + UTF8String('∂œ∑'));
{$IFNDEF NODOTS}
Check (CC + DirSep + '..' + DirSep + UTF8String('∂œ∑'), CDrive + DirSep + UTF8String('∂œ∑'));
{$ENDIF NODOTS}
Check (CC + DirSep + 'DOS.', CDrive + DirSep + 'DOS.');
{$IFDEF AMIGA}
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep, CDrive + DirSep);
{$ELSE AMIGA}
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep, CDrive + DirSep + UTF8String('∂œ∑') + DirSep);
{$ENDIF AMIGA}
{$IFNDEF NODOTS}
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep + '.', CDrive + DirSep + UTF8String('∂œ∑'));
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep + '..', CDrive + DirSep);
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep + '..' + DirSep, CDrive + DirSep);
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep + UTF8String('†ĘŚ™') + DirSep + '..', CDrive +
DirSep + UTF8String('∂œ∑'));
Check (CC + DirSep + UTF8String('∂œ∑') + DirSep + UTF8String('†ĘŚ™') + DirSep + '..' + DirSep,
CDrive + DirSep + UTF8String('∂œ∑') + DirSep);
{$ENDIF NODOTS}
{$ENDIF NODRIVEC}
{$IFNDEF MACOS}
Check (DirSep, TestDrive + DirSep);
Check (DirSep + '.', TestDrive + DirSep);
Check (DirSep + '..', TestDrive + DirSep);
Check (DirSep + UTF8String('∂œ∑'), TestDrive + DirSep + UTF8String('∂œ∑'));
{$ENDIF MACOS}
Check (UTF8String('∆'), CurDir + DirSep + UTF8String('∆'));
{$IFDEF MACOS}
Check (DirSep + UTF8String('∆'), CurDir + DirSep + UTF8String('∆'));
{$ELSE MACOS}
{$IFNDEF NODOTS}
Check ('.' + DirSep + UTF8String('∆'), CurDir + DirSep + UTF8String('∆'));
{$ENDIF NODOTS}
{$ENDIF MACOS}
Check (UTF8String('∆') + DirSep + TestFileName, CurDir + DirSep + UTF8String('∆') + DirSep + TestFileName);
Check (UTF8String(' ∆'), CurDir + DirSep + UTF8String(' ∆'));
Check (UTF8String('∆∆'), CurDir + DirSep + UTF8String('∆∆'));
{$IFDEF MACOS}
Check (DirSep + UTF8String('∆∆') + DirSep + UTF8String('∆∆'), CurDir + DirSep + UTF8String('∆∆') + DirSep + UTF8String('∆∆'));
Check (UTF8String('∆∆') + DirSep + UTF8String('∆∆'), UTF8String('∆∆') + DirSep + UTF8String('∆∆'));
{$ELSE MACOS}
Check (UTF8String('∆∆') + DirSep + UTF8String('∆∆'), CurDir + DirSep + UTF8String('∆∆') + DirSep + UTF8String('∆∆'));
{$ENDIF MACOS}
Check (UTF8String('∂∂∂'), CurDir + DirSep + UTF8String('∂∂∂'));
{$IFDEF MACOS}
Check (UTF8String('∂∂∂∂') + DirSep + UTF8String('ÊÊÊÊ.ƒƒƒƒ'), UTF8String('∂∂∂∂') + DirSep + UTF8String('ÊÊÊÊ.ƒƒƒƒ'));
{$ELSE MACOS}
Check (UTF8String('∂∂∂∂') + DirSep + UTF8String('ÊÊÊÊ.ƒƒƒƒ'), CurDir + DirSep + UTF8String('∂∂∂∂') + DirSep
+ UTF8String('ÊÊÊÊ.ƒƒƒƒ'));
{$ENDIF MACOS}
Check (UTF8String(UTF8String('.∑πê©îæ¬')), CurDir + DirSep + UTF8String(UTF8String('.∑πê©îæ¬')));
Check (UTF8String('..∑πê©îæ¬'), CurDir + DirSep + UTF8String('..∑πê©îæ¬'));
Check (UTF8String('∑πê©îæ¬..'), CurDir + DirSep + UTF8String('∑πê©îæ¬..'));
{$IFDEF AMIGA}
Check (UTF8String('∑πê©îæ¬.') + DirSep, CurDir);
{$ELSE AMIGA}
{$IFDEF MACOS}
Check (UTF8String('∑πê©îæ¬.') + DirSep, UTF8String('∑πê©îæ¬.') + DirSep);
{$ELSE MACOS}
Check (UTF8String('∑πê©îæ¬.') + DirSep, CurDir + DirSep + UTF8String('∑πê©îæ¬.') + DirSep);
{$ENDIF MACOS}
{$ENDIF AMIGA}
{$IFDEF MACOS}
Check (DirSep + DirSep, TestDir + TestDir1Name + DirSep);
Check (DirSep + DirSep + TestFileName, TestDir + TestDir1Name + DirSep
+ TestFileName);
{$ELSE MACOS}
Check (DirSep + UTF8String('.∑πê©îæ¬'), TestDrive + DirSep + UTF8String(UTF8String('.∑πê©îæ¬')));
{$IFNDEF NODOTS}
Check ('..', TestDir + TestDir1Name);
Check ('.' + DirSep + '..', TestDir + TestDir1Name);
Check ('..' + DirSep + '.', TestDir + TestDir1Name);
{$ENDIF NODOTS}
{$ENDIF MACOS}
{$IFDEF NETWARE}
Check ('...', TestDir);
{$ELSE NETWARE}
Check ('...', CurDir + DirSep + '...');
{$ENDIF NETWARE}
Check (TestFileName, CurDir + DirSep + TestFileName);
{$IFDEF UNIX}
S := GetEnvironmentVariable ('HOME');
{ On m68k netbsd at least, HOME contains a final slash
remove it PM }
if (Length (S) > 1) and (S [Length (S)] = DirSep) then
S:=Copy(S,1,Length(S)-1);
if Length (S) = 0 then
begin
Check ('~', CurDir);
Check ('~' + DirSep + '.', DirSep);
end
else
begin
Check ('~', S);
Check ('~' + DirSep + '.', S);
end;
if (Length (S) > 0) and (S [Length (S)] <> DirSep) then
S := S + DirSep;
Check (UTF8String('~ıœßodyWithThisNameShouldEverExist.test/nothinfl'), CurDir + DirSep +
UTF8String('~ıœßodyWithThisNameShouldEverExist.test/nothinfl'));
Check ('/tmp/~NoSº©hUse®Again', '/tmp/~NoSº©hUse®Again');
if Length (S) = 0 then
begin
Check ('~' + DirSep, DirSep);
Check ('~' + DirSep + '.' + DirSep, DirSep);
Check ('~' + DirSep + UTF8String('∂î®ê©†œ®Ú') + DirSep + UTF8String('anothe®'),
DirSep + UTF8String('∂î®ê©†œ®Ú') + DirSep + UTF8String('anothe®'));
end
else
begin
Check ('~' + DirSep, S);
Check ('~' + DirSep + '.' + DirSep, S);
Check ('~' + DirSep + UTF8String('∂î®ê©†œ®Ú') + DirSep + UTF8String('anothe®'),
S + UTF8String('∂î®ê©†œ®Ú') + DirSep + UTF8String('anothe®'));
end;
{$ELSE UNIX}
{$IFNDEF NODRIVEC}
Check (TestDrive + '..', TestDir + TestDir1Name);
Check (TestDrive + '..' + DirSep, TestDir + TestDir1Name + DirSep);
Check (TestDrive + '.' + DirSep + '.', CurDir);
Check (TestDrive + '.' + DirSep + '..', TestDir + TestDir1Name);
{$I-}
(*
{ $ ifndef unix }
{ avoid a and b drives for
no unix systems to reduce the
probablility of getting an alert message box }
{ This should not be needed - unit popuperr should solve this?! TH }
I := 3;
{$else unix} *)
I := 1;
{ $ endif unix}
repeat
S := '';
GetDir (I, S);
IOR := IOResult;
if IOR = 0 then Inc (I);
until (I > 26) or (IOR <> 0);
if I <= 26 then
begin
S := UTF8String(Chr (I + 64)) + UTF8String(':∂∂∂');
Check (S, UTF8String(Chr (I + 64)) + UTF8String(':') + DirSep + UTF8String('∂∂∂'));
end else
WriteLn ('Sorry, cannot test ExpandFileName behaviour for incorrect drives here.');
{$I+}
{$IFDEF FPC}
Check ('∆\∆/∆', CurDir + DirSep + UTF8String('∆') + DirSep + UTF8String('∆') + DirSep + UTF8String('∆'));
Check ('\\serve®\sha®e\di®ectory', '\\serve®\sha®e\di®ectory');
Check ('\\serve®\sha®e\directo®y1\directo®y2\..',
'\\serve®\sha®e\directo®y1');
Check ('\\', '\\');
Check ('\\.', '\\.\');
Check ('\\.\', '\\.\');
Check ('\\.\.', '\\.\.');
Check ('\\.\..', '\\.\..');
Check ('\\.\...', '\\.\...');
Check ('\\.\†êÒ™', '\\.\†êÒ™');
Check ('\\..\', '\\..\');
Check ('\\..\†êÒ™', '\\..\†êÒ™');
Check ('\\..\†êÒ™\.', '\\..\†êÒ™');
Check ('\\..\†êÒ™1\TÊ∑T2\..', '\\..\†êÒ™1');
Check ('\\..\†êÒ™\..', '\\..\†êÒ™');
Check ('\\..\†êÒ™\..\..', '\\..\†êÒ™');
{$ENDIF FPC}
{$ENDIF NODRIVEC}
{$ENDIF UNIX}
{$IFDEF VOLUMES}
Check (UTF8String('√olıame') + DriveSep + DirSep + UTF8String('∆ή1'), UTF8String('√olıame') + DriveSep + DirSep + UTF8String('∆ή1'));
{$IFNDEF NODOTS}
Check (UTF8String('√olıame') + DriveSep + DirSep + UTF8String('∆ή1') + DirSep + '..', UTF8String('√olıame') + DriveSep + DirSep);
Check (UTF8String('√olıame') + DriveSep + DirSep + UTF8String('∆ή1') + DirSep + '..' + DirSep + '..',
UTF8String('√olıame') + DriveSep + DirSep);
Check (UTF8String('√olıame') + DriveSep + DirSep + '.', UTF8String('√olıame:') + DirSep);
Check (UTF8String('√olıame') + DriveSep + DirSep + '..', UTF8String('√olıame:') + DirSep);
Check (UTF8String('√olıame') + DriveSep + DirSep + '..' + DirSep, UTF8String('√olıame') + DriveSep + DirSep);
{$ENDIF NODOTS}
{$IFDEF NETWARE}
Check (UTF8String('∑rvName\√olıame') + DriveSep + DirSep + UTF8String('†ĘŚ™'), UTF8String('∑rvName') + DirSep + UTF8String('√olıame') +
DriveSep + DirSep + UTF8String('†ĘŚ™'));
Check (UTF8String('∑rvName/√olıame') + DriveSep + DirSep + UTF8String('†ĘŚ™'), UTF8String('∑rvName') + DirSep + UTF8String('√olıame') +
DriveSep + DirSep + UTF8String('†ĘŚ™'));
{$ENDIF NETWARE}
{$IFDEF AMIGA}
{$IFDEF NODOTS}
Check ('.', CurDir + DirSep + '.');
{$ELSE NODOTS}
Check ('.', CurDir);
{$ENDIF NODOTS}
{$ENDIF AMIGA}
{$ENDIF VOLUMES}
Erase (F);
{$IFNDEF NODRIVEC}
ChDir (OrigTstDir);
{$ENDIF NODRIVEC}
end;
Function TestFexpand : AnsiString;
begin
Result:='';
{ ensure ExpandFileName doesn't lose data when the file system can represent all characters }
DefaultFileSystemCodePage:=CP_UTF8;
DefaultRTLFileSystemCodePage:=CP_UTF8;
{ ensure we do lose data if we somewhere accidentally use the default system code page
to perform operations }
DefaultSystemCodePage:=CP_ASCII;
if TestDir [Length (TestDir)] <> DirectorySeparator2 then
TestDir := TestDir + DirectorySeparator2;
GetDir (0, OrigDir);
{$IFDEF NODRIVEC}
TestDrive := '';
{$ELSE NODRIVEC}
TestDrive := Copy (TestDir, 1, 2);
GetDir ((Ord (TestDir [1]) and not ($20)) - 64, OrigTstDir);
{$ENDIF NODRIVEC}
{$I-}
MkDir (TestDir + TestDir1Name);
if IOResult <> 0 then ;
MkDir (TestDir + TestDir1Name + DirectorySeparator2 + TestDir2Name);
if IOResult <> 0 then ;
{$I+}
ChDir (TestDir + TestDir1Name + DirectorySeparator2 + TestDir2Name);
{$I-}
TestDir0 := TestDir;
try
Result:=DoTestFExpand;
finally
ChDir (OrigDir);
RmDir (TestDir0 + TestDir1Name + DirectorySeparator2 + TestDir2Name);
RmDir (TestDir0 + TestDir1Name);
end;
end;
Procedure GetTestDir;
Var
T : String;
begin
T:=SysGetSetting('fexpanddir');
if T='' then
{$IFDEF DIRECT}System.{$ENDIF DIRECT}GetDir (0,T);
if T='' then
T:='.';
TestDir:=T;
end;
begin
case GetSysTestOS of
'linux','freebsd','openbsd','netbsd','win32','win64','darwin','haiku','morphos':
begin
GetTestDir;
SysUtilsTest('TestFexpand',@TestFexpand);
end;
end;
end.

275
rtl/test/utffirst.pp
View File

@ -1,275 +0,0 @@
unit utffirst;
{$mode objfpc}
{$h+}
{$codepage utf8}
interface
uses
{$ifdef unix}
{$ifdef darwin}iosxwstr{$else}cwstring{$endif},
{$endif}
SysUtils;
implementation
uses punit, utrtl;
Function dotffirstutf8 : string;
const
FNAME = utf8string('adéfg');
var
f: thandle;
res: longint;
fnamecmp,
fsearch : utf8string;
rsr: TRawByteSearchRec;
begin
Result:='';
DeleteFile(FNAME);
f:=FileCreate(FNAME);
if f<=0 then
Exit('Cannot create file');
FileClose(f);
{ determine how the file system reports the name of the file (with the é
precomposed or decomposed) so we can pass the correct form to findfirst. We cannot
deal with this automatically in findfirst itself, because some OSes/file systems
allow both forms to coexist. }
if (findfirst('ad*fg',faAnyFile and not(faDirectory),rsr)<>0) then
Exit('Findfirst 1 did not return result')
else
begin
fnamecmp:=rsr.name;
findclose(rsr);
end;
fsearch:=fnamecmp;
fsearch[1]:='?';
res:=findfirst(fsearch,faAnyFile and not(faDirectory),rsr);
if Not AssertEquals('Findfirst 2: res',0,Res) then
exit;
if not AssertEquals('Findfirst 2 : name',fnamecmp,rsr.name) then
begin
findclose(rsr);
exit;
end;
fsearch:=fnamecmp;
fsearch[2]:='?';
if (findfirst(fsearch,faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 3 failed')
else
findclose(rsr);
{ must succeed regardless of whether the é is decomposed or not }
if (findfirst('ad?fg',faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 4 failed')
else
findclose(rsr);
{ this should succeed if if the the é is decomposed (at least "ls ade?fg" succeeds
on Mac OS X) }
if (fnamecmp[3]='e') then
if (findfirst('ade?fg',faAnyFile and not(faDirectory),rsr)<>0) then
Exit('FindFirst 5')
else
findclose(rsr);
fsearch:=fnamecmp;
fsearch[length(fsearch)-1]:='?';
if (findfirst(fsearch,faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 6')
else
findclose(rsr);
fsearch:=fnamecmp;
fsearch[length(fsearch)]:='?';
if (findfirst(fsearch,faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 7')
else
findclose(rsr);
if (findfirst('a*fg',faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 8')
else
findclose(rsr);
if (findfirst('ad*',faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 9')
else
findclose(rsr);
fsearch:=fnamecmp;
fsearch[length(fsearch)-1]:='*';
if (findfirst(fsearch,faAnyFile and not(faDirectory),rsr)<>0) or
(rsr.name<>fnamecmp) then
Exit('FindFirst 10')
else
findclose(rsr);
end;
Function tffirstutf8 : string;
const
FNAME = utf8string('adéfg');
Var
curdir: utf8string;
begin
RemoveDir('tffdir');
if not DirectoryExists('tffdir') then
if not CreateDir('tffdir') then
exit('Failed to create test dir tffdir');
curdir:=utf8string(GetCurrentDir);
if not SetCurrentDir('tffdir') then
Exit('Cannot chdir to test dir');
Result:=dotffirstutf8;
DeleteFile(FNAME);
SetCurrentDir(curdir);
RemoveDir('tffdir');
end;
Function dotffirstutf16 : string;
const
FNAME = unicodestring('adéfg');
var
f: thandle;
res: longint;
fnamecmp,
fsearch,
curdir: unicodestring;
usr: TUnicodeSearchRec;
begin
DeleteFile(FNAME);
f:=FileCreate(FNAME);
if f<=0 then
Exit('Failed to create file');
FileClose(f);
{ determine how the file system reports the name of the file (with the é
precomposed or decomposed) so we can pass the correct form to findfirst. We cannot
deal with this automatically in findfirst itself, because some OSes/file systems
allow both forms to coexist. }
if (findfirst('ad*fg',faAnyFile and not(faDirectory),usr)<>0) then
Exit('Failed at 11')
else
begin
fnamecmp:=usr.name;
findclose(usr);
end;
fsearch:=fnamecmp;
fsearch[1]:='?';
res:=findfirst(fsearch,faAnyFile and not(faDirectory),usr);
if Not AssertEquals('Findfirst 2 res',0,Res) then exit;
if Not AssertEquals('Findfirst 2 name',fnamecmp,usr.name) then
begin
findClose(usr);
exit;
end;
findclose(usr);
fsearch:=fnamecmp;
fsearch[2]:='?';
if (findfirst(fsearch,faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 13')
else
findclose(usr);
{ must succeed regardless of whether the é is decomposed or not }
if (findfirst('ad?fg',faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 14')
else
findclose(usr);
{ this should succeed if if the the é is decomposed (at least "ls ade?fg" succeeds
on Mac OS X) }
if (fnamecmp[3]='e') then
if (findfirst('ade?fg',faAnyFile and not(faDirectory),usr)<>0) then
Exit('Failed at 15')
else
findclose(usr);
fsearch:=fnamecmp;
fsearch[length(fsearch)-1]:='?';
if (findfirst(fsearch,faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 16')
else
findclose(usr);
fsearch:=fnamecmp;
fsearch[length(fsearch)]:='?';
if (findfirst(fsearch,faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 17')
else
findclose(usr);
if (findfirst('a*fg',faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 18')
else
findclose(usr);
if (findfirst('ad*',faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 19')
else
findclose(usr);
fsearch:=fnamecmp;
fsearch[length(fsearch)-1]:='*';
if (findfirst(fsearch,faAnyFile and not(faDirectory),usr)<>0) or
(usr.name<>fnamecmp) then
Exit('Failed at 20')
else
findclose(usr);
end;
Function tffirstutf16 : string;
const
FNAME = unicodestring('adéfg');
Var
curdir: utf8string;
begin
RemoveDir('tffdir');
if not DirectoryExists('tffdir') then
if not CreateDir('tffdir') then
exit('Failed to create test dir tffdir');
curdir:=utf8string(GetCurrentDir);
if not SetCurrentDir('tffdir') then
Exit('Cannot chdir to test dir');
Result:=Dotffirstutf16;
DeleteFile(FNAME);
SetCurrentDir(curdir);
RemoveDir('tffdir');
end;
begin
Case GetSysTestOS of
'linux','freebsd','openbsd','netbsd','win32','win64','darwin','haiku','morphos' :
begin
SysutilsTest('TestFFirstUtf8',@tffirstutf8);
SysutilsTest('TestFFirstUtf16',@tffirstutf16);
end;
end;
end.

222
rtl/test/utfile.pp
View File

@ -1,222 +0,0 @@
unit utfile;
{$mode objfpc}
{$h+}
interface
uses
SysUtils;
Implementation
uses punit, utrtl;
Function File1 : String;
var
l,l2: longint;
begin
try
try
l:=filecreate('tfile2.dat');
if (l<0) then
FailExit('unable to create file');
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread);
if (filewrite(l,l,sizeof(l))>0) then
FailExit('writing to read-only file succeeded');
fileclose(l);
deletefile('tfile2.dat');
l:=filecreate('tfile2.dat');
if (l<0) then
FailExit('unable to create file (2)');
fileclose(l);
l:=fileopen('tfile2.dat',fmopenwrite);
if (filewrite(l,l,sizeof(l))<>sizeof(l)) then
FailExit('writing to write-only file failed');
if (fileseek(l,0,fsFromBeginning)<>0) then
FailExit('seeking write-only file failed');
if (fileread(l,l2,sizeof(l))>=0) then
FailExit('reading from write-only file succeeded');
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l<0) then
FailExit('unable to open file in read-only mode and fmShareDenyWrite mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 < 0) then
FailExit('opening two files as read-only with fmShareDenyWrite failed');
fileclose(l2);
l2:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening file first as read-only with fmShareDenyWrite, and then again as fmopenread with fmShareExclusive succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenwrite or fmShareExclusive);
if (l<0) then
FailExit('unable to open file in write-only and fmShareExclusive mode');
l2:=fileopen('tfile2.dat',fmopenwrite or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening two files as write-only with fmShareExclusive succeeded');
end;
l2:=fileopen('tfile2.dat',fmopenwrite or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening file first as write-only with fmShareExclusive, and then again as fmopenwrite with fmShareDenyWrite succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l<0) then
FailExit('unable to open file in read-only and fmShareExclusive mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening two files as read-only with fmShareExclusive succeeded');
end;
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening file first as read-only with fmShareExclusive, and then again as fmopenread with fmShareDenyWrite succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread);
if (l<0) then
FailExit('unable to open file in read-only mode (2)');
l2:=fileopen('tfile2.dat',fmopenread);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening two files as read-only without sharing specified succeeded (should not, file is by default locked)');
end;
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening two files as read-only with fmShareDenyWrite succeeded (should not, file is by default locked)');
end;
fileclose(l);
{ should be same as no locking specified }
l:=fileopen('tfile2.dat',fmopenread or fmShareCompat);
if (l<0) then
FailExit('unable to open file in read-only mode (3)');
l2:=fileopen('tfile2.dat',fmopenread or fmShareCompat);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening two files as read-only with fmShareCompat succeeded (should be locked)');
end;
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening file first as read-only fmShareCompat (should not have any effect), and then again as fmopenread with fmShareDenyWrite succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l<0) then
FailExit('unable to open file in read-only mode and fmShareDenyNone mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l2 < 0) then
FailExit('opening two files as read-only with fmShareDenyNone failed');
fileclose(l2);
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 < 0) then
FailExit('opening two files as read-only with fmShareDenyNone and then fmShareDenyWrite failed');
fileclose(l2);
{ on Windows, fmShareExclusive checks whether the file is already open in any way by the current
or another process. On Unix, that is not the case, and we also cannot check against a
fmShareDenyNone mode
}
{$ifndef unix}
l2:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
FailExit('opening two files as read-only with fmShareDenyNone and then fmShareExclusive succeeded');
end;
{$endif}
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l<0) then
FailExit('unable to open file in read-only mode and fmShareDenyWrite mode (2)');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l2 < 0) then
FailExit('opening files as read-only with fmShareDenyWrite and then fmShareDenyNone failed');
fileclose(l2);
fileclose(l);
l:=fileopen('tfile2.dat',fmopenwrite or fmShareDenyNone);
if (l<0) then
FailExit('unable to open file in write-only mode and fmShareDenyNone mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l2 < 0) then
FailExit('opening two files as read/write-only with fmShareDenyNone failed');
fileclose(l2);
except
on e: exception do
begin
writeln(e.message);
exitcode:=1;
end;
end;
finally
if (l>=0) then
fileclose(l);
deletefile('tfile2.dat');
end;
end;
Function file2 : string;
VAR
dateTime: TDateTime;
f : file;
BEGIN
if FileExists('datetest.dat') then
begin
Assign(f,'datetest.dat');
Erase(f);
end;
if FileExists('datetest.dat') then
Exit('Error at 1000');
FileClose(FileCreate('datetest.dat'));
if not(FileExists('datetest.dat')) then
Exit('Error at 1001');
dateTime := IncMonth(Now, -1);
if FileSetDate('datetest.dat', DateTimeToFileDate(dateTime))<>0 then
Exit('Error at 1002');
if FileExists('datetest.dat') then
begin
Assign(f,'datetest.dat');
Erase(f);
end;
end;
begin
SysutilsTest('tfile1',@file1);
SysutilsTest('tfile2',@file2);
end.

40
rtl/test/utfile1.pp
View File

@ -1,40 +0,0 @@
PROGRAM Test;
USES
SysUtils;
procedure do_error(l : longint);
begin
writeln('Error near number ',l);
halt(1);
end;
VAR
dateTime: TDateTime;
f : file;
BEGIN
if FileExists('datetest.dat') then
begin
Assign(f,'datetest.dat');
Erase(f);
end;
if FileExists('datetest.dat') then
do_error(1000);
FileClose(FileCreate('datetest.dat'));
if not(FileExists('datetest.dat')) then
do_error(1001);
dateTime := IncMonth(Now, -1);
if FileSetDate('datetest.dat', DateTimeToFileDate(dateTime))<>0 then
do_error(1002);
if FileExists('datetest.dat') then
begin
Assign(f,'datetest.dat');
Erase(f);
end;
END.

188
rtl/test/utfile2.pp
View File

@ -1,188 +0,0 @@
{$ifdef fpc}
{$mode objfpc}
{$h+}
{$endif}
uses
SysUtils;
{$ifndef fpc}
const
fmsharecompat = cardinal(0);
fsFromBeginning = cardinal(0);
{$endif}
var
l,l2: longint;
begin
try
try
l:=filecreate('tfile2.dat');
if (l<0) then
raise exception.create('unable to create file');
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread);
if (filewrite(l,l,sizeof(l))>0) then
raise exception.create('writing to read-only file succeeded');
fileclose(l);
deletefile('tfile2.dat');
l:=filecreate('tfile2.dat');
if (l<0) then
raise exception.create('unable to create file (2)');
fileclose(l);
l:=fileopen('tfile2.dat',fmopenwrite);
if (filewrite(l,l,sizeof(l))<>sizeof(l)) then
raise exception.create('writing to write-only file failed');
if (fileseek(l,0,fsFromBeginning)<>0) then
raise exception.create('seeking write-only file failed');
if (fileread(l,l2,sizeof(l))>=0) then
raise exception.create('reading from write-only file succeeded');
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l<0) then
raise exception.create('unable to open file in read-only mode and fmShareDenyWrite mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 < 0) then
raise exception.create('opening two files as read-only with fmShareDenyWrite failed');
fileclose(l2);
l2:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening file first as read-only with fmShareDenyWrite, and then again as fmopenread with fmShareExclusive succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenwrite or fmShareExclusive);
if (l<0) then
raise exception.create('unable to open file in write-only and fmShareExclusive mode');
l2:=fileopen('tfile2.dat',fmopenwrite or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening two files as write-only with fmShareExclusive succeeded');
end;
l2:=fileopen('tfile2.dat',fmopenwrite or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening file first as write-only with fmShareExclusive, and then again as fmopenwrite with fmShareDenyWrite succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l<0) then
raise exception.create('unable to open file in read-only and fmShareExclusive mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening two files as read-only with fmShareExclusive succeeded');
end;
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening file first as read-only with fmShareExclusive, and then again as fmopenread with fmShareDenyWrite succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread);
if (l<0) then
raise exception.create('unable to open file in read-only mode (2)');
l2:=fileopen('tfile2.dat',fmopenread);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening two files as read-only without sharing specified succeeded (should not, file is by default locked)');
end;
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening two files as read-only with fmShareDenyWrite succeeded (should not, file is by default locked)');
end;
fileclose(l);
{ should be same as no locking specified }
l:=fileopen('tfile2.dat',fmopenread or fmShareCompat);
if (l<0) then
raise exception.create('unable to open file in read-only mode (3)');
l2:=fileopen('tfile2.dat',fmopenread or fmShareCompat);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening two files as read-only with fmShareCompat succeeded (should be locked)');
end;
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening file first as read-only fmShareCompat (should not have any effect), and then again as fmopenread with fmShareDenyWrite succeeded');
end;
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l<0) then
raise exception.create('unable to open file in read-only mode and fmShareDenyNone mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l2 < 0) then
raise exception.create('opening two files as read-only with fmShareDenyNone failed');
fileclose(l2);
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l2 < 0) then
raise exception.create('opening two files as read-only with fmShareDenyNone and then fmShareDenyWrite failed');
fileclose(l2);
{ on Windows, fmShareExclusive checks whether the file is already open in any way by the current
or another process. On Unix, that is not the case, and we also cannot check against a
fmShareDenyNone mode
}
{$ifndef unix}
l2:=fileopen('tfile2.dat',fmopenread or fmShareExclusive);
if (l2 >= 0) then
begin
fileclose(l2);
raise exception.create('opening two files as read-only with fmShareDenyNone and then fmShareExclusive succeeded');
end;
{$endif}
fileclose(l);
l:=fileopen('tfile2.dat',fmopenread or fmShareDenyWrite);
if (l<0) then
raise exception.create('unable to open file in read-only mode and fmShareDenyWrite mode (2)');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l2 < 0) then
raise exception.create('opening files as read-only with fmShareDenyWrite and then fmShareDenyNone failed');
fileclose(l2);
fileclose(l);
l:=fileopen('tfile2.dat',fmopenwrite or fmShareDenyNone);
if (l<0) then
raise exception.create('unable to open file in write-only mode and fmShareDenyNone mode');
l2:=fileopen('tfile2.dat',fmopenread or fmShareDenyNone);
if (l2 < 0) then
raise exception.create('opening two files as read/write-only with fmShareDenyNone failed');
fileclose(l2);
except
on e: exception do
begin
writeln(e.message);
exitcode:=1;
end;
end;
finally
if (l>=0) then
fileclose(l);
deletefile('tfile2.dat');
end;
end.

120
rtl/test/utfilename.pp
View File

@ -1,120 +0,0 @@
unit utfilename;
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}
interface
uses
SysUtils;
implementation
uses punit, utrtl;
Function TestFuncs(testidx:integer;const res,expected: string) : Boolean;
begin
Result:=AssertEquals('Failure at '+IntToStr(TestIdx),expected,res);
end;
Function TestFileName : String;
begin
Result:='';
// Default Unix
AllowDirectorySeparators:=['/','\'];
AllowDriveSeparators:=[];
If not TestFuncs(1,ExtractFilePath('./:'),'./') then exit;
If not TestFuncs(2,ExtractFileName('./:'),':') then exit;
If not TestFuncs(3,ExtractFileDrive('./:'),'') then exit;
If not TestFuncs(4,ExtractFilePath('C:/blah:blah'),'C:/') then exit;
If not TestFuncs(5,ExtractFileName('C:/blah:blah'),'blah:blah') then exit;
If not TestFuncs(6,ExtractFileDrive('C:/blah:blah'),'') then exit;
If not TestFuncs(7,ExtractFilePath('./\'),'./\') then exit;
If not TestFuncs(8,ExtractFileName('./\'),'') then exit;
If not TestFuncs(9,ExtractFileDrive('./\'),'') then exit;
If not TestFuncs(10,ExtractFilePath('./c:'),'./') then exit;
If not TestFuncs(11,ExtractFileName('./c:'),'c:') then exit;
If not TestFuncs(12,ExtractFileDrive('./c:'),'') then exit;
If not TestFuncs(13,ExtractFilePath('\\server\share\file'),'\\server\share\') then exit;
If not TestFuncs(14,ExtractFileName('\\server\share\file'),'file') then exit;
If not TestFuncs(15,ExtractFileDrive('\\server\share\file'),'\\server\share') then exit;
// Kylix compatibility mode
AllowDirectorySeparators:=['/'];
AllowDriveSeparators:=[];
If not TestFuncs(101,ExtractFilePath('./:'),'./') then exit;
If not TestFuncs(102,ExtractFileName('./:'),':') then exit;
If not TestFuncs(103,ExtractFileDrive('./:'),'') then exit;
If not TestFuncs(104,ExtractFilePath('C:/blah:blah'),'C:/') then exit;
If not TestFuncs(105,ExtractFileName('C:/blah:blah'),'blah:blah') then exit;
If not TestFuncs(106,ExtractFileDrive('C:/blah:blah'),'') then exit;
If not TestFuncs(107,ExtractFilePath('./\'),'./') then exit;
If not TestFuncs(108,ExtractFileName('./\'),'\') then exit;
If not TestFuncs(109,ExtractFileDrive('./\'),'') then exit;
If not TestFuncs(110,ExtractFilePath('./c:'),'./') then exit;
If not TestFuncs(111,ExtractFileName('./c:'),'c:') then exit;
If not TestFuncs(112,ExtractFileDrive('./c:'),'') then exit;
If not TestFuncs(113,ExtractFilePath('\\server\share\file'),'') then exit;
If not TestFuncs(114,ExtractFileName('\\server\share\file'),'\\server\share\file') then exit;
If not TestFuncs(115,ExtractFileDrive('\\server\share\file'),'') then exit;
// Default Windows/DOS/SO2
AllowDirectorySeparators:=['/','\'];
AllowDriveSeparators:=[':'];
If not TestFuncs(201,ExtractFilePath('./:'),'./:') then exit;
If not TestFuncs(202,ExtractFileName('./:'),'') then exit;
If not TestFuncs(203,ExtractFileDrive('./:'),'') then exit;
If not TestFuncs(204,ExtractFilePath('C:/blah:blah'),'C:/blah:') then exit;
If not TestFuncs(205,ExtractFileName('C:/blah:blah'),'blah') then exit;
If not TestFuncs(206,ExtractFileDrive('C:/blah:blah'),'C:') then exit;
If not TestFuncs(207,ExtractFilePath('./\'),'./\') then exit;
If not TestFuncs(208,ExtractFileName('./\'),'') then exit;
If not TestFuncs(209,ExtractFileDrive('./\'),'') then exit;
If not TestFuncs(210,ExtractFilePath('./c:'),'./c:') then exit;
If not TestFuncs(211,ExtractFileName('./c:'),'') then exit;
If not TestFuncs(212,ExtractFileDrive('./c:'),'') then exit;
If not TestFuncs(213,ExtractFilePath('\\server\share\file'),'\\server\share\') then exit;
If not TestFuncs(214,ExtractFileName('\\server\share\file'),'file') then exit;
If not TestFuncs(215,ExtractFileDrive('\\server\share\file'),'\\server\share') then exit;
// Windows/DOS/SO2 Delphi Compatibility
AllowDirectorySeparators:=['\'];
AllowDriveSeparators:=[':'];
If not TestFuncs(301,ExtractFilePath('./:'),'./:') then exit;
If not TestFuncs(302,ExtractFileName('./:'),'') then exit;
If not TestFuncs(303,ExtractFileDrive('./:'),'') then exit;
If not TestFuncs(304,ExtractFilePath('C:/blah:blah'),'C:/blah:') then exit;
If not TestFuncs(305,ExtractFileName('C:/blah:blah'),'blah') then exit;
If not TestFuncs(306,ExtractFileDrive('C:/blah:blah'),'C:') then exit;
If not TestFuncs(307,ExtractFilePath('./\'),'./\') then exit;
If not TestFuncs(308,ExtractFileName('./\'),'') then exit;
If not TestFuncs(309,ExtractFileDrive('./\'),'') then exit;
If not TestFuncs(310,ExtractFilePath('./c:'),'./c:') then exit;
If not TestFuncs(311,ExtractFileName('./c:'),'') then exit;
If not TestFuncs(312,ExtractFileDrive('./c:'),'') then exit;
If not TestFuncs(313,ExtractFilePath('\\server\share\file'),'\\server\share\') then exit;
If not TestFuncs(314,ExtractFileName('\\server\share\file'),'file') then exit;
If not TestFuncs(315,ExtractFileDrive('\\server\share\file'),'\\server\share') then exit;
end;
begin
SysutilsTest('TestFileName',@TestFileName);
end.

226
rtl/test/utfloattostr.pp
View File

@ -1,226 +0,0 @@
unit utfloattostr;
{$mode objfpc}
{$h+}
interface
{ Test for FloatToStr and CurrToStr functions. }
uses sysutils;
implementation
uses punit, utrtl;
const
MaxCurrency : currency = 922337203685477.5807;
MinCurrency : currency = -922337203685477.5807;
var
ErrCount: longint;
Function CheckVal(nr,step,cycle : Integer; f: Extended) : Boolean;
var
s,v1,v2,tn: string;
f1: Extended;
begin
TN:='Cycle nr '+intToStr(Nr)+' step :'+INtToStr(Step)+' cycle : '+IntToStr(Cycle)+' : ';
Result:=True;
s := FloatToStr(f);
f1 := StrToFloat(s);
if (f<>f1) and (Abs(f-f1)/Abs(f) > 6e-15) then
begin
Str(Abs(f-f1)/Abs(f),v1);
Str(f,V2);
Fail(TN+'Error (Double):'+V1+ ' Input:'+V2+' Output:'+s);
Exit(False);
end;
f := Single(f);
s := FloatToStr(Single(f));
f1 := StrToFloat(s);
if (f<>f1) and (Abs(f-f1)/Abs(f) > 6e-10) then
begin
Str(Abs(f-f1)/Abs(f),v1);
Str(f,V2);
Fail(TN+'Error (Single):'+V1+ ' Input:'+v2+' Output:'+s);
Exit(False);
end;
end;
Function Cycle(nr,step : Integer; f: Extended) : Boolean;
var
i: Integer;
begin
Result:=True;
for i := 1 to 50 do
begin
if not CheckVal(nr,step,i,f) then exit(False);
if not CheckVal(nr,step,i,-f) then exit(False);
f := f/10;
end;
end;
Function CycleInc(Nr : Integer; f, increment: Extended) : Boolean;
var
i: Integer;
begin
Result:=True;
if not Cycle(NR,-1,f) then Exit(False);
for i := 0 to 30 do
begin
if not Cycle(Nr,I,f+increment) then exit(False);
if not Cycle(Nr,I,f-increment) then exit(False);
increment := increment/10;
end;
end;
Function CheckResult(Nr : Integer; const s, ref: string) : Boolean;
begin
Result:=AssertEquals('Test '+IntToStr(Nr),Ref,S);
end;
Function TestFloatToStr : String;
var
e: extended;
d: double;
s: single;
c: currency;
i: Integer;
tests: array [0..4] of Double = (123456789123456789., 1e20, 1.6e20, 5e20, 9e20);
CS,DSep,TSep : String;
begin
Result:='';
DSep:=DefaultFormatSettings.DecimalSeparator;
TSep:=DefaultFormatSettings.ThousandSeparator;
e:=1234567890123.4;
d:=12345.12345;
s:=12345.12;
c:=12345.1234;
if not CheckResult(1,FloatToStrF(e,ffExponent,15,1), '1'+DSep+'23456789012340E+12') then exit;
If not CheckResult(2,FloatToStrF(d,ffExponent,11,0), '1'+DSep+'2345123450E+4') then exit;
If not CheckResult(3,FloatToStrF(s,ffExponent,8,0), '1'+DSep+'2345120E+4') then exit;
If not CheckResult(4,FloatToStrF(s,ffExponent,8,7), '1'+DSep+'2345120E+0004') then exit;
If not CheckResult(5,FloatToStrF(e,ffExponent,8,3), '1'+DSep+'2345679E+012') then exit;
If not CheckResult(6,FloatToStrF(c,ffExponent,10,0), '1'+DSep+'234512340E+4') then exit;
If not CheckResult(7,FloatToStrF(c,ffExponent,11,2), '1'+DSep+'2345123400E+04') then exit;
If not CheckResult(8,FloatToStrF(c,ffExponent,10,4), '1'+DSep+'234512340E+0004') then exit;
If not CheckResult(9,FloatToStrF(-12345.12345,ffExponent,11,0), '-1'+DSep+'2345123450E+4') then exit;
If not CheckResult(10,FloatToStrF(-0.00000123,ffGeneral,15,0), '-1'+DSep+'23E-6') then exit;
If not CheckResult(11,FloatToStrF(-12345.12345,ffGeneral,7,0), '-12345'+DSep+'12') then exit;
If not CheckResult(12,CurrToStr(-12345.1234), '-12345'+DSep+'1234') then exit;
If not CheckResult(13,CurrToStr(MaxCurrency), '922337203685477'+DSep+'5807') then exit;
If not CheckResult(14,CurrToStr(MinCurrency), '-922337203685477'+DSep+'5807') then exit;
DefaultFormatSettings.NegCurrFormat:=8;
CS:=DefaultFormatSettings.CurrencyString;
If not CheckResult(15,FloatToStrF(-12345.1234,ffCurrency,19,4), '-12' + TSep + '345'+DSep+'1234 ' + CS) then exit;
If not CheckResult(16,FloatToStrF(MinCurrency,ffCurrency,19,4), '-922' + TSep + '337' + TSep + '203' + Tsep + '685' + Tsep + '477'+DSep+'5807 ' + CS) then exit;
for i := 0 to High(tests) do
begin
e := tests[i];
if not CycleInc(I*10+1,e,1e20) then exit;
if not CycleInc(I*10+2,e,9e20) then exit;
if not CycleInc(I*10+3,e,e) then exit;
if not CycleInc(I*10+3,e,e/2) then exit;
if not CycleInc(I*10+3,e,e/3) then exit;
end;
end;
Function TestFormatFloat : TTestString;
Var
CT : Integer;
Function Check(aCount : Integer; AExpected,AActual : String): Boolean;
begin
Result:=AssertEquals('Check '+IntToStr(aCount),AExpected,AActual);
CT:=aCount;
end;
function TestIt(CR : Extended; Fmt,Expected : String) : Boolean;
begin
Result:=Check(CT+1,Expected,FormatFloat(Fmt,CR));
end;
begin
Result:='';
DefaultFormatSettings.ThousandSeparator:=',';
DefaultFormatSettings.DecimalSeparator:='.';
if not Check(1,'1.23',FormatFloat('#.##',1.23)) then exit;
If not Check(3,'1.23',FormatFloat('0.##',1.23)) then exit;
If not Check(5,'1.23',FormatFloat('#.0#',1.23)) then exit;
If not Check(7,'1.2',FormatFloat('#.0#',1.2)) then exit;
If not Check(9,'1.23',FormatFloat('0.0#',1.23)) then exit;
If not Check(11,'1.23',FormatFloat('0.00',1.23)) then exit;
If not Check(11,'001.23',FormatFloat('000.00',1.23)) then exit;
If not Check(13,'1.20',FormatFloat('0.00',1.2)) then exit;
If not Check(14,'1235',FormatFloat('#####',1234.567)) then exit;
If not Check(15,'01235',FormatFloat('00000',1234.567)) then exit;
If not Check(16,'1235',FormatFloat('0',1234.567)) then exit;
If not Check(17,'1,235',FormatFloat('#,##0',1234.567)) then exit;
If not Check(18,'1,235',FormatFloat(',0',1234.567)) then exit;
// Include the decimal value
If not Check(19,'1234.567',FormatFloat('0.####', 1234.567)) then exit;
If not Check(20,'1234.5670',FormatFloat('0.0000', 1234.567)) then exit;
// IsScientific format
If not Check(22,'1.2345670E+03',FormatFloat('0.0000000E+00', 1234.567)) then exit;
If not Check(23,'1.2345670E03',FormatFloat('0.0000000E-00', 1234.567)) then exit;
If not Check(24,'1.234567E3',FormatFloat('#.#######E-##', 1234.567)) then exit;
// Include freeform text
If not Check(25,'Value = 1234.6',FormatFloat('"Value = "0.0', 1234.567)) then exit;
// Different formatting for negative numbers
If not Check(26,'-1234.6',FormatFloat('0.0', -1234.567)) then exit;
If not Check(27,'1234.6 DB',FormatFloat('0.0 "CR";0.0 "DB"', -1234.567)) then exit;
If not Check(28,'1234.6 CR',FormatFloat('0.0 "CR";0.0 "DB"', 1234.567)) then exit;
// Different format for zero value
If not Check(29,'0.0',FormatFloat('0.0', 0.0)) then exit;
If not Check(30,'Nothing',FormatFloat('0.0;-0.0;"Nothing"', 0.0)) then exit;
If not Check(-30,'Nothing',formatfloat('0.0;-0.0;"Nothing"', 0.0)) then exit;
// Thousand separators
// bug 30950
If not Check(31,'449,888.06',FormatFloat('#,###,##0.00', 449888.06)) then exit;
// Bug 29781
If not Check(32,'2,222.00',FormatFloat('###,##0.00', 2222.0)) then exit;
// tw10519
if not check(33, '5.22480E+0004', FormatFloat('0.00000E+0000',52247.9532745)) then exit;
// tw11711
if not check(34,'-001.000',formatFloat('000.000',-1)) then exit;
// tw13552
DefaultFormatSettings.ThousandSeparator:=#0;
if not Check(35,'1000.00',formatfloat('#,0.00',1000.0)) then exit;
DefaultFormatSettings.ThousandSeparator:=',';
// tw15308
if not Check(36,'1.0500E+002',formatFloat('0.0000E+000', 1.05e2)) then exit;
if not Check(37,'1.0600E+002',formatFloat('0.0000E+000', 1.06e2)) then exit;
// tw 12385
If not Testit(1234.567,'00000000.00','00001234.57') then exit;
If not Testit(-1234.567,'00000000.00','-00001234.57') then exit;
If not Testit(-1234.567,'000.00','-1234.57') then exit;
If not Testit(-1,'000.000','-001.000') then exit;
If not Testit(-80,'#,##0.00','-80.00') then exit;
If not Testit(-140,'#,##0.00','-140.00') then exit;
If not Testit(140,'#,##0.00','140.00') then exit;
If not Testit(80,'#,##0.00','80.00') then exit;
If not Testit(-2.45,'#,##0.00','-2.45') then exit;
If not Testit(-1400,'#,##0.00','-1,400.00') then exit;
If not Testit(-1400,'##,##0.00','-1,400.00') then exit;
// tw13076
if not TestIt(-10,'###,###,##0.00','-10.00') then exit;
end;
begin
SysutilsTest('testfloattostr',@TestFloatToStr);
SysutilsTest('TestFormatFloat',@TestFormatFloat);
end.

23
rtl/test/utformat.pp
View File

@ -1,23 +0,0 @@
unit utformat;
{$mode objfpc}{$h+}
interface
uses sysutils;
implementation
uses punit, utrtl;
function testformat : string;
begin
Result:='';
if not AssertEquals('Test 1','> def<', format('>%1:*s<',[0, 12,'def',-15])) then exit;
if not AssertEquals('Test 2','> abc< > def<',format('>%1:*s< >%*s<', [0, 12, 'abc', 10, 'def'])) then exit;
if not AssertEquals('Test 3','> abc< > def<',format('>%1:*.*s< >%*.*s<', [0, 10,10,'abc', 6,6,'def'])) then exit;
end;
begin
SysutilsTest('format',@testformat);
end.

75
rtl/test/utfsearch.pp
View File

@ -1,75 +0,0 @@
{
This file is part of the Free Pascal test suite.
Copyright (c) 1999-2003 by the Free Pascal development team.
Test for possible bugs in Dos.FSearch
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
unit utfsearch;
interface
uses punit, utrtl;
implementation
uses
Dos;
const
TestDir: string = 'TESTDIR';
TestFile: string = 'testfile';
{$IFDEF MACOS}
RelPathPrefix = ':';
{$ELSE}
RelPathPrefix = '';
{$ENDIF}
Function DoTestFSearch : TTestString;
var
R,S: string;
F: file;
begin
Result:='';
S := FSearch (TestDir, '');
If not AssertEquals('FSearch should only find files, not directories!!','',S) then exit;
// Create test file
Assign (F, RelPathPrefix + TestDir + DirectorySeparator + TestFile);
Rewrite (F);
Close (F);
S:=FSearch (TestFile, TestDir);
// expected result
R:=RelPathPrefix + TestDir + DirectorySeparator + TestFile;
If not AssertEquals('FSearch didn''t find the test file!!',R,S) then exit;
end;
Function TestFSearch : TTestString;
var
F: file;
begin
MkDir (TestDir);
Result:=DoTestFSearch;
// Clean up
{$i-}
Assign (F, RelPathPrefix + TestDir + DirectorySeparator + TestFile);
Erase (F);
RmDir (TestDir);
{$i+}
end;
begin
AddTest('TestFSearch',@TestFsearch,EnsureSuite('Dos'));
end.

19
rtl/test/utmath.pp
View File

@ -1,19 +0,0 @@
unit utmath;
interface
uses punit, utrtl;
implementation
uses math;
Function TestFMod : TTestString;
Begin
Result:='';
end;
Begin
AddTest('TestFMod',@TestFMod,EnsureSuite('Math'));
end.

51
rtl/test/utrtl.pp
View File

@ -1,51 +0,0 @@
unit utrtl;
{$mode objfpc}
interface
uses punit;
Function SysUtilsTest(Const ATestName : ShortString; ARun : TTestRun) : PTest;
Function DosTest(Const ATestName : ShortString; ARun : TTestRun) : PTest;
Function EnsureSuite(Const AName : ShortString) : PSuite;
Function ShowDebugOutput : Boolean;
implementation
function DosTest(const ATestName: ShortString; ARun: TTestRun): PTest;
begin
Result:=AddTest(ATestName,ARun,EnsureSuite('Dos'));
end;
Function EnsureSuite(Const AName : ShortString) : PSuite;
begin
Result:=GetSuite(AName);
if Result=Nil then
Result:=AddSuite(AName);
end;
Function SysUtilsTest(Const ATestName : ShortString; ARun : TTestRun) : PTest;
begin
Result:=AddTest(ATestName,ARun,EnsureSuite('SysUtils'));
end;
Var
ReadDebug : Boolean;
ShowDebug : Boolean;
function ShowDebugOutput: Boolean;
begin
if Not ReadDebug then
begin
ReadDebug:=True;
ShowDebug:=SysGetSetting('debug')='true';
end;
Result:=ShowDebug;
end;
end.

222
rtl/test/utrwsync.pp
View File

@ -1,222 +0,0 @@
unit utrwsync;
{$ifdef fpc}
{$mode objfpc}
{$h+}
{$endif}
interface
uses
{$ifdef unix}
cthreads,
{$endif}
SysUtils, Classes;
implementation
uses punit, utrtl;
var
lock: TMultiReadExclusiveWriteSynchronizer;
gcount: longint;
waiting: boolean;
errorstring : string;
type
terrorcheck = class(tthread)
procedure execute; override;
end;
tcounter = class(tthread)
private
flock: TMultiReadExclusiveWriteSynchronizer;
flocalcount: longint;
public
constructor create;
property localcount: longint read flocalcount;
end;
treadcounter = class(tcounter)
procedure execute; override;
end;
twritecounter = class(tcounter)
procedure execute; override;
end;
constructor tcounter.create;
begin
{ create suspended }
inherited create(true);
freeonterminate:=false;
flock:=lock;
flocalcount:=0;
end;
procedure treadcounter.execute;
var
i: longint;
l: longint;
r: longint;
begin
for i:=1 to 100000 do
begin
lock.beginread;
inc(flocalcount);
l:=gcount;
{ guarantee at least one sleep }
if i=50000 then
sleep(20+random(30))
else if (random(10000)=0) then
sleep(20);
{ this must cause data races/loss at some point }
gcount:=l+1;
lock.endread;
r:=random(30000);
if (r=0) then
sleep(30);
end;
end;
procedure twritecounter.execute;
var
i: longint;
l: longint;
r: longint;
begin
for i:=1 to 500 do
begin
lock.beginwrite;
inc(flocalcount);
l:=gcount;
{ guarantee at least one sleep }
if i=250 then
sleep(20+random(30))
else if (random(100)=0) then
sleep(20);
{ we must be exclusive }
if gcount<>l then
begin
writeln('error 1');
halt(1);
end;
gcount:=l+1;
lock.endwrite;
r:=random(30);
if (r>28) then
sleep(r);
end;
end;
procedure terrorcheck.execute;
begin
{ make sure we don't exit before this thread has initialised, since }
{ it can allocate memory in its initialisation, which would cause }
{ problems for heaptrc as it goes over the memory map in its exit code }
waiting:=true;
{ avoid deadlocks/bugs from causing this test to never quit }
sleep(1000*15);
errorstring:='error 4';
end;
Function trwsync : string;
var
r1,r2,r3,r4,r5,r6: treadcounter;
w1,w2,w3,w4: twritecounter;
begin
if SysGetSetting('nosync')='true' then
begin
Ignore('Excluded by config');
exit;
end;
waiting:=false;
terrorcheck.create(false);
randomize;
lock:=TMultiReadExclusiveWriteSynchronizer.create;
{ verify that the lock is recursive }
lock.beginwrite;
lock.beginwrite;
lock.endwrite;
lock.endwrite;
{ first try some writers }
w1:=twritecounter.create;
w2:=twritecounter.create;
w3:=twritecounter.create;
w4:=twritecounter.create;
w1.start;
w2.start;
w3.start;
w4.start;
w1.waitfor;
w2.waitfor;
w3.waitfor;
w4.waitfor;
{ must not have caused any data races }
if (gcount<>w1.localcount+w2.localcount+w3.localcount+w4.localcount) then
Result:='error 2';
w1.free;
w2.free;
w3.free;
w4.free;
if Result='' then
begin
{ now try some mixed readers/writers }
gcount:=0;
r1:=treadcounter.create;
r2:=treadcounter.create;
r3:=treadcounter.create;
r4:=treadcounter.create;
r5:=treadcounter.create;
r6:=treadcounter.create;
w1:=twritecounter.create;
w2:=twritecounter.create;
r1.start;
r2.start;
r3.start;
r4.start;
r5.start;
r6.start;
w1.start;
w2.start;
r1.waitfor;
r2.waitfor;
r3.waitfor;
r4.waitfor;
r5.waitfor;
r6.waitfor;
w1.waitfor;
w2.waitfor;
{ updating via the readcount must have caused data races }
if (gcount>=r1.localcount+r2.localcount+r3.localcount+r4.localcount+r5.localcount+r6.localcount+w1.localcount+w2.localcount) then
Result:='Error 3';
r1.free;
r2.free;
r3.free;
r4.free;
r5.free;
r6.free;
w1.free;
w2.free;
end;
lock.free;
while not waiting do
sleep(20);
if Result='' then
Result:=errorstring;
end;
begin
SysutilsTest('trwsync',@trwsync);
end.

31
rtl/test/utscanf.pp
View File

@ -1,31 +0,0 @@
unit utscanf;
{$mode objfpc}
{$h+}
interface
uses
sysutils;
implementation
uses utrtl, punit;
Function utsscanf : string;
var
e : extended;
s : string;
l : longint;
begin
Result:='';
sscanf('asdf 1'+DecimalSeparator+'2345 1234','%s %f %d',[@s,@e,@l]);
if AssertEquals('Detected float',1.2345,e) then
If AssertEquals('Detected integer',1234,l) then
AssertEquals('Detected string','asdf',s)
end;
begin
SysutilsTest('utsscanf',@utsscanf);
end.

142
rtl/test/utstrcmp.pp
View File

@ -1,142 +0,0 @@
unit utstrcmp;
{ based on string/tester.c of glibc 2.3.6
* Tester for string functions.
Copyright (C) 1995-2000, 2001, 2003 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with the GNU C Library; if not, write to the Free
Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA. */
}
{$ifdef fpc}
{$mode delphi}
{$endif fpc}
interface
uses
{$ifdef unix}
{$ifdef darwin}iosxwstr{$else}cwstring{$endif},
{$endif unix}
SysUtils;
implementation
uses punit, utrtl;
Var
GotError : Boolean;
procedure check(b: boolean; testnr: longint);
begin
if Not GotError then
begin
GotError:=B;
AssertTrue('Error nr '+IntToStr(testNr),B);
end;
end;
Function teststricomp : String;
begin
GotError:=False;
Result:='';
check(stricomp('a', 'a') = 0, 1);
check(stricomp('a', 'A') = 0, 2);
check(stricomp('A', 'a') = 0, 3);
check(stricomp('a', 'b') < 0, 4);
check(stricomp('c', 'b') > 0, 5);
check(stricomp('abc', 'AbC') = 0, 6);
check(stricomp('0123456789', '0123456789') = 0, 7);
check(stricomp('', '0123456789') < 0, 8);
check(stricomp('AbC', '') > 0, 9);
check(stricomp('AbC', 'A') > 0, 10);
check(stricomp('AbC', 'Ab') > 0, 11);
check(stricomp('AbC', 'ab') > 0, 12);
check(stricomp('Ab'#0'C', 'ab'#0) = 0, 13);
end;
Function teststrlcomp : string;
begin
GotError:=False;
Result:='';
check (strlcomp ('', '', 0) = 0, 1); { Trivial case. }
check (strlcomp ('a', 'a', 1) = 0, 2); { Identity. }
check (strlcomp ('abc', 'abc', 3) = 0, 3); { Multicharacter. }
check (strlcomp ('abc'#0, 'abcd', 4) < 0, 4); { Length unequal. }
check (strlcomp ('abcd', 'abc'#0, 4) > 0, 5);
check (strlcomp ('abcd', 'abce', 4) < 0, 6); { Honestly unequal. }
check (strlcomp ('abce', 'abcd', 4) > 0, 7);
check (strlcomp ('abce', 'abcd', 3) = 0, 10); { Count limited. }
check (strlcomp ('abce', 'abc', 3) = 0, 11); { Count = length. }
check (strlcomp ('abcd', 'abce', 4) < 0, 12); { Nudging limit. }
check (strlcomp ('abc', 'def', 0) = 0, 13); { Zero count. }
check (strlcomp ('abc'#0'e', 'abc'#0'd', 5) = 0, 14);
end;
Function teststrcomp : String;
begin
GotError:=False;
Result:='';
check (strcomp ('', '') = 0, 1); { Trivial case. }
check (strcomp ('a', 'a') = 0, 2); { Identity. }
check (strcomp ('abc', 'abc') = 0, 3); { Multicharacter. }
check (strcomp ('abc', 'abcd') < 0, 4); { Length mismatches. }
check (strcomp ('abcd', 'abc') > 0, 5);
check (strcomp ('abcd', 'abce') < 0, 6); { Honest miscompares. }
check (strcomp ('abce', 'abcd') > 0, 7);
check (strcomp ('abc'#0'e', 'abc'#0'd') = 0, 8);
end;
function teststrlicomp : string;
begin
GotError:=False;
Result:='';
check(strlicomp('a', 'a', 1) = 0, 1);
check(strlicomp('a', 'A', 1) = 0, 2);
check(strlicomp('A', 'a', 1) = 0, 3);
check(strlicomp('a', 'b', 1) < 0, 4);
check(strlicomp('c', 'b', 1) > 0, 5);
check(strlicomp('abc', 'AbC', 3) = 0, 6);
check(strlicomp('0123456789', '0123456789', 10) = 0, 7);
check(strlicomp(#0'123456789', #0'123456799', 10) = 0, 8);
check(strlicomp(#0'bD', #0'bC', 3) = 0, 9);
check(strlicomp('AbC', 'A'#0#0,3) > 0, 10);
check(strlicomp('AbC', 'Ab'#0, 3) > 0, 11);
check(strlicomp('AbC', 'ab'#0, 3) > 0, 12);
check(strlicomp('0123456789', 'AbC', 0) = 0, 13);
check(strlicomp('AbC', 'abc', 1) = 0, 14);
check(strlicomp('AbC', 'abc', 2) = 0, 15);
check(strlicomp('AbC', 'abc', 3) = 0, 16);
check(strlicomp('AbC', 'abcd', 3) = 0, 17);
check(strlicomp('AbCc', 'abcd', 4) < 0, 18);
check(strlicomp('ADC', 'abcd', 1) = 0, 19);
check(strlicomp('ADC', 'abcd', 2) > 0, 20);
check(strlicomp('abc'#0'e', 'abc'#0'd', 5) = 0, 21);
end;
begin
SysutilsTest('TestStrIComp',@teststricomp);
SysutilsTest('TestStrLComp',@teststrlcomp);
SysutilsTest('TestStrComp',@teststrcomp);
SysutilsTest('TestStrLIComp',@teststrlicomp);
end.

51
rtl/test/utstrcopy.pp
View File

@ -1,51 +0,0 @@
unit utstrcopy;
interface
uses punit,utrtl;
implementation
uses strings;
function test_strcopy : TTeststring;
Type
TCharArray = array[0..256] of char;
TLongCharArray = array[0..512] of char;
var
p: pchar;
s: TCharArray;
buf: TLongCharArray;
i, j, l: longint;
id : string;
begin
Result:='';
s:=Default(TCharArray);
buf:=Default(TLongCharArray);
for i := 0 to 256 do
begin
Str(i,ID);
fillchar(s,sizeof(s),'b');
s[i] := #0;
for j := 0 to 3 do
begin
fillchar(buf,sizeof(buf),'a');
p := strcopy(@buf[j+32],@s[0]);
if not AssertEquals('Error 0',@buf[j+32],P) then exit;
for l := 0 to j+31 do
If not assertEquals('Error 1 (i='+id+')','a',buf[l]) then exit;
for l := j+32 to j+32+i-1 do
If not assertEquals('Error 2 (i='+id+')','b',buf[l]) then exit;
if not AssertEquals('Error 3 (i='+id+')',#0,buf[j+i+32]) then exit;
for l := j+i+32+1 to 512 do
If not assertEquals('Error 4 (i='+id+')','a',buf[l]) then exit;
end;
end;
end;
begin
AddTest('test_strcopy',@test_strcopy,EnsureSuite('Strings'));
end.

1034
rtl/test/utstringbuild.pp
View File

File diff suppressed because it is too large Load Diff

1264
rtl/test/utstringhelp.pp
View File

File diff suppressed because it is too large Load Diff

147
rtl/test/utstrings1.pp
View File

@ -1,147 +0,0 @@
{ Basic test suite for the strings unit }
{$mode objfpc}
unit utstrings1;
interface
uses punit, utrtl;
implementation
uses
strings;
Function teststrlen : TTestString;
Const
P1 : PChar = '';
P2 : PChar = 'This is a constant pchar string';
begin
Result:='';
If not AssertEquals('Empty string',0,strlen(P1)) then exit;
if not AssertEquals('Non-empty string',31,strlen(P2)) then exit;
end;
function teststrcomp : TTestString;
Const
P1 : PChar = 'This is the first string.';
P2 : PCHar = 'This is the second string.';
P3 : PChar = 'This is the first string.';
begin
Result:='';
If Not AssertTrue('Different strings',StrComp (P1,P2)<>0) then exit;
If Not AssertEquals('Equal strings different pointers',0,StrComp(P1,P3)) then exit;
If Not AssertTrue('First less than second',StrComp (P1,P2)<=0) then exit;
If Not AssertTrue('Second bigger than first',StrComp (P2,P1)>0) then exit;
end;
Function teststrpas : TTestString;
Const
P1 : PChar = 'This is a PCHAR string';
P2 : PChar = '';
var
S : string;
begin
Result:='';
S:=StrPas(P1);
if Not AssertEquals('Test strpas, non-nil','This is a PCHAR string',S) then exit;
S:=StrPas(P2);
if Not AssertEquals('Test strpas, nil','',S) then exit;
end;
Function teststrlcomp : TTestString;
Const
P1 : PChar = 'This is the first string.';
P2 : PCHar = 'This is the second string.';
P3 : PChar = 'This is the first string.';
Var
L : Longint;
begin
Result:='';
L:=1;
While StrLComp(P1,P2,L)=0 do
inc (L);
if not AssertEquals('Max 13 chars equal',13,L) then exit;
if not AssertTrue('Different strings',StrLComp (P1,P2,255)<>0) then exit;
if not AssertEquals('Equal strings, different pointers',0,StrLComp (P1,P3,100)) then exit;
if not AssertTrue('P1<P2 negative',StrLComp (P1,P2,65535)<0) then exit;
if not AssertTrue('P2>P1, positive',StrLComp (P2,P1,12341234)>0) then exit;
end;
Function teststrpcopy : TTestString;
Const
S1 = 'This is a normal string.';
S2 = '';
Var
P : array[0..255] of char;
begin
Result:='';
If not AssertEquals('Return value',@P,StrPCopy(P,S1)) then exit;
If not AssertEquals('Correct copy',0,StrComp(P,S1)) then exit;
if not AssertEquals('Return value 2',@P,StrPCopy(P,S2)) then
if not AssertEquals('Correct copy 2',0,StrComp(P,S2)) then exit;
end;
Function teststrend : TTestString;
Const
P : PChar = 'This is a PCHAR string.';
begin
Result:='';
If not AssertEquals('StrEnd, not empty',23,StrEnd(P)-P) then exit;
end;
Function teststrcopy : TTestString;
Const
P1 : PChar = 'This a test string 012345678901234567890123456789012345678901234567890123456789';
P2 : PChar = '';
var
Buf : array[0..255] of char;
begin
Result:='';
If not AssertEquals('StrCopy non-empty Result',@Buf,StrCopy(Buf,P1)) then exit;
If not AssertEquals('StrCopy non-empty Resulting string',0,StrComp(Buf,P1)) then exit;
If not AssertEquals('StrCopy empty Result',@Buf,StrCopy(Buf,P2)) then exit;
If not AssertEquals('StrCopy empty Resulting string',0,StrComp(Buf,P2)) then exit;
end;
Function teststrscanstrrscan : TTestString;
Const
P : PChar = 'This is a PCHAR string.';
S : Char = 's' ;
begin
Result:='';
if Not AssertEquals('Not contained',0, StrComp(StrScan(P,s),'s is a PCHAR string.')) then exit;
if Not AssertTrue('Contained',StrComp(StrRScan(P,s),'string.')=0) then exit;
end;
Var
P : Psuite;
begin
P:=EnsureSuite('Strings');
AddTest('teststrlen',@teststrlen,P);
AddTest('teststrcomp',@teststrcomp,P);
AddTest('teststrlcomp',@teststrlcomp,P);
AddTest('teststrpas', @teststrpas,P);
AddTest('teststrcopy', @teststrcopy,P);
AddTest('teststrpcopy',@teststrpcopy,P);
AddTest('teststrend', @teststrend,P);
AddTest('teststrscanstrrscan',@teststrscanstrrscan,P);
end.

97
rtl/test/utstrtobool.pp
View File

@ -1,97 +0,0 @@
unit utstrtobool;
{$mode objfpc}
Interface
uses
sysutils;
implementation
uses utrtl, punit;
Function TestStrToBool : AnsiString;
var
b : boolean;
FS : TFormatSettings;
begin
Result:='';
if not TryStrToBool('true',b) then
exit('Test 1');
if not b then
exit('Test 2');
if not TryStrToBool('false',b) then
exit('Test 3');
if b then
exit('Test 4');
if not TryStrToBool('True',b) then
exit('Test 5');
if not b then
exit('Test 6');
if not TryStrToBool('False',b) then
exit('Test 7');
if b then
exit('Test 8');
if not TryStrToBool('truE',b) then
exit('Test 9');
if not b then
exit('Test 10');
if not TryStrToBool('falsE',b) then
exit('Test 11');
if b then
exit('Test 12');
if not TryStrToBool('TRUE',b) then
exit('Test 13');
if not b then
exit('Test 14');
if not TryStrToBool('FALSE',b) then
exit('Test 15');
if b then
exit('Test 16');
if not TryStrToBool('3.1415',b) then
exit('Test 17');
if not b then
exit('Test 18');
if not TryStrToBool('0.0',b) then
exit('Test 19');
if b then
exit('Test 19');
if TryStrToBool('',b) then
exit('Test 20');
if TryStrToBool('asdf',b) then
exit('Test 21');
b:=StrToBool('truE');
if not b then
exit('Test 22');
b:=StrToBool('falsE');
if b then
exit('Test 23');
if not(StrToBoolDef('',true)) then
exit('Test 24');
if StrToBoolDef('asdf',false) then
exit('Test 25');
FS:=DefaultFormatSettings;
FS.DecimalSeparator:=',';
If Not TryStrToBool('1,2',B,FS) then
Exit('test 26');
end;
begin
SysUtilsTest('TestStrToBool',@TestStrToBool);
end.

158
rtl/test/utstrtotime.pp
View File

@ -1,158 +0,0 @@
{$mode objfpc}
{$h+}
unit utstrtotime;
Interface
Function CheckStrToTime : String;
Implementation
uses sysutils, punit;
Function CheckStrToTime : String;
var
fmt : TFormatSettings;
Function Check(TestNo : Integer; inputstr : String;shouldfailstrtotime:boolean=false;shouldfailcomparison:boolean=false;resultstr:string='') : Boolean;
var
dt :TDateTime;
outputstr:ansistring;
S : String;
begin
Result:=True;
S:='Test '+IntToStr(TestNo)+': ';
if TryStrToTime(inputstr,dt,fmt) then
begin
if shouldfailstrtotime then
begin
Fail(S+' should fail on strtotime while it didn''t '+timetostr(dt,fmt));
Exit(False);
end
else
begin
outputstr:=TimeToStr(dt,fmt); // note because of this bugs can also be in timetostr
if resultstr<>'' then
begin
if outputstr<>resultstr then
begin
Fail(S+' should be "'+resultstr+'" is "'+outputstr+'"');
Exit(False);
end;
exit; // don't do other comparisons
end;
if inputstr<>outputstr then
begin
if not shouldfailcomparison then
begin
Fail(S+' failed "'+inputstr+'" <> "'+outputstr+'"');
Exit(False);
end;
end
else
begin
if shouldfailcomparison then
begin
Fail(S+' succeeded "'+inputstr+'" = "'+outputstr+'", while it shouldn''t');
exit(False);
end;
end;
end;
end
else
if not shouldfailstrtotime then
begin
Fail(S+' failed: '+inputstr);
Exit(False);
end;
end;
procedure setdecimalsep(c:char);
begin
fmt.DecimalSeparator:=c;
fmt.longtimeformat:='hh:nn:ss'+fmt.DecimalSeparator+'zzz';
end;
begin
Result:='';
fmt:=defaultformatsettings;
fmt.TimeSeparator:=':';
fmt.TimeAmstring:='AM';
fmt.TimePmstring:='PM';
setdecimalsep('.');
If not Check( 0,'12:34:45.789',false,false) then exit;
If not Check( 1,'12:34:45,789',true,false) then exit;
setdecimalsep(',');
If not Check( 2,'12:34:45.789',true,false) then exit;
If not Check( 3,'12:34:45,789',false,false) then exit;
If not Check( 4,'12 am',false,false,'00:00:00,000') then exit;
If not Check( 5,'pm 12:34',false,false,'12:34:00,000') then exit;
If not Check( 6,'12::45',true,false) then exit;
If not Check( 7,'12:34:56 px',true,false) then exit;
If not Check( 8,'12:34:5x',true,false) then exit;
If not Check( 9,'12:34:56:78:90',true,false) then exit;
If not Check(10,'5 am',false,false,'05:00:00,000') then exit;
If not Check(11,'5 pm',false,false,'17:00:00,000') then exit;
If not Check(12,'am 5',false,false,'05:00:00,000') then exit;
If not Check(13,'pm 5',false,false,'17:00:00,000') then exit;
fmt.longtimeformat:='hh:nn:ss'+fmt.DecimalSeparator+'zzz am/pm';
If not Check(14,'5 am',false,false,'05:00:00,000 am') then exit;
If not Check(15,'5 pm',false,false,'05:00:00,000 pm') then exit;
If not Check(16,'am 5',false,false,'05:00:00,000 am') then exit;
If not Check(17,'pm 5',false,false,'05:00:00,000 pm') then exit;
fmt.TimeAmstring:='AM';
fmt.TimePmstring:='PM';
fmt.longtimeformat:='hh:nn:ss'+fmt.DecimalSeparator+'zzz a/p';
If not Check(18,'am 5',false,false,'05:00:00,000 a') then exit;
If not Check(19,'pm 5',false,false,'05:00:00,000 p') then exit;
fmt.TimeAMString:='a'; fmt.TimePMString:='p';
If not Check(20,'a 5',false,false,'05:00:00,000 a') then exit;
If not Check(21,'p 5',false,false,'05:00:00,000 p') then exit;
If not Check(22,'12:',True,false) then exit;
If not Check(23,'13:14:',True,false) then exit;
If not Check(24,'a 17:00',True,false) then exit;
If not Check(25,'p 19:00',True,false) then exit;
If not Check(26,'1:2:3',false,false,'01:02:03,000 a') then exit;
If not Check(27,'1:4',false,false,'01:04:00,000 a') then exit;
If not Check(28,'111:2:3',True,false) then exit;
If not Check(29,'1:444',True,false) then exit;
If not Check(30,'1:2:333',True,false) then exit;
If not Check(31,'1:4:55,4',False,false,'01:04:55,004 a') then exit;
If not Check(32,'1:4:55,12',False,false,'01:04:55,012 a') then exit;
If not Check(33,'1:4:55,004',False,false,'01:04:55,004 a') then exit;
If not Check(34,'1:4:55,0012',False,false,'01:04:55,012 a') then exit;
If not Check(35,'1:4:55,004'#9'am',true,false,'01:04:55,004'#9'am') then exit;
If not Check(36,#9'1:4:55,0012',true,false,'01:04:55,012 a') then exit;
If not Check(37,' 1:4:55,4',False,false,'01:04:55,004 a') then exit;
If not Check(38,'1: 4:55,12',False,false,'01:04:55,012 a') then exit;
If not Check(39,'1:4: 55,004',False,false,'01:04:55,004 a') then exit;
If not Check(40,'1:4:55, 2',False,false,'01:04:55,002 a') then exit;
If not Check(41,'1:4:55, 4',False,false,'01:04:55,004 a') then exit; // note more padding then needed
If not Check(42,'1: 4:55, 4',False,false,'01:04:55,004 a') then exit; // note more padding then needed
If not Check(43,'1: 4: 55, 4',False,false,'01:04:55,004 a') then exit; // note more padding then needed
If not Check(44,'1: 4: 55, 4',False,false,'01:04:55,004 a') then exit; // note more padding then needed
If not Check(45,'1 4 55 4',True,false) then exit;
fmt.timeseparator:=' ';
If not Check(46,'01 04 55',True,false) then exit;
If not Check(47,'a 01',false,false,'01 00 00,000 a') then exit;
If not Check(52,'a01',false,false,'01 00 00,000 a') then exit;
fmt.TimeSeparator:=':';
If not Check(48,'1:4:55,0000000000000000000000012',false,false,'01:04:55,012 a') then exit;
If not Check(49,'1:4:55,0000100012',True,false) then exit;
If not Check(50,'1:4:55,000001012',True,false) then exit;
If not Check(51,'12:034:00056',false,false,'12:34:56,000 p') then exit;
end;
begin
AddSuite('SysUtils');
AddTest('CheckStrToTime',@CheckStrToTime,'SysUtils');
end.

1883
rtl/test/utsyshelpers.pp
View File

File diff suppressed because it is too large Load Diff

136
rtl/test/utsysutils.pp
View File

@ -1,136 +0,0 @@
{$mode objfpc}
{$h+}
unit utsysutils;
Interface
Function CheckMaxDateTime : String;
Implementation
uses sysutils, punit, utrtl;
Function CheckMaxDateTime : String;
var
y,d,h,m,s,z : Word;
begin
Result:='';
DecodeTime(MaxDateTime, h, m, s, z);
if not AssertEquals('Hours correct',23,h) then exit;
if not AssertEquals('Minutes correct',59,m) then exit;
if not AssertEquals('Seconds correct',59,s) then exit;
if not AssertEquals('Milliseconds correct',999,z) then exit;
DecodeDate(MaxDateTime, y, m,d);
if not AssertEquals('Year correct',9999,y) then exit;
if not AssertEquals('Month correct',12,m) then exit;
if not AssertEquals('Day correct',31,d) then exit;
end;
Function CheckIsValidIdent : string;
begin
Result:='';
if not AssertTrue('Normal',isValidIdent('abc')) then exit;
if not AssertTrue('Normal with dot',isValidIdent('abc',true)) then exit;
if not AssertTrue('Normal underscore',isValidIdent('_abc')) then exit;
if not AssertTrue('Normal underscore with dot',isValidIdent('_abc',true)) then exit;
if not AssertTrue('Normal last underscore',isValidIdent('abc_')) then exit;
if not AssertTrue('Normal last underscore with dot',isValidIdent('abc_',true)) then exit;
if not AssertTrue('Normal number',isValidIdent('abc0')) then exit;
if not AssertTrue('Normal number',isValidIdent('abc0',true)) then exit;
if not AssertFalse('Normal number first',isValidIdent('9abc')) then exit;
if not AssertFalse('Normal number first',isValidIdent('9abc',True)) then exit;
if not AssertTrue('Containing dot, allowed',IsValidIdent('a.b',True)) then exit;
if not AssertFalse('Containing dot, not allowed',IsValidIdent('a.b')) then exit;
if not AssertFalse('Containing dot pos 1, allowed',IsValidIdent('.b',true)) then exit;
end;
Function CheckAnsiDequotedString : string;
begin
Result:='';
if Not AssertEquals('Nothing between quotes','',AnsiDequotedStr('""', '"')) then exit;
if Not AssertEquals('empty string','',AnsiDequotedStr('', '"')) then exit;
if Not AssertEquals('Non-quoted string','abc',AnsiDequotedStr('abc', '"')) then exit;
end;
Function CheckFileOpenDirFails : String;
begin
Result:='';
If Not AssertEquals('Cannot open directory with fileOpen',-1,FileOpen('.',fmOpenRead)) then exit;
end;
Function CheckStringReplace : String;
Var
C : integer;
begin
Result:='';
If not AssertEquals('StringReplace 1 Result','ABA',StringReplace('ACA','C','B',[],C)) then exit;
If not AssertEquals('StringReplace 1 count Result',1,C) then exit;
If not AssertEquals('StringReplace 2 Result','ABAC',StringReplace('ACAC','C','B',[],C)) then exit;
If not AssertEquals('StringReplace 2 count Result',1,C) then exit;
If not AssertEquals('StringReplace 3 Result','ABAB',StringReplace('ACAC','C','B',[rfReplaceAll],C)) then exit;
If not AssertEquals('StringReplace 3 count Result',2,C) then exit;
If not AssertEquals('StringReplace 4 Result','ACAC',StringReplace('ACAC','D','B',[rfReplaceAll],C)) then exit;
If not AssertEquals('StringReplace 4 count Result',0,C) then exit;
end;
Function CheckUnicodeStringReplace : String;
Var
C : integer;
begin
Result:='';
If not AssertEquals('UnicodeStringReplace 1 Result','ABA',UnicodeStringReplace('ACA','C','B',[],C)) then exit;
If not AssertEquals('UnicodeStringReplace 1 count Result',1,C) then exit;
If not AssertEquals('UnicodeStringReplace 2 Result','ABAC',UnicodeStringReplace('ACAC','C','B',[],C)) then exit;
If not AssertEquals('UnicodeStringReplace 2 count Result',1,C) then exit;
If not AssertEquals('UnicodeStringReplace 3 Result','ABAB',UnicodeStringReplace('ACAC','C','B',[rfReplaceAll],C)) then exit;
If not AssertEquals('UnicodeStringReplace 3 count Result',2,C) then exit;
If not AssertEquals('UnicodeStringReplace 4 Result','ACAC',UnicodeStringReplace('ACAC','D','B',[rfReplaceAll],C)) then exit;
If not AssertEquals('UnicodeStringReplace 4 count Result',0,C) then exit;
end;
Function CheckWideStringReplace : String;
Var
C : integer;
begin
Result:='';
If not AssertEquals('WideStringReplace 1 Result','ABA',WideStringReplace('ACA','C','B',[],C)) then exit;
If not AssertEquals('WideStringReplace 1 count Result',1,C) then exit;
If not AssertEquals('WideStringReplace 2 Result','ABAC',WideStringReplace('ACAC','C','B',[],C)) then exit;
If not AssertEquals('WideStringReplace 2 count Result',1,C) then exit;
If not AssertEquals('WideStringReplace 3 Result','ABAB',WideStringReplace('ACAC','C','B',[rfReplaceAll],C)) then exit;
If not AssertEquals('WideStringReplace 3 count Result',2,C) then exit;
If not AssertEquals('WideStringReplace 4 Result','ACAC',WideStringReplace('ACAC','D','B',[rfReplaceAll],C)) then exit;
If not AssertEquals('WideStringReplace 4 count Result',0,C) then exit;
end;
Function CheckWrapText : String;
begin
Result:='';
If not AssertEquals('Default','hello hello',WrapText('hello hello',7)) then exit;
end;
begin
SysutilsTest('CheckMaxDateTime',@CheckMaxDateTime);
SysutilsTest('CheckIsValidIdent',@CheckIsValidIdent);
SysutilsTest('CheckAnsiDequotedString',@CheckAnsiDequotedString);
SysutilsTest('CheckFileOpenDirFails',@CheckFileOpenDirFails);
SysutilsTest('CheckStringReplace',@CheckStringReplace);
SysutilsTest('CheckUnicodeStringReplace',@CheckUnicodeStringReplace);
SysutilsTest('CheckWideStringReplace',@CheckWideStringReplace);
SysutilsTest('CheckWrapText',@CheckWrapText);
end.

143
rtl/test/uttypinfo.pp
View File

@ -1,143 +0,0 @@
unit uttypinfo;
{$mode objfpc}
{$H+}
interface
uses
Classes, SysUtils, punit, utrtl, typinfo;
implementation
Type
TMyEnum = (one,two,three);
TMyInt = Integer;
Var
MyEnumInfo : PtypeInfo;
Function RegisterAliasesNotEnumerated : TtestString;
begin
Result:='';
ExpectException('Type information points to non-enumerated type',EArgumentException);
AddEnumElementAliases(TypeInfo(TMyInt),['a','b','c'],0)
end;
Function RegisterAliasesNoElements : TTestString;
begin
Result:='';
ExpectException('Invalid number of enumerated values',EArgumentException);
AddEnumElementAliases(MyEnumInfo,[],0)
end;
Function RegisterAliasesTooManyElements : TTestString;
begin
Result:='';
ExpectException('Invalid number of enumerated values',EArgumentException);
AddEnumElementAliases(MyEnumInfo,['a','b','c','d'],0)
end;
Function RegisterAliasesTooManyElementsOffset : TTestString;
begin
Result:='';
ExpectException('Invalid number of enumerated values',EArgumentException);
AddEnumElementAliases(MyEnumInfo,['a','b','c'],2)
end;
Function RegisterAliasesDuplicate : TTestString;
begin
Result:='';
ExpectException('Duplicate alias for enumerated value',EArgumentException);
AddEnumElementAliases(MyEnumInfo,['a','b','a'],2)
end;
function TestGetEnumeratedAliasValue : TTestString;
begin
Result:='';
AddEnumElementAliases(MyEnumInfo,['a','b','c']);
if not AssertEquals('Correct value',0,GetEnumeratedAliasValue(MyEnumInfo,'a')) then
exit;
if not AssertEquals('Correct value',1,GetEnumeratedAliasValue(MyEnumInfo,'b')) then
exit;
if not AssertEquals('Correct value',2,GetEnumeratedAliasValue(MyEnumInfo,'c')) then
exit;
end;
function TestGetRemoveEnumeratedAliases : TTestString;
begin
Result:='';
RemoveEnumElementAliases(MyEnumInfo);
AddEnumElementAliases(MyEnumInfo,['a','b','c']);
if not AssertEquals('Correct value',0,GetEnumeratedAliasValue(MyEnumInfo,'a')) then
exit;
RemoveEnumElementAliases(MyEnumInfo);
if not AssertEquals('Correct value',-1,GetEnumeratedAliasValue(MyEnumInfo,'a')) then
exit;
end;
function TestGetRemoveEnumeratedAliasesOffset : TTestString;
begin
Result:='';
RemoveEnumElementAliases(MyEnumInfo);
AddEnumElementAliases(MyEnumInfo,['b','c'],1);
if not AssertEquals('Correct value',-1,GetEnumeratedAliasValue(MyEnumInfo,'a')) then
exit;
if not AssertEquals('Correct value',1,GetEnumeratedAliasValue(MyEnumInfo,'b')) then
exit;
if not AssertEquals('Correct value',2,GetEnumeratedAliasValue(MyEnumInfo,'c')) then
exit;
end;
function TestGetEnumeratedValue : TTestString;
begin
Result:='';
RemoveEnumElementAliases(MyEnumInfo);
AddEnumElementAliases(MyEnumInfo,['b','c'],1);
if not AssertEquals('Correct value',-1,GetEnumValue(MyEnumInfo,'a')) then
exit;
if not AssertEquals('Correct value',0,GetEnumValue(MyEnumInfo,'one')) then
exit;
if not AssertEquals('Correct value',1,GetEnumValue(MyEnumInfo,'two')) then
exit;
if not AssertEquals('Correct value',1,GetEnumValue(MyEnumInfo,'b')) then
exit;
if not AssertEquals('Correct value',2,GetEnumValue(MyEnumInfo,'three')) then
exit;
if not AssertEquals('Correct value',2,GetEnumValue(MyEnumInfo,'c')) then
exit;
end;
Procedure RegisterTests;
Var
P : Psuite;
begin
P:=EnsureSuite('TypInfo');
AddTest('RegisterAliasesNotEnumerated',@RegisterAliasesNoElements,P);
AddTest('RegisterAliasesNoElements',@RegisterAliasesNoElements,P);
AddTest('RegisterAliasesTooManyElements',@RegisterAliasesTooManyElements,P);
AddTest('RegisterAliasesTooManyElementsOffset',@RegisterAliasesTooManyElementsOffset,P);
AddTest('RegisterAliasesDuplicate',@RegisterAliasesDuplicate,P);
AddTest('TestGetEnumeratedAliasValue',@TestGetEnumeratedAliasValue,P);
AddTest('TestGetRemoveEnumeratedAliases',@TestGetRemoveEnumeratedAliases,P);
AddTest('TestGetRemoveEnumeratedAliasesOffset',@TestGetRemoveEnumeratedAliasesOffset,P);
AddTest('TestGetEnumeratedValue',@TestGetEnumeratedValue,P);
end;
begin
MyEnumInfo:=TypeInfo(TMyEnum);
RegisterTests;
end.

132
rtl/test/utunifile.pp
View File

@ -1,132 +0,0 @@
unit utunifile;
{$codepage utf8}
{$mode objfpc}{$h+}
interface
uses
{$ifdef unix}
{$ifdef darwin}iosxwstr{$else}cwstring{$endif},
{$endif}
sysutils;
implementation
uses punit,utrtl;
type
tcpstr866 = type ansistring(866);
procedure error(const s: string);
begin
writeln('Error: ',s);
halt(1);
end;
procedure warn(const s: string);
begin
Ignore('Warning: cannot test '+s+' scenario fully because not all characters are supported by DefaultFileSystemCodePage');
end;
Function testsinglebyteUtf8 : String;
var
u: utf8string;
f: THandle;
r: rawbytestring;
begin
Result:='';
u:='‹≈©◊';
r:=u;
setcodepage(r,DefaultFileSystemCodePage);
if r=u then
begin
f:=FileCreate(u,fmShareDenyNone,(6 shl 6) or (4 shl 3) or 4);
if not AssertTrue('Creating utf8string',f<>-1) then exit;
FileClose(f);
DeleteFile(u);
end
else
warn('utf8string');
end;
Function testsinglebytecp866 : String;
var
c: tcpstr866;
f: THandle;
r: rawbytestring;
begin
Result:='';
c:='Русская';
setcodepage(rawbytestring(c),866);
r:=c;
setcodepage(r,DefaultFileSystemCodePage);
if r=c then
begin
f:=FileCreate(c,fmShareDenyNone,(6 shl 6) or (4 shl 3) or 4);
if not AssertTrue('Creating tcpstr866',f<>-1) then exit;
FileClose(f);
DeleteFile(c);
end
else
warn('tcpstr866');
end;
Function testtwobyteutf8 : string;
var
u: unicodestring;
f: THandle;
r: rawbytestring;
begin
Result:='';
R:='';
u:='‹≈©◊';
widestringmanager.unicode2ansimoveproc(punicodechar(u),r,DefaultFileSystemCodePage,length(u));
if r=u then
begin
f:=FileCreate(u,fmShareDenyNone,(6 shl 6) or (4 shl 3) or 4);
if not AssertTrue('Creating unicodestring 1',f<>-1) then exit;
FileClose(f);
DeleteFile(u);
end
else
warn('random unicodestring');
end;
Function testtwobytecp866 : string;
var
u: unicodestring;
f: THandle;
r: rawbytestring;
begin
Result:='';
r:='';
u:='Русская';
r:=u;
if r=u then
begin
f:=FileCreate(u,fmShareDenyNone,(6 shl 6) or (4 shl 3) or 4);
if not AssertTrue('Creating unicodestring 1',f<>-1) then exit;
FileClose(f);
DeleteFile(u);
end
else
warn('cp866 unicodestring');
end;
begin
SysutilsTest('testsinglebyteutf8',@testsinglebyteutf8);
SysutilsTest('testsinglebytecp866',@testsinglebytecp866);
SysutilsTest('testtwobyteutf8',@testtwobyteutf8);
SysutilsTest('testtwobytecp866',@testtwobytecp866);
end.

113
rtl/test/utuplow.pp
View File

@ -1,113 +0,0 @@
unit utuplow;
{$mode objfpc}
{$h+}
interface
uses
SysUtils;
Implementation
uses punit, utrtl;
procedure writestring(const s: ansistring);
var
i: longint;
begin
for i:=1 to length(s) do
if (s[i]<=#32) or (s[i]>=#127) then
write('#',ord(s[i]),' ')
else
write(s[i],' ');
writeln;
end;
procedure writestring(const s: unicodestring);
var
i: longint;
begin
for i:=1 to length(s) do
if (s[i]<=#0032) or (s[i]>=#0127) then
write('#',ord(s[i]),' ')
else
write(s[i],' ');
writeln;
end;
procedure error(const s1,s2: ansistring; nr: longint);
begin
writeln('error ',nr);
write(' Got: ');
writestring(s1);
write(' Expected: ');
writestring(s2);
halt(nr);
end;
procedure error(const s1,s2: unicodestring; nr: longint);
begin
writeln('error ',nr);
write(' Got: ');
writestring(s1);
write(' Expected: ');
writestring(s2);
halt(nr);
end;
Function testuplowansi : string;
const
str = #1#2#0#3#128#129#130#131#132#133#134#135#136#137#138#139'aAbBcCdD'#0'fF';
upperstr = #1#2#0#3#128#129#130#131#132#133#134#135#136#137#138#139'AABBCCDD'#0'FF';
lowerstr = #1#2#0#3#128#129#130#131#132#133#134#135#136#137#138#139'aabbccdd'#0'ff';
var
s1, s2: ansistring;
begin
Result:='';
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=uppercase(s1);
if not AssertEquals('error 1',upperstr,S1) then exit;
if not AssertEquals('error 2',str,S2) then exit;
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=lowercase(s1);
if not AssertEquals('Error 3',lowerstr,S1) then exit;
if not AssertEquals('Error 4',str,S2) then exit;
end;
Function testuplowwide : String;
const
str = #$0001#$0002#$0000#$0003#0128#0129#0130#0131#0132#0133#0134#0135#0136#0137#0138#0139'AABBCCDD'#0000'FF';
upperstr = #$0001#$0002#$0000#$0003#0128#0129#0130#0131#0132#0133#0134#0135#0136#0137#0138#0139'AABBCCDD'#0000'FF';
lowerstr = #$0001#$0002#$0000#$0003#0128#0129#0130#0131#0132#0133#0134#0135#0136#0137#0138#0139'aabbccdd'#0000'ff';
var
s1, s2: unicodestring;
begin
Result:='';
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=uppercase(s1);
if not AssertEquals('error 5',upperstr,S1) then exit;
if not AssertEquals('error 6',str,S2) then exit;
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=lowercase(s1);
if not AssertEquals('Error 7',lowerstr,S1) then exit;
if not AssertEquals('Error 8',str,S2) then exit;
end;
begin
SysUtilsTest('testuplowansi',@testuplowansi);
SysUtilsTest('testuplowwide',@testuplowwide);
end.

6
rtl/test/utustringbuild.pp
View File

@ -1,6 +0,0 @@
unit utustringbuild;
{$DEFINE SBUNICODE}
{$i utstringbuild.pp}

57
rtl/test/utverify.pp
View File

@ -1,57 +0,0 @@
{******************************************}
{ Used to check the DOS unit }
{------------------------------------------}
{ SetVerify / GetVerify routine testing }
{******************************************}
{$mode objfpc}
unit utverify;
interface
uses punit, utrtl;
implementation
uses utdos, dos;
{$IFDEF GO32V2}
{$DEFINE SUPPORTS_VERIFY}
{$ENDIF}
Function TestVerify : TTestString;
Var
B: Boolean;
s: string;
Begin
Result:='';
B:=False;
if ShowDebugOutput then
begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' GETVERIFY/SETVERIFY ');
WriteLn('----------------------------------------------------------------------');
end;
if not CheckDosError('Initial value',0) then exit;
s:='Testing GetVerify...';
SetVerify(TRUE);
if not CheckDosError(S,0) then exit;
GetVerify(b);
if not CheckDosError(S,0) then exit;
if not AssertEquals(S+' return value',true,B) then exit;
s:='Testing SetVerify...';
SetVerify(FALSE);
if not CheckDosError(S,0) then exit;
GetVerify(b);
if not CheckDosError(S,0) then exit;
{ verify actually only works under dos }
{ and always returns TRUE on other platforms }
{ not anymore (JM) }
if not AssertEquals(S+' test 2',False, B) then exit;
end;
initialization
AddTest('TestVerify',@testverify,EnsureSuite('Dos'));
end.

143
rtl/test/utwstrcmp.pp
View File

@ -1,143 +0,0 @@
{ based on string/tester.c of glibc 2.3.6
* Tester for string functions.
Copyright (C) 1995-2000, 2001, 2003 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with the GNU C Library; if not, write to the Free
Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA. */
}
unit utwstrcmp;
{$ifdef fpc}
{$mode delphi}
{$modeswitch unicodestrings}
{$endif fpc}
interface
uses
{$ifdef unix}
{$ifdef darwin}iosxwstr{$else}cwstring{$endif},
{$endif unix}
SysUtils;
Implementation
uses punit, utrtl;
Var
GotError : Boolean;
procedure check(b: boolean; testnr: longint);
begin
if Not GotError then
begin
GotError:=B;
AssertTrue('Error nr '+IntToStr(testNr),B);
end;
end;
Function teststricomp : String;
begin
GotError:=False;
Result:='';
check(stricomp(pwidechar('a'), pwidechar('a')) = 0, 1);
check(stricomp(pwidechar('a'), pwidechar('A')) = 0, 2);
check(stricomp(pwidechar('A'), pwidechar('a')) = 0, 3);
check(stricomp(pwidechar('a'), pwidechar('b')) < 0, 4);
check(stricomp(pwidechar('c'), pwidechar('b')) > 0, 5);
check(stricomp('abc', 'AbC') = 0, 6);
check(stricomp('0123456789', '0123456789') = 0, 7);
check(stricomp(pwidechar(''), '0123456789') < 0, 8);
check(stricomp('AbC', pwidechar('')) > 0, 9);
check(stricomp('AbC', pwidechar('A')) > 0, 10);
check(stricomp('AbC', 'Ab') > 0, 11);
check(stricomp('AbC', 'ab') > 0, 12);
check(stricomp('Ab'#0'C', 'ab'#0) = 0, 13);
end;
Function teststrlcomp : String;
begin
GotError:=False;
Result:='';
check (strlcomp ('', '', 0) = 0, 1); { Trivial case. }
check (strlcomp (pwidechar('a'), pwidechar('a'), 1) = 0, 2); { Identity. }
check (strlcomp ('abc', 'abc', 3) = 0, 3); { Multicharacter. }
check (strlcomp ('abc'#0, 'abcd', 4) < 0, 4); { Length unequal. }
check (strlcomp ('abcd', 'abc'#0, 4) > 0, 5);
check (strlcomp ('abcd', 'abce', 4) < 0, 6); { Honestly unequal. }
check (strlcomp ('abce', 'abcd', 4) > 0, 7);
check (strlcomp ('abce', 'abcd', 3) = 0, 10); { Count limited. }
check (strlcomp ('abce', 'abc', 3) = 0, 11); { Count = length. }
check (strlcomp ('abcd', 'abce', 4) < 0, 12); { Nudging limit. }
check (strlcomp ('abc', 'def', 0) = 0, 13); { Zero count. }
check (strlcomp ('abc'#0'e', 'abc'#0'd', 5) = 0, 14);
end;
Function teststrcomp : String;
begin
GotError:=False;
Result:='';
check (strcomp (pwidechar(''), pwidechar('')) = 0, 1); { Trivial case. }
check (strcomp (pwidechar('a'), pwidechar('a')) = 0, 2); { Identity. }
check (strcomp ('abc', 'abc') = 0, 3); { Multicharacter. }
check (strcomp ('abc', 'abcd') < 0, 4); { Length mismatches. }
check (strcomp ('abcd', 'abc') > 0, 5);
check (strcomp ('abcd', 'abce') < 0, 6); { Honest miscompares. }
check (strcomp ('abce', 'abcd') > 0, 7);
check (strcomp ('abc'#0'e', 'abc'#0'd') = 0, 8);
end;
function teststrlicomp : string;
begin
GotError:=False;
Result:='';
check(strlicomp(pwidechar('a'), pwidechar('a'), 1) = 0, 1);
check(strlicomp(pwidechar('a'), pwidechar('A'), 1) = 0, 2);
check(strlicomp(pwidechar('A'), pwidechar('a'), 1) = 0, 3);
check(strlicomp(pwidechar('a'), pwidechar('b'), 1) < 0, 4);
check(strlicomp(pwidechar('c'), pwidechar('b'), 1) > 0, 5);
check(strlicomp('abc', 'AbC', 3) = 0, 6);
check(strlicomp('0123456789', '0123456789', 10) = 0, 7);
check(strlicomp(#0'123456789', #0'123456799', 10) = 0, 8);
check(strlicomp(#0'bD', #0'bC', 3) = 0, 9);
check(strlicomp('AbC', 'A'#0#0,3) > 0, 10);
check(strlicomp('AbC', 'Ab'#0, 3) > 0, 11);
check(strlicomp('AbC', 'ab'#0, 3) > 0, 12);
check(strlicomp('0123456789', 'AbC', 0) = 0, 13);
check(strlicomp('AbC', 'abc', 1) = 0, 14);
check(strlicomp('AbC', 'abc', 2) = 0, 15);
check(strlicomp('AbC', 'abc', 3) = 0, 16);
check(strlicomp('AbC', 'abcd', 3) = 0, 17);
check(strlicomp('AbCc', 'abcd', 4) < 0, 18);
check(strlicomp('ADC', 'abcd', 1) = 0, 19);
check(strlicomp('ADC', 'abcd', 2) > 0, 20);
check(strlicomp('abc'#0'e', 'abc'#0'd', 5) = 0, 21);
end;
begin
SysutilsTest('UnicodeTestStrIComp',@teststricomp);
SysutilsTest('UnicodeTestStrLComp',@teststrlcomp);
SysutilsTest('UnicodeTestStrComp',@teststrcomp);
SysutilsTest('UnicodeTestStrLIComp',@teststrlicomp);
end.