{ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ}
{Û                                                       Û}
{Û      Virtual Pascal Examples. Version 2.1.            Û}
{Û      Dos unit test example.                           Û}
{Û      ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÛ}
{Û      Copyright (C) 1995-2000 vpascal.com              Û}
{Û                                                       Û}
{ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß}

program TestDos;

{&PMTYPE VIO}
{&Use32+,I-,Delphi-}

uses
  VpSysLow, Dos;

const
  {$IFDEF LINUX}
   sAutoExec    = 'autoexec.bat';
   sCmdShell    = 'bash';
   sDirAll      = 'ls * | less';
   sShell       = 'SHELL';
   sCommandSpec = '-c';
   sOSName      = 'Linux kernel';
  {$ELSE}
   sAutoExec    = 'C:\AUTOEXEC.BAT';
   sCmdShell    = 'CMD.EXE';
   sDirAll      = 'DIR *.* /P';
   sShell       = 'COMSPEC';
   sCommandSpec = '/C';
   {$IFDEF OS2}
    sOSName      = 'OS/2';
   {$ELSE}
    {$IFDEF WIN32}
     sOSName      = 'Windows';
    {$ELSE}
     sOSName      = 'Operating System';
    {$ENDIF}
   {$ENDIF}
  {$ENDIF ~LINUX}
  sTempFile    = 'temp.$$$';

const
  Days: array [0..6] of String[9] =
    ('Sunday','Monday','Tuesday', 'Wednesday','Thursday','Friday', 'Saturday');
  OffOn : array [Boolean] of String[3] = ('off','on');

function ConvertTime(Hour,Minute,Second,Sec100: Word): String;
var
  I: Integer;
  S1,S2: String[20];
begin
  Str(Hour:2, S1);
  Str(Minute:2, S2);
  S1 := S1 + ':' + S2;
  Str(Second:2, S2);
  S1 := S1 + ':' + S2;
  Str(Sec100:2, S2);
  S1 := S1 + ':' + S2;
  for i := 1 to Length(S1) do if S1[i] = ' ' then S1[i] := '0';
  ConvertTime := S1;
end;

function i2s(_Value, _Width: Integer): String;
var
  Res: String;
begin
  str(_Value:_Width, Res);
  i2s := Res;
end;

const
  LineNumber : Longint = 0;

procedure Line(const _s: String);
begin
  Writeln(_s);
  inc( LineNumber );
  if LineNumber mod 20 = 0 then
    begin
      Write(' ? Press <ENTER> to continue');
      readln;
    end;
end;

procedure Indent( const _s: String );
begin
  Line( '   '+_s );
end;

procedure NewTest( const _s: String );
begin
  Line( '' );
  Line( '-= '+_s );
end;

procedure TestDosVersion;
var
  strMajor: String;
  strMinor: String;
  Ver: SmallWord;
begin
  NewTest('DosVersion');
  Ver := DosVersion;
{$IFDEF OS2}
  StrMajor := i2s( Lo(Ver) div 10, 0 );
{$ELSE}
  StrMajor := i2s( Lo(Ver), 0 );
{$ENDIF}
  StrMinor := i2s( Hi(Ver), 0 );
  Indent(sOSName+' version '+strMajor+'.'+strMinor+' is running');
end;

procedure TestGetSetDate;
var
  Y,M,D,DoW: Word;
  Y1,M1,D1,DoW1: Word;
begin
  NewTest('GetDate');
  GetDate(Y, M, D, DoW);
  Indent('Today is '+Days[DoW]+', '+i2s(M,0)+'/'+i2s(D,0)+'/'+i2s(Y,0)+'.');

  NewTest('SetDate');
  SetDate(2001, 1, 1);
  GetDate(Y1, M1, D1, DoW1);
  Indent('1/1/2001 is a '+ Days[DoW1]+ '.');
  SetDate(Y, M, D);
end;

procedure TestGetSetTime;
var
  H,M,M1,H1,S,S1,Hund,Hund1: Word;
begin
  NewTest('GetTime');
  GetTime(H, M, S, Hund);
  Indent('Current time is '+ ConvertTime(H, M, S, Hund)+ '.');

  NewTest('SetTime');
  SetTime(0, 0, 0, 0);
  GetTime(H1, M1, S1, Hund1);
  Indent('Oooooorrrrrr, it''s time to sleep for a while: time is '+ ConvertTime(H1, M1, S1, Hund1)+ '.');
  SetTime(H, M, S, Hund);
end;

procedure TestVerify;
var
  Verify,Verify1: Boolean;
begin
  NewTest('GetVerify/SetVerify');
  GetVerify(Verify);
  Indent('Write verify is '+ OffOn[Verify]+'.');
  Verify := not(Verify);
  Write('   Turning write verify '+ OffOn[Verify]+' ... ');
  SetVerify(Verify);
  GetVerify(Verify1);
  if Verify = Verify1 then
    WriteLn(' done.')
  else
    WriteLn(' failed.');
  SetVerify(not Verify);
end;

procedure TestDiskFreeSize;
var
  i: Integer;
  Size: Longint;
  qSize: TQuad;
begin
  NewTest('DiskFree/DiskSize');
  for I := 3 to 26 do
  begin
    Size := DiskSize(i);
    if Size = -1 then Break;
    Indent('Drive '+ Chr(I + Ord('A') - 1)+ ':   '
          + 'Size = '+ i2s(Size div 1024,10)+ 'Kb  '
          + 'Free = '+ i2s(DiskFree(I) div 1024,10)+ 'Kb.');
  end;

  NewTest('VpSysLow.SysDiskFreeLong/SysDiskSizeLong');
  for I := 3 to 26 do
  begin
    qSize := SysDiskSizeLong(i);
    if qSize = -1 then
      Break;
    Indent('Drive '+ Chr(I + Ord('A') - 1)+ ':   '
          + 'Size = '+ i2s(Round(qSize/1024),10)+ 'Kb  '
          + 'Free = '+ i2s(Round(SysDiskFreeLong(I)/1024),10)+ 'Kb.');
  end;
end;

procedure TestGetSetFAttr;
var
  Attr,Attr1: Word;
  F: Text;

begin
  NewTest('GetFAttr/SetFAttr');
  Assign(F, sAutoExec);
  GetFAttr(F, Attr1);
  Indent('Make "'+ sAutoExec+ '" read only ...');
  if DosError = 0 then
  begin
    SetFAttr(F, Attr1 or ReadOnly);
    if DosError = 0 then
    begin
      GetFAttr(F, Attr);
      if DosError = 0 then
      begin
        Write('   ',sAutoExec, ' attributes = ', Attr,' =');
        if Attr and ReadOnly <> 0 then Write(' ReadOnly');
        if Attr and Hidden   <> 0 then Write(' Hidden');
        if Attr and SysFile  <> 0 then Write(' System');
        if Attr and Archive  <> 0 then Write(' Archive');
        Writeln;
        SetFAttr(F,Attr1);
      end;
    end;
  end;
  if DosError <> 0 then
    Indent('Error getting/setting file attributes, rc = '+ i2s(DosError,0));
end;

procedure TestGetSetFTime;
var
  F: Text;
  DT: DateTime;
  FTime: Longint;
begin
  { GetFTime/SetFTime }
  NewTest('GetFTime/SetFTime');
  Indent('Creating temporary file '+sTempFile+'...');
  Assign(F, sTempFile);
  Rewrite(F);                   { Create new file   }
  GetFTime(F, FTime);           { Get creation time }
  UnpackTime(FTime, DT);
  with DT do
  begin
    Indent('File datestamp is '+ i2s(Month,0)+ '/'+ i2s(Day,0)+ '/'+ i2s(Year,0)+ '.');
    Indent('File timestamp is '+ ConvertTime(Hour,Min,Sec,0)+ '.');
    Hour := 0;
    Min := 1;
    Sec := 0;
    PackTime(DT, FTime);
    Indent('Setting file timestamp to one minute after midnight');
    Reset(F);                   { Reopen file for reading }
    SetFTime(F, FTime);         { (Otherwise, close will update time) }
  end;
  Close(F);   { Close file }
end;

procedure TestFindFirstNextClose;
var
  SR: SearchRec;
begin
  NewTest('FindFirst/FindNext/FindClose');
  Indent('List of all files and directories in the current directory');
  Indent('       Name       Size');
  FindFirst('*.*', AnyFile, SR);
  while DosError = 0 do
    begin
      write('   ');
      if SR.Attr and Directory = Directory then
        Write('<DIR>      ')
      else
        write(SR.Size:11);
      Indent(SR.Name);
      FindNext(SR);
    end;
{$IFDEF VIRTUALPASCAL}
  FindClose(SR);
{$ENDIF}
end;

procedure TestFSearchGetEnv;
var
  FName: PathStr;
begin
  NewTest('FSearch/GetEnv');
  FName := FSearch(sCmdSHell, GetEnv('PATH'));
  if FName = '' then
    Indent(sCmdShell+ ' is not found')
  else
    Indent(sCmdShell+ ' full path is '+ FName);
end;

procedure TestEnvStrEnvCount;
var
  i: Integer;
begin
  NewTest('EnvStr/EnvCount');
  Indent('List of all environment variables');
  for I := 1 to EnvCount do
    Indent(i2s(I,4)+ ': '+ EnvStr(I));
end;

procedure TestFExpand;
begin
  NewTest('FExpand');
  Indent('Fully qualified name for "..\.\QQ" is '+ FExpand('..\.\qq'));
  Indent('Fully qualified name for "QQ"      is '+ FExpand('qq'));
  Indent('Fully qualified name for "\QQ"     is '+ FExpand('\qq'));
  Indent('Fully qualified name for "C:QQ"    is '+ FExpand('c:qq'));
end;

procedure TestFSplit;
  procedure Test(const FName: PathStr);
  var
    Dir: DirStr;
    Name: NameStr;
    Ext: ExtStr;
  begin
    FSplit(FName, Dir, Name, Ext);
    Indent('Full name: '+FName);
    Indent('      Dir="'+Dir+ '" Name="'+Name+ '" Ext="'+Ext+'"');
  end;
begin
  NewTest('FSplit');
  Test('D:\DIR\FILENAME.EXT');
  Test('D:\DIR.EXT\FILENAME');
  Test('DIR\FILENAME.EXT');
  Test('\FILENAME.EXT');
  Test('FILENAME.EXT');
  Test('FILENAME');
end;

procedure TestExec;
begin
  NewTest('GetEnv/Exec/ExecFlags/ExitCode');
{$IFDEF VIRTUALPASCAL}
  ExecFlags := efAsync;
{$ENDIF}

  { Show list of all files }
  Indent('Execute '+ sDirAll);
  Exec(GetEnv(sShell), sCommandSpec+' '+sDirAll);
  Indent('ExitCode = '+ i2s(DosExitCode,0) );
end;

begin
  {$IFDEF LINUX}
  FileSystem := fsDos;
  {$ENDIF}
  Writeln('Virtual Pascal TestDos v2.1 - test of DOS unit functionality');

  TestDosVersion;
  TestGetSetDate;
  TestGetSetTime;
  TestVerify;
  TestDiskFreeSize;
  TestGetSetFAttr;
  TestGetSetFTime;
  TestFindFirstNextClose;
  TestFSearchGetEnv;
  TestEnvStrEnvCount;
  TestFExpand;
  TestFSplit;
  TestExec;
end.
