Fórum Reconstruindo o MS-DOS em delphi #229820

// MyDos command interpreter
// (c) André Werlang
// Last modified: 07/17/02

program MyDos;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;
   
const
  SysCmdsNames: array[0..21] of String = (´Cfg´, ´Cls´, ´Cd´, ´Md´, ´Rd´,
    ´Dir´, ´Deltree´, ´Ver´, ´Date´, ´Time´, ´Vol´, ´Copy´, ´Move´, ´Del´,
    ´Ren´, ´Attrib´, ´Prompt´, ´Echo´, ´Pause´, ´Rpt´, ´Help´, ´Exit´);

  ciExit = High(SysCmdsNames);

resourcestring
  SUnknownCommand = ´´´¬s´´ não é reconhecido como um comando interno´;
  SUnknownCommand2 = ´ou externo, um programa operável ou um arquivo em lotes.´;
  SInvalidSwitch = ´Opção inválida - "¬s". Tente ¬s /?´;
  SInvalidSyntax = ´A sintaxe do comando está incorreta.´;
  SNotImplemented = ´Este comando atualmente não foi implementado.´;
  SPause = ´Pressione qualquer tecla para continuar. . . ´;
  SEchoActive = ´ECHO está ativado´;
  SEchoDeactive = ´ECHO está desativado´;
  SAtlantis = ´Atlantis MyDos Interpreter Version 1.0´;
  SInitialized = ´MyDos inicializado.´;
  STerminated = ´MyDos terminado.´;
  SCopyright = ´Copyright © 2002 André Werlang´;
  SProgrammer = ´Programado por André Werlang, o cara mais genial da face da terra.´;

var
  Console: THandle;
  CmdLine, CurCmd, ParamLine: String;
  Switches: TSysCharSet;
  XorSwitches: TSysCharSet;
  CmdParams: array of String;
  SysCmds: array[0..21] of TProcedure;
  CmdIndex: Integer;
  LineCounter: Integer = 0;
  Report: TextFile;

  { variáveis que armazenam o estado do interpretador }
  DefPrompt: String; { $V=Versão $D=Data $H=Hora $U=Unidade $C=Caminho}
  EchoOn: Boolean;
  Color: Byte;

type
  TFileSystemFlags = set of (fsCaseSensitiveSearch, fsCasePreserved,
    fsUnicodeStored, fsPersistentAcls, fsFileCompression, fsVolumeCompressed);

  TVolumeInfo = record
    Drive: Char;
    VolumeName: String;
    FileSystem: String;
    SerialNumber: Cardinal;
    MaxNameLen: Cardinal;
    Flags: TFileSystemFlags;
  end;

procedure Write(S: String = ´´); forward;
procedure WriteLn(S: String = ´´); forward;

procedure InvalidSwitch(const Switch: String); forward;
procedure InvalidSyntax; forward;

function GetVolumeInfo(Path: String): TVolumeInfo;
var
  VolName, System: array[0..259] of Char;
  Flags: Cardinal;
begin
  Result.Drive := Path[1];
  GetVolumeInformation(PChar(Path), VolName, 260, @Result.SerialNumber,
    Result.MaxNameLen, Flags, System, 260);
  SetString(Result.VolumeName, VolName, StrLen(PChar(@VolName[1])) + 1);
  SetString(Result.FileSystem, System, StrLen(PChar(@System[1])) + 1);
  Result.Flags := TFileSystemFlags(Byte(Flags));
  if Flags and FS_VOL_IS_COMPRESSED <> 0 then
    Include(Result.Flags, fsVolumeCompressed);
end;

function Coord(X, Y: Smallint): TCoord;
begin
  Result.X := X;
  Result.Y := Y;
end;

function GetXY: TCoord;
var
  Info: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(Console, Info);
  Result := Info.dwCursorPosition;
end;

procedure GoToXY(X, Y: Byte);
var
  XY: TCoord;
begin
  XY.X := X;
  XY.Y := Y;
  SetConsoleCursorPosition(Console, XY);
end;

procedure NotImplemented;
begin
  WriteLn(SNotImplemented);
end;

procedure ClrLine(Y: Cardinal);
var
  XY: TCoord;
  Dummy: Cardinal;
  Info: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(Console, Info);
  XY := Coord(0, Y);
  FillConsoleOutputCharacter(Console, ´©´, Info.dwSize.X, XY, Dummy);
end;

procedure ClrEol;
var
  XY: TCoord;
  Dummy: Cardinal;
  Info: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(Console, Info);
  XY := Coord(0, GetXY.Y - 1);
  FillConsoleOutputCharacter(Console, ´ ´, Info.dwSize.X - 1, XY, Dummy);
  GoToXY(XY.X, XY.Y);
end;

procedure Cls;
var
  Dummy: Cardinal;
  Info: TConsoleScreenBufferInfo;
  Screen: Cardinal;
begin
  GetConsoleScreenBufferInfo(Console, Info);
  Screen := Info.dwSize.X * Info.dwSize.Y + Info.dwSize.X;
  FillConsoleOutputCharacter(Console, ´ ´, Screen, Coord(0, 0), Dummy);
  GoToXY(0, 0);
end;

procedure SetColor;
var
  Dummy: Cardinal;
  Info: TConsoleScreenBufferInfo;
  Size: Cardinal;
begin
  GetConsoleScreenBufferInfo(Console, Info);
  Size := Info.dwSize.X * Info.dwSize.Y + Info.dwSize.X;
  FillConsoleOutputAttribute(Console, Color, Size, Coord(0, 0), Dummy);
  SetConsoleTextAttribute(Console, Color);
end;

procedure Pause;
begin
  Write(SPause);
  ReadLn;
  ClrEol;
end;

procedure Echo;
begin
  if Trim(ParamLine) = ´´ then
    if EchoOn then
      WriteLn(SEchoActive)
    else
      WriteLn(SEchoDeactive)
  else
    case CmdParams[0][2] of
      ´N´: EchoOn := True;
      ´F´: EchoOn := False;
    else
      InvalidSyntax;
    end;
end;

function AnsiToOem(S: String): PChar;
begin
  GetMem(Result, Length(S) + 1);
  CharToOem(PChar(S), Result);
end;

procedure Write(S: String = ´´);
var
  P: PChar;
begin
  P := AnsiToOem(S);
  try
    System.Write(P);
  finally
    FreeMem(P);
  end;
end;

procedure WriteLn(S: String = ´´);
var
  P: PChar;
begin
  P := AnsiToOem(S);
  try
    System.WriteLn(P);
  finally
    FreeMem(P);
  end;
  Inc(LineCounter);
  if LineCounter = 23 then
  begin
    Pause;
    LineCounter := 0;
  end;
end;

procedure Cfg;
begin
  if Length(CmdParams) = 0 then Exit;
  if Pos(´C[´, CmdParams[0]) <> 0 then
  begin
    Color := StrToInt(´$´ + Copy(CmdParams[0], 3, 2));
    SetColor;
  end;
end;

procedure Cd;
begin
  if Length(CmdParams) = 0 then WriteLn(GetCurrentDir)
  else SetCurrentDir(CmdParams[0]);
end;

procedure Md;
begin
  CreateDir(CmdParams[0]);
end;

procedure Rd;
begin
  RemoveDir(CmdParams[0]);
end;

procedure Dir;
var
  Search: TSearchRec;
  Mask: String;
  NumFiles, FilesSizes, NumDirs: Cardinal;

  procedure WriteFileDesc;
  var
    OutStr: String;
  begin
    OutStr := DateToStr(FileDateToDateTime(Search.Time)) + 3232 +
      Format(´¬.2d:¬.2d´, [LongRec(Search.Time).Lo shr 11, LongRec(Search.Time).Lo shr 5 and 63]) + 9;
    if Search.Attr and faDirectory <> 0 then
      OutStr := OutStr + ´<DIR>´9
    else OutStr := OutStr + 9 + IntToStr(Search.Size);
    OutStr := OutStr + 9 + Search.Name;
    WriteLn(OutStr);
  end;

begin
  Mask := GetCurrentDir + ´\´;
  if Length(CmdParams) > 0 then
    Mask := Mask + CmdParams[0]
  else
    Mask := Mask + ´*.*´;
  SysCmds[10];
  WriteLn;
  WriteLn(´Pasta de ´ + ExtractFileDir(Mask));
  WriteLn;
  NumFiles := 0;
  FilesSizes := 0;
  NumDirs := 0;
  if FindFirst(Mask, faAnyFile and not (faSysFile or faHidden), Search) = 0 then
  repeat
    WriteFileDesc;
    if Search.Attr and faDirectory = 0 then Inc(NumFiles)
    else Inc(NumDirs);
    Inc(FilesSizes, Search.Size);
  until FindNext(Search) <> 0;
  FindClose(Search);
  WriteLn;
  WriteLn(99 + IntToStr(NumFiles) + ´ arquivo(s)´99 + IntToStr(FilesSizes) + ´ bytes´);
  WriteLn(99 + IntToStr(NumDirs) + ´ pasta(s)´99 + IntToStr(DiskFree(Ord(^C))) + ´ bytes´);
end;

procedure Deltree;
begin
  NotImplemented;
end;

procedure Ver;
begin
  WriteLn(SAtlantis);
end;

procedure Date;
begin
  WriteLn(´Data atual: ´ + DateToStr(SysUtils.Date));
end;

procedure Time;
var
  SystemTime: TSystemTime;
begin
  GetLocalTime(SystemTime);
  with SystemTime do
    WriteLn(Format(´Hora atual: ¬d:¬.2d:¬.2d,¬2.d´, [wHour, wMinute,
      wSecond, wMilliSeconds]));
end;

procedure Vol;
var
  Command: String;
begin
  if Length(CmdParams) = 0 then Command := ´C:\´
  else Command := CmdParams[0];
  with GetVolumeInfo(Command) do
  begin
    WriteLn(´ O volume na unidade ´ + Command[1] + ´ é ´ + VolumeName);
    WriteLn(´ O sistema de arquivos para ´ + Command[1] + ´ é ´ +  FileSystem);
    WriteLn(´ O número de série do volume é ´ + Format(´¬x-¬x´, [PWord(Integer(@SerialNumber) + 2)^, Word(SerialNumber)]));
  end;                                                           // SerialNumber shr 16
end;

procedure Copy;
begin
  NotImplemented;
end;

procedure Move;
begin
  NotImplemented;
end;

procedure Del;
begin
  NotImplemented;
end;

procedure Ren;
begin
  NotImplemented;
end;

procedure Attrib;
begin
  NotImplemented;
end;

procedure Prompt;
begin
  DefPrompt := ParamLine;
end;

procedure CmdNotFound;
begin
  WriteLn(Format(SUnknownCommand, [CurCmd]));
  WriteLn(SUnknownCommand2);
end;

procedure InvalidSwitch(const Switch: String);
begin
  WriteLn(Format(SInvalidSwitch, [Switch, CurCmd]));
end;

procedure InvalidSyntax;
begin
  WriteLn(SInvalidSyntax);
end;

procedure DoReport(const Msg: String; ReportTime: Boolean = True);
var
  S: String;
begin
  if ReportTime then S := DateTimeToStr(Now) + ´ - ´;
  S := S + Msg;
  System.WriteLn(Report, S);
end;

procedure Rpt;
begin
  DoReport(CmdParams[0]);
end;

procedure Help;
var
  Msg: String;
begin
  case CmdIndex of
    0: Msg := ´Exibe ou modifica a configuração do interpretador.´1010´Sintaxe:´10´CFG´;
    1: Msg := ´Limpa a tela.´1010´Sintaxe:´10´CLS´;
    2: Msg := ´Exibe o nome da pasta ou altera a pasta atual.´1010´Sintaxe:´10´CD´;
    3: Msg := ´Cria uma pasta´1010´Sintaxe:´10´MD´;
    4: Msg := ´Remove(exclui) uma pasta´1010´Sintaxe:´10´RD´;
    5: Msg := ´Exibe uma lista de arquivos e subpastas em uma pasta´1010´Sintaxe:´10´DIR´;
    6: Msg := ´Deltree´;
    7: Msg := ´Ver´;
    8: Msg := ´Date´;
    9: Msg := ´Time´;
    10: Msg := ´Vol´;
    11: Msg := ´Copy´;
    12: Msg := ´Move´;
    13: Msg := ´Del´;
    14: Msg := ´Attrib´;
    15: Msg := ´Help´;
  end;
  WriteLn(Msg);
end;

procedure WriteCopyright;
begin
  Ver;
  WriteLn(SCopyright);
  WriteLn(SProgrammer);
  WriteLn;
end;

procedure WriteCurrentDir;
begin
  Write(GetCurrentDir + ´>´);
end;

procedure WritePrompt;
begin
  if EchoOn then Exit;
  Write(GetCurrentDir + ´>´);
end;

function HasSwitch(const Switch: Char): Boolean;
begin
  Result := (Switch in Switches) and not (Switch in XorSwitches);
end;

procedure AddParam(const ParamStr: String; High: Integer);
begin
  SetLength(CmdParams, High);
  CmdParams[High - 1] := ParamStr;
end;

procedure StripCmd;
const
  Alpha = [´A´..´Z´, ´a´..´z´];
  Spaces = [9, 32];
var
  P, Start: PChar;
  I: Integer;
begin
  I := 0;
  Switches := [];
  XorSwitches := [];
  SetLength(CmdParams, 0);
  P := PChar(CmdLine);
  Start := P;
  while P^ in Alpha do Inc(P);
  SetString(CurCmd, Start, P - Start);
  SetString(ParamLine, P, StrLen(P));
  ParamLine := Trim(ParamLine);
  while P^ <> #0 do
  begin
    while P^ in Spaces do Inc(P);

    case P^ of
      ´/´:
        begin
          Inc(P);
          if P^ = ´-´ then
          begin
            Inc(P);
            Include(XorSwitches, P^);
          end else
            Include(Switches, P^);
        end;

      ´"´:
        begin
          Inc(P);
          Start := P;
          while P^ <> ´"´ do
            if P^ = 0 then  
            begin
              InvalidSyntax;
              Exit;
            end else
              Inc(P);
          Inc(I);
          AddParam(String(P - Start), I);
        end;

    else
      begin
        Start := P;
        while not (P^ in Spaces) do if P^ = #0 then Break else Inc(P);
        Inc(I);
        SetLength(CmdParams, I);
        SetString(CmdParams[I - 1], Start, P - Start);
      end;
    end;
  end;
end;

procedure FindCmd;
var
  I: Integer;
begin
  CmdIndex := -1;
  for I := 0 to High(SysCmds) do
    if AnsiSameText(CurCmd, SysCmdsNames[I]) then
    begin
      CmdIndex := I;
      Break;
    end;
end;

procedure ProcessCmd;
begin
  while True do
  begin
    ReadLn(CmdLine);
    CmdLine := Trim(CmdLine);
    if CmdLine <> ´´ then
    begin
      StripCmd;
      FindCmd;
      if CmdIndex = -1 then
        CmdNotFound
      else
        if HasSwitch(´?´) then
          Help
        else
        try
          if CmdIndex = ciExit then Exit;
          LineCounter := 0;
          SysCmds[CmdIndex];
        except
          on E: Exception do DoReport(E.Message); 
        end;
      WriteLn;
    end;
    WritePrompt;
  end;
end;

procedure AssignCmds;
begin                           
  SysCmds[0] := Cfg;
  SysCmds[1] := Cls;
  SysCmds[2] := Cd;
  SysCmds[3] := Md;
  SysCmds[4] := Rd;
  SysCmds[5] := Dir;
  SysCmds[6] := Deltree;
  SysCmds[7] := Ver;
  SysCmds[8] := Date;
  SysCmds[9] := Time;
  SysCmds[10] := Vol;
  SysCmds[11] := Copy;
  SysCmds[12] := Move;
  SysCmds[13] := Del;
  SysCmds[14] := Ren;
  SysCmds[15] := Attrib;
  SysCmds[16] := Prompt;
  SysCmds[17] := Echo;
  SysCmds[18] := Pause;
  SysCmds[19] := Rpt;
  SysCmds[20] := Help;
end;

function ExpandStr(const S: String): String;
var
  Buf: array[0..MAX_PATH - 1] of Char;
begin
  SetString(Result, Buf, ExpandEnvironmentStrings(PChar(S), Buf, MAX_PATH));
end;

begin
  Console := GetStdHandle(STD_OUTPUT_HANDLE);
  AssignCmds;
  Assign(Report, ´mydos.inf´);      // if FileExists(´mydos.inf´) then
  {$I-}                             //   Append(Report)
  Append(Report);                   // else
  {$I+}                             //   Rewrite(Report);
  if IOResult <> 0 then Rewrite(Report);
  try
    DoReport(1310´´1310, False);
    DoReport(SInitialized);
    WriteCopyright;
    SetCurrentDir(ExpandStr(´¬HOMEPATH¬´));
    WritePrompt;
    ProcessCmd;
  finally
    DoReport(STerminated);
    CloseFile(Report);
  end;
end.