textshell.pas

一个能够在 Console Mode 下使用的 Shell 类 (1.00 版

(*

   TTextShell Class
   Simple Command Shell for Console Applications
   Version 01.002
   (C) 1996, Glen Why


   Version history:

   01.001 - The Caption property added
   01.002 - "Type" command added
   

*)

unit TextShell;

interface

{$IFDEF CONSOLE}

uses
 Windows, SysUtils, Classes;


type

  TShellCOmmandProc = procedure( const CmdLine :string );

  TShellCommand = class( TObject )
  private
    FProc :TShellCOmmandProc;
    FHint :String;
  public
    constructor Create( aHint :string; Proc :TShellCOmmandProc );
    procedure Execute( const CmdLine :String ); virtual;
    property Hint :String read FHint;
  end;

  TTextShell = class( TObject )
  private
    FCommands :TStringList;
    FPrompt :String;
    FOnCtrlC :TProcedure;
    FOnCtrlBreak :TProcedure;
    function GetCommands( index :integer ):TShellCOmmand;
    function GetCaption :string;
    procedure SetCaption( const Value :String );
  protected
    procedure CtrlC; virtual;
    procedure CtrlBreak; virtual;
    procedure ClearCommands;
    property Commands[ index :integer ] :TShellCOmmand
      read GetCommands;
  public
    ExitCode :Integer;
    constructor Create;
    destructor Destroy; override;
    procedure Initialize;
    procedure Run;
    procedure AddCommand( const Name, Hint :string; Proc :TShellCOmmandProc );
    property Prompt :string
      read FPrompt write FPrompt;
    property Caption :string
      read GetCaption write SetCaption;
    property OnCtrlC :TProcedure
      read FOnCtrlC write FOnCtrlC;
    property OnCtrlBreak :TProcedure
      read FOnCtrlBreak write FOnCtrlBreak;
  end;


var Shell :TTextShell = nil;

{$ENDIF}

implementation

uses
 consts;

{$Resource TextShell.res}
{$Include TextShell.inc}

{$IFDEF CONSOLE}

procedure DelProc( const CmdLine :string );
var
 F :TSearchRec;
 R :Integer;
 P :String;
begin
  if CmdLine = '' then
    begin
      writeln( LoadStr( SNoFile ) );
      exit;
    end;
  FillChar( F, SizeOf( F ), 0 );
  R := FindFirst( CmdLine, faAnyFile and ( not faDirectory ), F );
  try
    while R = 0 do
     begin
       write( format( LoadStr( SDeletePrompt ), [ F.Name ] ) );
       readln( p );
       if ( P <> '' ) and ( UpCase( P[ 1 ] ) = 'Y' ) then
         begin
           {$I-}
           DeleteFile( F.Name );
           if ( IOResult <> 0 )
            then writeln( format( LoadStr( SDelError ), [ F.Name ] ) );
         end;
       R := FindNext( F );
     end;
    writeln;
  finally
    FindClose( F );
  end;
end;


procedure TypeProc( const CmdLine :string );
var S, P :String; I :Integer; T :Text;
begin
  if CmdLine = '' then
    begin
      writeln( LoadStr( SNoFile ) );
      exit;
    end;
  if not FileExists( CmdLine ) then
    begin
      writeln( format( LoadStr( SNoFileExists ), [ CmdLine ] ) );
      exit;
    end;
  {$I-}
  assign( t, cmdLine );
  reset( t );
  if IOResult <> 0 then raise EFOpenError.CreateResFmt( SFOpenError, [ CmdLine ] );
  try
    I := 0;
    while not eof( t ) do
      begin
        inc( i );
        readln( t, s );
        writeln( s );
        if i mod 20 = 0 then
          begin
            writeln( LoadStr( SCOntinuePrompt ) );
            readln( p );
            if ( p <> '' ) and ( UpCase( p[ 1 ] ) = 'X' ) then break;
         end;
      end;
  finally
    close( t );
  end;
end;

procedure CloseShellProc( const CmdLine :string );
begin
  writeln( LoadStr( SShellClosing ) );
  Shell.ExitCode := -1;
end;

procedure HelpProc( const CmdLine :string );
var i :integer;
begin
 with Shell do
   begin
     writeln( LoadStr( SShellHelpTitle ) );
     for i := 0 to FCommands.Count - 1 do
     writeln(format('%s'#9'- %s',[FCOmmands.Strings[i],Commands[i].Hint]));
   end;
end;

procedure DirProc( const CmdLine :string );
var
 C, T :String;
 R, I :Integer;
 F :TSearchRec;
begin
  FillChar( F, SizeOf( F ), 0 );
  if ( CmdLine = '' )
    then C := '.\'
    else begin
      C := CmdLine;
      if C[ Length( C ) ] <> '\' then C := C + '\';
    end;
  C := C + '*.*';
  I := 0;
  R := FindFirst( C, faAnyFile, F );
  try
    while R = 0 do
     begin
       inc( I );
       T := '';
       if LongBool( F.Attr and faDirectory )
         then T := T + 'd' else T := T + '_';
       if LongBool( F.Attr and faReadOnly )
         then T := T + 'r' else T := T + '_';
       if LongBool( F.Attr and faHidden )
         then T := T + 'h' else T := T + '_';
       if LongBool( F.Attr and faSysFile )
         then T := T + 's' else T := T + '_';
       if LongBool( F.Attr and faArchive )
         then T := T + 'a' else T := T + '_';
       writeln( format( '%-25s'#9'%s'#9'%10d'#9'%s',
        [ F.Name, T, F.Size,
        DateTimeToStr( FileDateToDateTime( F.Time ) ) ] ) );
       if ( I mod 20 ) = 0 then
         begin
           writeln( LoadStr( SContinuePrompt ) );
           readln( T );
           if ( T <> '' ) and ( UpCase( T[ 1 ] ) = 'X' ) then break;
         end;
       R := FindNext( F );
     end;
    writeln;
    writeln( format( 'Total: %d files', [ i ] ) );
    writeln;
  finally
    FindClose( F );
  end;
end;

procedure CdProc( const CmdLine :string );
begin
  {$I-}
  ChDir( CmdLine );
  if IOResult <> 0 then writeln( format( LoadStr( SBadDirName ), [ CmdLine ] ) );
end;


{ TShellCOmmand }

constructor TShellCOmmand.Create( aHint :string; Proc :TShellCOmmandProc );
begin
  inherited Create;
  FHint := aHint;
  FProc := Proc;
end;

procedure TShellCOmmand.Execute( const CmdLine :string );
begin
 if assigned( FProc ) then FProc( CmdLine );
end;

{ TTextShell }

function TTextShell.GetCaption :string;
const MAX_CONSOLE_TITLE = 255;
begin
  SetLength( Result, MAX_CONSOLE_TITLE );
  SetLength( Result, GetConsoleTitle( PChar( result ), MAX_CONSOLE_TITLE ) );
end;

procedure TTextShell.SetCaption( const Value :String );
begin
 SetConsoleTitle( PChar( Value ) );
end;

procedure TTextShell.Initialize;
begin
 AddCOmmand( 'exit', LoadStr( SCloseHint ), CloseShellProc );
 AddCOmmand( 'close',LoadStr( SCloseHint ), CloseShellProc );
 AddCOmmand( 'bye', LoadStr( SCloseHint ), CloseShellProc );
 AddCOmmand( 'quit', LoadStr( SCloseHint ), CloseShellProc );
 AddCOmmand( 'fuck', LoadStr( SCloseHint ), CloseShellProc );
 AddCOmmand( 'damn', LoadStr( SCloseHint ), CloseShellProc );
 AddCommand( 'help', LoadStr( SHelpHint ), HelpProc );
 AddCommand( 'ls', LoadStr( SDirHint ), DirProc );
 AddCommand( 'dir', LoadStr( SDirHint ), DirProc );
 AddCommand( 'cd', LoadStr( SChDirHint ),CdProc );
 AddCOmmand( 'ty', LoadStr( STypeHint ), TypeProc );
 AddCOmmand( 'type', LoadStr( STypeHint ), TypeProc );
 AddCOmmand( 'del', LoadStr( SDelHint ), DelProc );
 AddCOmmand( 'rm', LoadStr( SDelHint ), DelProc );
end;


procedure TTextShell.Run;
var
 C, L :String;
 I :Integer;
begin
 repeat
  write( Prompt );
  readln( C );
  if ( C = '' ) then continue;
  I := Pos( ' ', C );
  if ( I > 0 ) then
    begin
      L := Trim( Copy( C, I, Length( C ) ) );
      Delete( C, I, Length( C ) );
    end
    else L := '';
  I := FCommands.IndexOf( C );
  if ( I < 0 )
    then writeln( format( LoadStr( SUnkCommand ), [ C ] ) )
    else
     try
       Commands[ i ].Execute( L );
     except
       on E :Exception do
         writeln(format(LoadStr(SException),[E.ClassName,E.Message]));
       else writeln( LoadStr( SUnkException ) );
     end;
 until ( ExitCode <> 0 );
end;

constructor TTextShell.Create;
begin
 if Shell <> nil then Raise Exception.CreateRes( SMultiInstance );
 inherited Create;
 FCommands := TStringList.Create;
 with FCommands do
   begin
     Sorted := true;
     Duplicates := dupError;
   end;
 FPrompt := '>';
end;

destructor TTextShell.Destroy;
begin
 if FCOmmands <> Nil then
   begin
     ClearCommands;
     FCommands.free;
   end;
end;

procedure TTextShell.ClearCommands;
var i :integer;
begin
 if FCommands <> Nil then
  with FCommands do
   for i := 0 to Count - 1 do
    if Objects[ i ] <> Nil then Objects[ i ].free;
end;

function TTextShell.GetCommands( index :integer ):TShellCOmmand;
begin
 result := TShellCOmmand( FCommands.Objects[ index ] );
end;

procedure TTextShell.AddCommand( const Name, Hint :string; Proc :TShellCOmmandProc );
var C : TShellCOmmand;
begin
  C := TShellCOmmand.Create( Hint, Proc );
  try
    FCommands.AddObject( Name, C );
  except
    C.Free;
    writeln( format( LoadStr( SAddError ), [ Name ] ) );
  end;
end;

procedure TTextShell.CtrlC;
begin
  if assigned( FOnCtrlC ) then FOnCtrlC;
end;

procedure TTextShell.CtrlBreak;
begin
  if assigned( FOnCtrlBreak ) then FOnCtrlBreak;
end;


function HandlerRoutine( dwCtrlType :Longint ) :Bool; stdcall;
begin
  result := false;
  if ( Shell = nil ) then exit;
  case dwCtrlType of
    CTRL_C_EVENT : Shell.CtrlC;
    CTRL_BREAK_EVENT : Shell.CtrlBreak;
    else exit;
  end;
  result := true;
end;

initialization
  shell := TTextShell.Create;
  writeln( 'Command Shell v1.0 (C) 1996 Glen Why' );
  writeln( '------------------------------------' );
  writeln;
  SetConsoleCtrlHandler( @HandlerRoutine, true );
finalization
  SetConsoleCtrlHandler( @HandlerRoutine, false );
  if assigned( shell ) then shell.Free;

{$ENDIF}
end.