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

{******************************************}
{  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 ATARI}
        {$DEFINE EXTATTR}
{$ENDIF}
{$IFDEF WINCE}
        {$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 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! }
 TestExt   = 'DAT';
 has_errors : boolean = false;


Procedure PauseScreen;
var
 ch: char;
Begin
 { this is the non-interacting version
   so we disable this
 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+')');
      has_errors:=true;
    end
  else
    WriteLn('Success.');
 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('----------------------------------------------------------------------');
{$ifndef beos}
 {This should be disabled under BeOS : maybe this is a BeOS bug (or a feature ?) 
  in stime function.
  When you set 36 hours, the time AND the date are changed
  It seems it is a valid value under BeOS, but you have jump in the future :
  36 hours in the future from the begining of the starting day, more or less
  depending on your timezone.
  For example in Paris, in summer (2 hours from GMT time zone),
  this call set the clock to 14:<Minute>:<Second>:<Sec100> the next day !}
 SetTime(36,Minute,Second,Sec100);
 CheckDosError(0);
{$endif}
 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 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('Assigning an invalid file...');
 Assign(f,'x');
 GetFTime(f,Time);
{$ifndef macos}
 CheckDosError(6);
{$else}
 CheckDosError(2); {Since on MacOS, GetFTime works even for non-opened files}
{$endif}

 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}

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

 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',Archive+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('*',Archive+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
{$ifndef wince}
 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
{$endif wince}
 if Failure then
   WriteLn(s+'FAILURE. Did not find special '+TestFName1+' directory')
 else
   WriteLn(s+'Success.');

{$ifdef go32v2}
 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}
{$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
{$IFDEF MACOS}
 pathTranslation:= true;
{$ENDIF}
 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);
 TestFTime;
 TestFind;
 PauseScreen;
 TestSplit;
 RmDir(TestDir);
 PauseScreen;

 { Cleanup }
 {$I-}
  assign(f,TestFName);
  erase(f);
  assign(f,TestFName1);
  erase(f);
 {$I+}
 if ioresult<>0 then;

 if has_errors then
   halt(1);
end.