freepascal.compiler/tests/test/units/dos/tdos2.pp

{ %INTERACTIVE }
{******************************************}
{  Used to check the DOS unit              }
{------------------------------------------}
{  Requirements for this unit can be       }
{  found in testdos.htm                    }
{******************************************}
Program TestDos;

Uses Dos;

{**********************************************************************}
{ Some specific OS verifications : }
{ Mainly for file attributes:      }
{ Read-Only                        }
{ Hidden                           }
{ System File                      }
{ only work on Win32, OS/2 and DOS }



{$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 TOS}
        {$DEFINE EXTATTR}
{$ENDIF}



{$IFNDEF UNIX}
{$IFDEF LINUX}
        {$DEFINE UNIX}
{$ENDIF}
{$IFDEF QNX}
        {$DEFINE UNIX}
{$ENDIF}
{$IFDEF SOLARIS}
        {$DEFINE UNIX}
{$ENDIF}
{$IFDEF FREEBSD}
        {$DEFINE UNIX}
{$ENDIF}
{$IFDEF BEOS}
        {$DEFINE UNIX}
{$ENDIF}
{$ENDIF}
{**********************************************************************}



CONST
{ what is the root path }
{$IFDEF EXTATTR}
  RootPath = 'C:\';
{$ENDIF}
{$IFDEF UNIX}
  RootPath = '/';
{$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! }
 TestExt   = 'DAT';


Procedure PauseScreen;
var
 ch: char;
Begin
 WriteLn('-- Press any key --');
 ReadLn;
end;

{ verifies that the DOSError variable is equal to }
{ the value requested.                            }
Procedure CheckDosError(err: Integer);
 var
  x : integer;
  s :string;
 Begin
  Write('Verifying value of DOS Error...');
  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
    s := 'INVALID DOSERROR';
  end;
  if err <> x then
    Begin
      WriteLn('FAILURE. (Value should be ',err,' '+s+')');
    end
  else
    WriteLn('Success.');
 end;


Procedure TestdiskSize;
Var
 i : Integer;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                          DISKSIZE/DISKFREE                           ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Should return -1 on both functions if device is not ready.     ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
{ Check Disksize / DiskFree routines }
 for I:=0 to 20 do
 Begin
   Write('Disk unit ',i:2,' free size : ',DiskFree(i):10, ' Total Size: ',DiskSize(i):10);
   WriteLn(' bytes.');
 end;
 CheckDosError(0);
 PauseScreen;
end;

Procedure TestDosVersion;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                          DOSVERSION                                  ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Number should be major version followed by minor version.      ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
 {*------------------------- NOTE -------------------------------------*}
 {* This is OS specific. LO -> Major revision, HI -> Minor Revision    *}
 {*--------------------------------------------------------------------*}
 WriteLn('Operating system Version :',Lo(DosVersion),'.',Hi(DosVersion));
 CheckDosError(0);
 PauseScreen;
end;

Procedure TestEnvCount;
Var
 I: Integer;
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('----------------------------------------------------------------------');
 CheckDosError(0);
 PauseScreen;
 {*------------------------- NOTE -------------------------------------*}
 {* Variables should be of the form VAR=VALUE                          *}
 {*--------------------------------------------------------------------*}
 WriteLn('Number of environment variables : ',EnvCount);
 WriteLn('CURRENT ENVIRONMENT');
 For I:=1 to EnvCount do
  WriteLn(EnvStr(i));
 CheckDosError(0);
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: The next few lines should be empty strings, as they are        ');
 WriteLn('       invalid environment indexes.                                   ');
 WriteLn('----------------------------------------------------------------------');
 For i:=-5 to 0 do
  WriteLn(EnvStr(i));
 CheckDosError(0);
 For i:=20000 to 20002 do
  WriteLn(EnvStr(i));
 CheckDosError(0);
 PauseScreen;
end;

Procedure TestVerify;
Var
 B: Boolean;
 s: string;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                       GETVERIFY/SETVERIFY                            ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
 s:='Testing GetVerify...';
 SetVerify(TRUE);
 CheckDosError(0);
 GetVerify(b);
 CheckDosError(0);
 if b then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE.');
  end;
 s:='Testing GetVerify...';
 SetVerify(FALSE);
 CheckDosError(0);
 GetVerify(b);
 CheckDosError(0);
{ verify actually only works under dos       }  
{ and always returns TRUE on other platforms }
{$ifdef go32v2} 
 if NOT b then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE.');
  end;
{$else}  
 if b then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE.');
  end;
{$endif}  
 PauseScreen;
end;

Procedure TestCBreak;
Var
 B: Boolean;
 s: string;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                       GETCBREAK/SETCBREAK                            ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
 s:='Testing GetCBreak...';
 SetCBreak(TRUE);
 CheckDosError(0);
 GetCBreak(b);
 CheckDosError(0);
 if b then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE.');
  end;
{ actually setting Ctrl-C only works under DOS }  
{$ifdef go32v2}  
 s:='Testing GetCBreak...';
 SetCBreak(FALSE);
 CheckDosError(0);
 GetCBreak(b);
 CheckDosError(0);
 if NOT b then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE.');
  end;
{$endif}  
 PauseScreen;
end;


Procedure TestSystemDate;
var
 Year,Month, DayOfWeek, Day: Word;
 Year1,Month1, DayOfWeek1, Day1: Word;
 s: string;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                            GETDATE                                   ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Number of week should be consistent (0 = Sunday)               ');
 WriteLn(' Note: Year should contain full four digits.                          ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
 Month:=0;
 Day:=0;
 DayOfWeek:=0;
 Year:=0;
 GetDate(Year,Month,Day,DayOfWeek);
 CheckDosError(0);
 Write('DD-MM-YYYY : ',Day,'-',Month,'-',Year);
 WriteLn(' (',Week[DayOfWeek],')');
 PauseScreen;
  
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                            SETDATE                                   ');
 WriteLn('----------------------------------------------------------------------');
 { normal call }
 SetDate(Year,Month,Day);
 CheckDosError(0);
 { setdate and settime is not supported on most platforms }
{$ifdef go32v2}
 s:='Testing with invalid year....';
 SetDate(98,Month,Day);
 CheckDosError(0);
 GetDate(Year1,Month1,Day1,DayOfWeek1);
 CheckDosError(0);
 if (Year1 <> Year) or (Month1 <> month) or (Day1 <> Day) then
  Begin
     WriteLn(s+'FAILURE.');
  end
 else
  WriteLn(s+'Success.');

 SetDate(Year,Month,255);
 CheckDosError(0);
 s:='Testing with invalid day.....';
 GetDate(Year1,Month1,Day1,DayOfWeek1);
 CheckDosError(0);
 if (Year1 <> Year) or (Month1 <> month) or (Day1 <> Day) then
  Begin
     WriteLn(s+'FAILURE.');
  end
 else
  WriteLn(s+'Success.');

 SetDate(Year,13,Day);
 CheckDosError(0);
 s:='Testing with invalid month...';
 GetDate(Year1,Month1,Day1,DayOfWeek1);
 CheckDosError(0);
 if (Year1 <> Year) or (Month1 <> month) or (Day1 <> Day) then
  Begin
     WriteLn(s+'FAILURE.');
  end
 else
  WriteLn(s+'Success.');

 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Date should be 01-01-1998                                      ');
 WriteLn('----------------------------------------------------------------------');
 SetDate(1998,01,01);
 CheckDosError(0);
 GetDate(Year1,Month1,Day1,DayOfWeek1);
 CheckDosError(0);
 WriteLn('DD-MM-YYYY : ',Day1,'-',Month1,'-',Year1);
 SetDate(Year,Month,Day);
 CheckDosError(0);
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Date should be restored to previous value                      ');
 WriteLn('----------------------------------------------------------------------');
 GetDate(Year1,Month1,Day1,DayOfWeek1);
 CheckDosError(0);
 WriteLn('DD-MM-YYYY : ',Day1,'-',Month1,'-',Year1);
 PauseScreen;
{$endif}
end;

Procedure TestsystemTime;
Var
 Hour, Minute, Second, Sec100: word;
 Hour1, Minute1, Second1, Sec1001: word;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                            GETTIME                                   ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Hours should be in military format (0..23), and MSec in 0..100 ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
 Hour:=0;
 Minute:=0;
 Second:=0;
 Sec100:=0;
 GetTime(Hour,Minute,Second,Sec100);
 CheckDosError(0);
 WriteLn('HH:MIN:SEC (MS): ',Hour,':',Minute,':',Second,' (',Sec100,')');
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                            SETTIME                                   ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: GetTime should return the same value as the previous test.     ');
 WriteLn('----------------------------------------------------------------------');
 SetTime(36,Minute,Second,Sec100);
 CheckDosError(0);
 GetTime(Hour1,Minute1,Second1,Sec1001);
 CheckDosError(0);
 WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
 { actual settime is only supported under DOS }
{$ifdef go32v2} 
 SetTime(Hour,32000,Second,Sec100);
 CheckDosError(0);
 GetTime(Hour1,Minute1,Second1,Sec1001);
 CheckDosError(0);
 WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: GetTime should return  0:0:0                                   ');
 WriteLn('----------------------------------------------------------------------');
 SetTime(0,0,0,0);
 CheckDosError(0);
 GetTime(Hour1,Minute1,Second1,Sec1001);
 CheckDosError(0);
 WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: GetTime should return  approximately the original time         ');
 WriteLn('----------------------------------------------------------------------');
 SetTime(Hour,Minute,Second,Sec1001);
 CheckDosError(0);
 GetTime(Hour1,Minute1,Second1,Sec1001);
 CheckDosError(0);
 WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
 {$endif}
end;


Procedure TestFAttr;
Var
 F: File;
 Attr: Word;
 s: string;
Begin
 PauseScreen;
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                         GETFATTR / SETFATTR                          ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);

 WriteLn('Opening an invalid file...Success.');
 Assign(f,'');
 GetFAttr(f,Attr);
 CheckDosError(3);
 Assign(f,TestFName);
 WriteLn('Trying to open a valid file..Success.');
 GetFAttr(f,Attr);
 CheckDosError(0);
 {----------------------------------------------------------------}
 { 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);
 CheckDosError(0);
{$IFDEF EXTATTR}
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and ReadOnly<> 0 then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE. Read-only attribute not set.');
  end;
 { file should no longer be read only }
 s:='Removing read-only attribute...';
 SetFAttr(f,Archive);
 CheckDosError(0);
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and ReadOnly<> 0 then
  Begin
    WriteLn(s+'FAILURE. Read-only attribute still set.');
  end
 else
   WriteLn(s+'Success.');
{$ENDIF}

 s:='Setting hidden attribute on '+TestFName+'...';
 SetFAttr(f,Hidden);
 CheckDosError(0);
{$IFDEF EXTATTR}
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and Hidden<> 0 then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE. Hidden attribute not set.');
  end;

 { file should no longer be read only }
 s:='Removing hidden attribute...';
 SetFAttr(f,Archive);
 CheckDosError(0);
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and Hidden<> 0 then
  Begin
    WriteLn(s+'FAILURE. Hidden attribute still set.');
  end
 else
   WriteLn(s+'Success.');
{$ENDIF}

 s:='Setting system attribute on '+TestFName+'...';
 SetFAttr(f,SysFile);
 CheckDosError(0);
{$IFDEF EXTATTR}
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and SysFile<> 0 then
   WriteLn(s+'Success.')
 else
  Begin
    WriteLn(s+'FAILURE. SysFile attribute not set.');
  end;
 { file should no longer be read only }
 s:='Removing read-only attribute...';
 SetFAttr(f,Archive);
 CheckDosError(0);
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and Sysfile<> 0 then
  Begin
    WriteLn(s+'FAILURE. SysFile attribute still set.');
  end
 else
   WriteLn(s+'Success.');
{$ENDIF}

 s:='Setting Directory attribute on '+TestFName+'...';
 SetFAttr(f,Directory);
 CheckDosError(5);
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and Directory<> 0 then
  Begin
    WriteLn(s+'FAILURE. Directory Attribute set.');
  end
 else
   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);
 CheckDosError(5);
 GetFAttr(f,Attr);
 CheckDosError(0);
 if Attr and VolumeID<> 0 then
  Begin
    WriteLn(s+'FAILURE. Volume Attribute set.');
  end
 else
   WriteLn(s+'Success.');

 PauseScreen;
end;


Procedure TestFTime;
var
 s : string;
 F: File;
 Time: Longint;
 DT: DateTime;
 DT1 : Datetime; { saved values }
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                         GETFTIME / SETFTIME                          ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);

 {**********************************************************************}
 {********************** TURBO PASCAL BUG ******************************}
 { The File is not Open and DosError is still zero! THIS SHOULD NOT BE  }
 { SO IN FPC!                                                           }
 {**********************************************************************}
 {********************** TURBO PASCAL BUG ******************************}
 Write('Opening an invalid file...');
 Assign(f,'x');
 GetFTime(f,Time);
 CheckDosError(6);

 Write('Trying to open ',TestFName,'...');
 Assign(f,TestFName);
 Reset(f,1);
 GetFTime(f,Time);
 CheckDosError(0);
 UnpackTime(Time,Dt);
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: Hour should be in military format and year should be a 4 digit ');
 WriteLn('       number.                                                        ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn('DD-MM-YYYY : ',DT.Day,'-',DT.Month,'-',DT.Year);
 WriteLn('HH:MIN:SEC ',DT.Hour,':',DT.Min,':',DT.Sec);

 { SETFTIME / GETFTIME No Range checking is performed so the tests are }
 { very limited.                                                       }
 s:='Setting '+TestFName+' date/time to 01-28-1998:0:0:0...';
 dt1.Year:=1998;
 dt1.Month:=1;
 dt1.Day:=28;
 Dt1.Hour:=0;
 Dt1.Min:=0;
 Dt1.Sec:=0;
 PackTime(DT1,Time);
 CheckDosError(0);
 SetFTime(f,Time);
 CheckDosError(0);
 GetFTime(f,Time);
 CheckDosError(0);
 { Re-initialize the date time file }
 FillChar(Dt1,sizeof(dt1),#0);
 UnpackTime(Time,Dt1);
 if (Dt1.Year <> 1998) or (Dt1.Month<>1) or (Dt1.Day<>28) or
    (Dt1.Hour<>0) or (Dt1.Min <>0) or (Dt1.Sec<>0) then
   Begin
      WriteLn(s+'FAILURE.');
   end
 else
   WriteLn(s+'Success.');

 s:='Restoring old file time stamp...';
 Move(Dt,Dt1,sizeof(Dt));
 PackTime(DT1,Time);
 CheckDosError(0);
 SetFTime(f,Time);
 CheckDosError(0);
 GetFTime(f,Time);
 CheckDosError(0);
 { Re-initialize the date time file }
 FillChar(Dt1,sizeof(dt),#0);
 UnpackTime(Time,Dt1);
 if (Dt1.Year <> Dt.Year) or (Dt1.Month<>Dt.Month) or (Dt1.Day<>Dt.Day) or
    (Dt1.Hour<>Dt.Hour) or (Dt1.Min <> Dt.Min) or (Dt1.Sec<>Dt.Sec) then
   Begin
      WriteLn(s+'FAILURE.');
   end
 else
   WriteLn(s+'Success.');
 Close(f);
end;

Procedure TestFind;
var
 Search: SearchRec;
 DT: Datetime;
 Year, Month, Day, DayOfWeek: Word;
 Failure : Boolean;
 FoundDot, FoundDotDot: boolean;
 FoundDir : boolean;
 s : string;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                         FINDFIRST/ FINDNEXT                          ');
 WriteLn('----------------------------------------------------------------------');
 WriteLn(' Note: The full path should NOT be displayed.                         ');
 WriteLn('----------------------------------------------------------------------');
 CheckDosError(0);
 WriteLn('Trying to find an invalid file ('''') with Any Attribute...');
 FindFirst('',AnyFile,Search);
 CheckDosError(3);
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 WriteLn('Trying to find an invalid file ('''') with VolumeID attribute...');
 FindFirst('',VolumeID,Search);
 CheckDosError(3);
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 WriteLn('Trying to find an invalid file (''''zz.dat'''') with Any Attribute...');
 FindFirst('zz.dat',AnyFile,Search);
 CheckDosError(18);
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 WriteLn('Trying to find an invalid file (''''zz.dat'''') with VolumeID attribute...');
 FindFirst('zz.dat',VolumeID,Search);
 CheckDosError(18);
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 WriteLn('Trying to find an invalid file (''''zz.dat'''') with Directory attribute...');
 FindFirst('zz.dat',Directory,Search);
 CheckDosError(18);
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 s:='Looking for '+TestFName +' with Any Attribute...';
 FindFirst('*.DAT',AnyFile,Search);
 if Search.Name <> TestFName then
  Begin
    repeat
      FindNext(Search);
    until (DosError <> 0) OR (Search.Name = TestFName);
  end;
 if Search.Name <> TestFName then
 { At least testdos.dat should appear }
   WriteLn(s+'FAILURE. ',TestFName,' should be found.')
 else
   WriteLn(s+'Success.');

{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 { In addition to normal files          }
 { directory files should also be found }
 s:='Looking for '+TestFName +' with Directory Attribute...';
 FindFirst('*.DAT',Directory,Search);
 if DosError<> 0 then
   WriteLn(s+'FAILURE. ',TestFName,' should be found.')
 else
   WriteLn(s+'Success.');
 if Search.Name <> TestFName then
  Begin
    repeat
      FindNext(Search);
    until (DosError <> 0) OR (Search.Name = TestFName);
  end;
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}


 Write('Checking file stats of ',TestFName,'...');
 UnpackTime(Search.Time,DT);
 GetDate(Year, Month, Day, DayOfWeek);
 if (Search.Size <> Sizeof(week)) OR (DT.Year <> Year) OR (DT.Month <> Month)
    OR (DT.Day <> Day)
 then
  Begin
    WriteLn('FAILURE. Size/Date is different.')
  end
 else
   WriteLn('Success.');
 Write('Looking for ',TestFName,'...');
 FindFirst('*.D??',AnyFile,Search);
 { At least testdos.dat should appear }
 if DosError <> 0 then
   WriteLn('FAILURE. ',Testfname,' should be found.')
 else
   WriteLn('Success.');
 if Search.Name <> TestFName then
  Begin
    repeat
      FindNext(Search);
    until (DosError <> 0) OR (Search.Name = TestFName);
  end;
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 Write('Checking file stats of ',TestFName,'...');
 UnpackTime(Search.Time,DT);
 GetDate(Year, Month, Day, DayOfWeek);
 if (Search.Size <> Sizeof(week)) OR (DT.Year <> Year) OR (DT.Month <> Month)
    OR (DT.Day <> Day)
 then
  Begin
    WriteLn('FAILURE. Size/Date is different.')
  end
 else
   WriteLn('Success.');

 { Should show all possible files }
 FoundDot := False;
 FoundDotDot := False;
 Failure := True;
 FoundDir := False;
 s:='Searching using * wildcard (normal files + directories)...';
 FindFirst('*',Directory,Search);
 WriteLn(#9'Resources found (full path should not be displayed):');
 while DosError = 0 do
 Begin
    If Search.Name = TestDir then
    Begin
      If Search.Attr and Directory <> 0 then
        FoundDir := TRUE;
    end;
    If Search.Name = '.' then
    Begin
      If Search.Attr and Directory <> 0 then
         FoundDot := TRUE;
    End;
    if Search.Name = '..' then
    Begin
      If Search.Attr and Directory <> 0 then
         FoundDotDot := TRUE;
    End;
    { check for both . and .. special files }
    If Search.Name = TestFName1 then
      Failure := FALSE;
    WriteLn(#9+Search.Name);
    FindNext(Search);
 end;
{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}
 if not FoundDir then
   WriteLn(s+'FAILURE. Did not find '+TestDir+' directory')
 else
 if not FoundDot then
   WriteLn(s+'FAILURE. Did not find special ''''.'''' directory')
 else
 if not FoundDotDot then
   WriteLn(s+'FAILURE. Did not find special ''''..'''' directory')
 else
 if Failure then
   WriteLn(s+'FAILURE. Did not find special '+TestFName1+' directory')
 else
   WriteLn(s+'Success.');

{$IFDEF FPC}
 FindClose(Search);
{$ENDIF}

 s:='Searching using ??? wildcard (normal files + all special files)...';
 FindFirst('???',AnyFile,Search);
 FoundDot := False;
 FoundDotDot := False;
 WriteLn(#9'Resources found (full path should not be displayed):');
 while DosError = 0 do
 Begin
    If Search.Name = '.' then
    Begin
      If Search.Attr and Directory <> 0 then
         FoundDot := TRUE;
    End;
    if Search.Name = '..' then
    Begin
      If Search.Attr and Directory <> 0 then
         FoundDotDot := TRUE;
    End;
    WriteLn(#9+Search.Name);
    FindNext(Search);
 end;
 if not FoundDot then
   WriteLn(s+'FAILURE. Did not find special ''''.'''' directory')
 else
 if not FoundDotDot then
   WriteLn(s+'FAILURE. Did not find special ''''..'''' directory')
 else
   WriteLn(s+'Success.');
{$IFDEF FPC}
  FindClose(Search);
{$ENDIF}
 { search for volume ID }
 s:='Searching using * wildcard in ROOT (normal files + volume ID)...';
 FindFirst(RootPath+'*',Directory+VolumeID,Search);
 Failure := TRUE;
 WriteLn(#9'Resources found (full path should not be displayed):');
 while DosError = 0 do
 Begin
    If Search.Attr and VolumeID <> 0 then
    Begin
      Failure := FALSE;
      WriteLn(#9'Volume ID: '+Search.Name);
    End
    else
      WriteLn(#9+Search.Name);
    FindNext(Search);
 end;
 If Failure then
   WriteLn(s+'FAILURE. Did not find volume name')
 else
   WriteLn(s+'Success.');
{$IFDEF FPC}
  FindClose(Search);
{$ENDIF}


end;


Procedure TestSplit;
var
 P: PathStr;
 D: DirStr;
 N: NameStr;
 E: ExtStr;
 temp : string;
Begin
 WriteLn('----------------------------------------------------------------------');
 WriteLn('                                FSPLIT                                ');
 WriteLn('----------------------------------------------------------------------');
 Write('Testing invalid filename...');
 { Initialize names ot invalid values! }
 D:='Garbage';
 N:='Garbage';
 E:='GAR';
 { This is the path to be split }
 P:='';
 FSPlit(P,D,N,E);
 IF (length(D) <> 0) OR (length(N) <>0) OR (length(E) <> 0) THEN
   WriteLn('FAILURE. Same length as PATH (now length 0) should be returned.')
 else
   WriteLn('Success.');
 Write('Testing paramstr(0)...');
 { Initialize names ot invalid values! }
 D:='Garbage';
 N:='Garbage';
 E:='GAR';
 { This is the path to be split }
 P:=paramstr(0);
 FSPlit(P,D,N,E);
 IF length(p) <> (length(d)+length(n)+length(e)) then
   WriteLn('FAILURE. Same length as PATH should be returned.')
 else
   WriteLn('Success.');
 temp:=d+n+e;
 Write('Testing paramstr(0)...');
 if temp <> p then
   WriteLn('FAILURE. Concatenated string should be the same.')
 else
   WriteLn('Success.');
 WriteLn('PARAMSTR(0) = ', ParamStr(0));
 WriteLn('DRIVE + NAME + EXT = ',d+n+e);
{$ifdef go32v2}
 Write('Testing invalid path (..)...');
 P:='..';
 FSPlit(P,D,N,E);
 IF (length(D) <> 0) OR (length(N) <>0) OR (E <> P) THEN
   WriteLn('FAILURE. Length of drive and name should be zero and Ext should return Path')
 else
   WriteLn('Success.');
{$endif}
 Write('Testing invalid path (*)...');
 P:='*';
 FSPlit(P,D,N,E);
 IF (length(D) <> 0) OR (length(e) <>0) OR (N <> P) THEN
   WriteLn('FAILURE. Length of drive and name should be zero and Name should return Path')
 else
   WriteLn('Success.');
end;



var
 F: File;
 Attr : Word;
Begin
 TestDiskSize;
 TestDosVersion;
 TestEnvCount;
 TestVerify;
 TestSystemDate;
 TestSystemTime;

 { Now the file I/O functions                  }
 { Let us create a file that we will play with }
 Assign(f,TestFName);
 Rewrite(f,1);
 BlockWrite(f,Week,sizeof(Week));
 Close(f);
 Assign(f,TestFName1);
 Rewrite(f,1);
 Close(F);
 MkDir(TestDir);
 TestFAttr;
 TestFTime;
 TestCBreak;
 TestFind;
 PauseScreen;
 TestSplit;
 RmDir(TestDir);
 PauseScreen;
end.

{
  $Log$
  Revision 1.6  2001-11-23 01:57:30  carl
  * updated some tests so they work on other systems

  Revision 1.5  2001/08/12 18:55:00  carl
  + added printing the number of ENV vars.

  Revision 1.4  2001/08/09 01:14:57  carl
  * several updates and more error checking

  Revision 1.3  2001/06/06 01:31:24  carl
  * fsplit with .. only works for go32v2 version and TP

  Revision 1.2  2001/05/20 18:30:46  hajny
    + support for GO32v1 and GO32v2 added

  Revision 1.1  2001/05/19 12:10:02  peter
    * renamed to .pp

  Revision 1.1  2001/04/02 02:34:13  carl
  + initial version of complete test for dos unit


}