{******************************************************************************}
{                                                                              }
{                                ConsoleMemo                                   }
{                                                                              }
{   Component derived from TMemo imitating the behaviour of a console like     }
{   the "DOS-box"                                                              }
{                                                                              }
{   original author:   Christian Rehn aka R2C2                                 }
{                                                                              }
{   Diese Klasse ist für alle gedacht, die meinen sie nützlich finden          }
{   zu müssen ;-)                                                              }
{   This class is intended for everybody thinking it is useful ;-)             }
{                                                                              }
{******************************************************************************}

//TODO: Command-Historx
//TODO: allow WordWrap

unit ConsoleMemo_class;

interface

uses
  StdCtrls, Classes, Graphics;

type
  TConsoleMemoReadMode = (rmNone, rmString, rmInteger, rmCommand);

  TCommandEvent = procedure(Sender: TObject; Command: string) of object;

  TConsoleMemo = class(TMemo)
  private
    FMinPos: Integer;
    FReadComplete: Boolean;
    FReadMode: TConsoleMemoReadMode;
    FCommandMode: Boolean;
    FPrompt: string;
    FOnCommand: TCommandEvent;
    procedure SetCommandMode(const Value: Boolean);
    procedure SetReadOnly(Value: Boolean);
    procedure SetWordWrap(Value: Boolean);
  protected
    procedure KeyPress(var Key: Char); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Click; override;
    procedure Change; override;
    property MinPos: Integer read FMinPos write FMinPos;
    procedure EnsureCaretPos; virtual;
    procedure ShowPrompt; virtual;
    procedure HandleCommand; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    property ReadMode: TConsoleMemoReadMode read FReadMode default rmNone;
    property Prompt: string read FPrompt write FPrompt;       
    function ReadString: string; virtual;
    function ReadInt: Integer; virtual;
  published
    property ReadOnly write SetReadOnly default True;
    property Color default clBlack;
    property WordWrap write SetWordWrap;
    property CommandMode: Boolean read FCommandMode write SetCommandMode default False;
    property OnCommand: TCommandEvent read FOnCommand write FOnCommand;
  end;

  procedure Register;

implementation

uses
  Forms, SysUtils, Windows;

procedure Register;
begin
  RegisterComponents('R2C2', [TConsoleMemo]);
end;

constructor TConsoleMemo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ReadOnly := True;
  FReadComplete := False;
  FReadMode := rmNone;
  FCommandMode := False;
  Color := clBlack;
  Font.Color := clSilver;
  Font.Name := 'Courier New';
  Font.Size := 10;
  ScrollBars := ssVertical;
  WordWrap := False;
end;

procedure TConsoleMemo.SetCommandMode(const Value: Boolean);
begin
  FCommandMode := Value;
  if Value then
  begin
    FReadMode := rmCommand;
    inherited ReadOnly := False;
    ShowPrompt;
  end
  else
  begin
    FReadMode := rmNone;
    inherited ReadOnly := True;
  end;
end;

procedure TConsoleMemo.SetReadOnly(Value: Boolean);
begin
  inherited ReadOnly := Value;
  if Value then
  begin
    FReadMode := rmNone;
    FCommandMode := False;
  end
  else
  begin
    FReadMode := rmCommand;
    FCommandMode := True;
  end;
end;

procedure TConsoleMemo.SetWordWrap(Value: Boolean);
begin
  // "disable" WordWrap, because it doesn't work with OnCommand yet
  inherited WordWrap := False;
end;

procedure TConsoleMemo.KeyPress(var Key: Char);
begin
  if (Key = #8) and (SelStart <= FMinPos) then
    Key := #0;  // discard backspace, if this would delete more than allowed

  inherited KeyPress(Key);
  if (FReadMode <> rmNone) and (Key = #13) then
  begin
    if FReadMode = rmCommand then
    begin
      HandleCommand;
      key := #0; // don't add another line
    end
    else
    begin
      FReadComplete := True;
    end;
  end;
  if (FReadMode = rmInteger)
    and (
         ((not (Key in ['0'..'9', #8])) and (SelStart > MinPos))
      or ((not (Key in ['0'..'9', #8, '-'])) and (SelStart = MinPos))
    ) then
  begin
    Key := #0;       // only accept numbers in integer-mode
  end;
  EnsureCaretPos;
end;

procedure TConsoleMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if (Key in  [VK_BACK, VK_LEFT]) and (SelStart <= FMinPos) then
    Key := 0; // discard backspace, if this would delete more than allowed

  // handle VK_UP separately, because SelStart isn't updated before EnsureCaretPos:
  if (Key = VK_UP) then
    Key := 0;

  inherited KeyDown(Key, Shift);
  EnsureCaretPos;
end;

procedure TConsoleMemo.Click;
begin
  inherited Click;
  if SelLength = 0 then // selecting text is allowed
    EnsureCaretPos;
end;

procedure TConsoleMemo.Change;
begin
  inherited Change;
  EnsureCaretPos;   //TODO: paste --> Int
end;

function TConsoleMemo.ReadInt: Integer;
var
  s: string;
begin
  FMinPos := SelStart; // maximum editable area
  FReadComplete := False;
  ReadOnly := False;
  FReadMode := rmInteger;
  while (not FReadComplete) and (not Application.Terminated) do
  begin
    Application.ProcessMessages;   //TODO: WaitForSingleObject?
  end;
  ReadOnly := True;
  FReadMode := rmNone;
  s := Trim(Copy(Lines.Text, FMinPos +1, Length(Lines.Text) - FMinPos + 1));
  Result := StrToIntDef(s, 0);
end;

function TConsoleMemo.ReadString: string;
var
  s: string;
begin
  FMinPos := SelStart;   // maximum editable area
  FReadComplete := False;
  ReadOnly := False;
  FReadMode := rmString;
  while (not FReadComplete) and (not Application.Terminated) do
  begin
    Application.ProcessMessages;  //TODO: WaitForSingleObject?
  end;
  ReadOnly := True;
  FReadMode := rmNone;
  s := Trim(Copy(Lines.Text, FMinPos+1, Length(Lines.Text) - FMinPos + 1));
  Result := s;
end;

procedure TConsoleMemo.EnsureCaretPos;
begin
  if (FReadMode <> rmNone) and (SelStart < FMinPos) then
  begin
    SelStart := FMinPos;
  end;
end;

procedure TConsoleMemo.ShowPrompt;

  function RemoveTraillingCRLF(s: string): string;
  begin
    while (Length(s) > 0) and (s[Length(s)] in [#13, #10]) do
      Delete(s, Length(s), 1);
    Result := s;
  end;

begin
  if Lines[Lines.Count -1] <> FPrompt then
  begin
    Lines.Add(FPrompt);
    if FPrompt <> '' then
      Lines.Text := RemoveTraillingCRLF(Lines.Text);
  end;
end;

procedure TConsoleMemo.HandleCommand;

  function RemovePrompt(s: string): string;
  begin
    Result := Trim(Copy(s, Length(FPrompt) +1, Length(s) - Length(FPrompt) -1));
  end;

begin   
  // add space so that Delphi realizes that there is a new line
  // otherwhise the last command is executed a second time:
  Lines.Text := Lines.Text + ' ';

  if Assigned(FOnCommand) then
    FOnCommand(Self, RemovePrompt(Lines[Lines.Count -1]));
  ShowPrompt;
  FMinPos := SelStart;   // maximum editable area
end;

end.