Sordie.co.uk

libsassy/libSassy.Console.pas

Raw

{(
 )) libSassy.Console
((    Console window library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.Console;

interface

uses
  Winapi.Windows,

  libSassy.Strings,
  libSassy.Streams;

type
  TConsole = class;

{$REGION 'TConsoleCursor'}
  TConsoleCursor = class
  private
    fConsole: TConsole;

    fSaveX: Integer;
    fSaveY: Integer;

    function  GetCoord(Index: Integer): Integer;
    procedure SetCoord(Index, Value: Integer);

    function  GetVisible: Boolean;
    procedure SetVisible(Value: Boolean);

    function  GetSize: Integer;
    procedure SetSize(Value: Integer);
  public
    constructor Create(AConsole: TConsole);

    procedure GotoXY(const X, Y: Integer);

    procedure Save;    inline;
    procedure Restore; inline;

    property Console: TConsole read fConsole;

    property SaveX: Integer read fSaveX write fSaveX;
    property SaveY: Integer read fSaveY write fSaveY;

    property X: Integer index 0 read GetCoord write SetCoord;
    property Y: Integer index 1 read GetCoord write SetCoord;

    property Visible: Boolean read GetVisible write SetVisible;
    property Size:    Integer read GetSize    write SetSize;
  end;
{$ENDREGION}

{$REGION 'TConsoleColour'}
  TConsoleColourElement = (ceRed, ceGreen, ceBlue, ceIntensity);
  TConsoleColourSet     = set of TConsoleColourElement;

  TConsoleColour = class
  private
    fConsole: TConsole;

    function  GetColour: Cardinal;
    procedure SetColour(Value: Cardinal);

    function  GetForeground: TConsoleColourSet;
    procedure SetForeground(Value: TConsoleColourSet);

    function  GetBackground: TConsoleColourSet;
    procedure SetBackground(Value: TConsoleColourSet);
  public
    constructor Create(AConsole: TConsole);

    class function MakeColour(R, G, B, I: Boolean): TConsoleColourSet;

    property Console: TConsole read fConsole;

    property Colour: Cardinal read GetColour write SetColour;

    property Foreground: TConsoleColourSet read GetForeground write SetForeground;
    property Background: TConsoleColourSet read GetBackground write SetBackground;
  end;
{$ENDREGION}

{$REGION 'TConsole'}
  TConsole = class(TStream)
  private
    fInput:  THandle;
    fOutput: THandle;

    fCursor: TConsoleCursor;
    fColour: TConsoleColour;

    class var fActiveConsole: TConsole;

    class function  GetActiveConsole: TConsole;        static;
    class procedure SetActiveConsole(Value: TConsole); static;
  public
    const
        HomeCoord: TCoord = (X:0; Y:0);

    class constructor Create;

    constructor Create(AOutput: Cardinal = STD_OUTPUT_HANDLE; AInput: Cardinal = STD_INPUT_HANDLE);
    destructor  Destroy; override;

    procedure Clear(const Ch: Char = #32);

    function InternalRead (var   Data; const Size: Int64): Int64; override;
    function InternalWrite(const Data; const Size: Int64): Int64; override;

    procedure Activate; inline;

    function GetScreenInfo: TConsoleScreenBufferInfo; inline;
    function GetCursorInfo: TConsoleCursorInfo;       inline;

    property Input:  THandle read fInput  write fInput;
    property Output: THandle read fOutput write fOutput;

    property Cursor: TConsoleCursor read fCursor;
    property Colour: TConsoleColour read fColour;

    class property ActiveConsole: TConsole read GetActiveConsole write SetActiveConsole;
  end;
{$ENDREGION}

{$REGION 'Stock console'}
function Console: TConsole;
{$ENDREGION}

{$REGION 'Colours'}
const
  ccBlack   = [];
  ccNavy    = [ceBlue];
  ccGreen   = [ceGreen];
  ccCyan    = [ceBlue, ceGreen];
  ccMaroon  = [ceRed];
  ccPurple  = [ceBlue, ceRed];
  ccBrown   = [ceGreen, ceRed];
  ccGrey    = [ceBlue, ceGreen, ceRed];
  ccBlue    = [ceIntensity, ceBlue];
  ccLime    = [ceIntensity, ceGreen];
  ccAqua    = [ceIntensity, ceBlue, ceGreen];
  ccRed     = [ceIntensity, ceRed];
  ccFuchsia = [ceIntensity, ceBlue, ceRed];
  ccYellow  = [ceIntensity, ceGreen, ceRed];
  ccWhite   = [ceIntensity, ceBlue, ceGreen, ceRed];
{$ENDREGION}

implementation

{$REGION 'TConsoleCursor'}
function TConsoleCursor.GetCoord;
begin
  case Index of
    0: Result := fConsole.GetScreenInfo.dwCursorPosition.X;
    1: Result := fConsole.GetScreenInfo.dwCursorPosition.Y;
  else
    Result := 0;
  end;
end;

procedure TConsoleCursor.SetCoord;
begin
  case Index of
    0: GotoXY(Value, Y);
    1: GotoXY(X, Value);
  end;
end;

function TConsoleCursor.GetVisible;
begin
  Result := fConsole.GetCursorInfo.bVisible;
end;

procedure TConsoleCursor.SetVisible;
var
  Info: TConsoleCursorInfo;
begin
  Info.dwSize   := fConsole.GetCursorInfo.dwSize;
  Info.bVisible := Value;

  SetConsoleCursorInfo(fConsole.Output, Info);
end;

function TConsoleCursor.GetSize;
begin
  Result := fConsole.GetCursorInfo.dwSize;
end;

procedure TConsoleCursor.SetSize;
var
  Info: TConsoleCursorInfo;
begin
  Info.dwSize   := Value;
  Info.bVisible := fConsole.GetCursorInfo.bVisible;

  SetConsoleCursorInfo(fConsole.Output, Info);
end;

constructor TConsoleCursor.Create;
begin
  inherited Create;

  fConsole := AConsole;
end;

procedure TConsoleCursor.GotoXY;
var
  Coord: TCoord;
begin
  Coord.X := X;
  Coord.Y := Y;

  SetConsoleCursorPosition(fConsole.Output, Coord);
end;

procedure TConsoleCursor.Save;
begin
  fSaveX := X;
  fSaveY := Y;
end;

procedure TConsoleCursor.Restore;
begin
  GotoXY(fSaveX, fSaveY);
end;
{$ENDREGION}

{$REGION 'TConsoleColour'}
function TConsoleColour.GetColour;
begin
  Result := fConsole.GetScreenInfo.wAttributes;
end;{TConsoleColour.GetColour}

procedure TConsoleColour.SetColour;
begin
  SetConsoleTextAttribute(fConsole.Output, Value);
end;{TConsoleColour.SetColour}

function TConsoleColour.GetForeground;
var
  c: Cardinal;
begin
  c := Colour;

  Result := [];

  if (c and FOREGROUND_BLUE)      = FOREGROUND_BLUE      then Result := Result + [ceBlue];
  if (c and FOREGROUND_GREEN)     = FOREGROUND_GREEN     then Result := Result + [ceGreen];
  if (c and FOREGROUND_RED)       = FOREGROUND_RED       then Result := Result + [ceRed];
  if (c and FOREGROUND_INTENSITY) = FOREGROUND_INTENSITY then Result := Result + [ceIntensity];
end;{TConsoleColour.GetForeground}

procedure TConsoleColour.SetForeground;
var
  c: Cardinal;
begin
  c := Colour and (BACKGROUND_BLUE or BACKGROUND_GREEN or BACKGROUND_RED or BACKGROUND_INTENSITY);

  if ceBlue      in Value then c := c or FOREGROUND_BLUE;
  if ceGreen     in Value then c := c or FOREGROUND_GREEN;
  if ceRed       in Value then c := c or FOREGROUND_RED;
  if ceIntensity in Value then c := c or FOREGROUND_INTENSITY;

  Colour := c;
end;{TConsoleColour.SetForeground}

function TConsoleColour.GetBackground;
var
  c: Cardinal;
begin
  c := Colour;

  Result := [];

  if (c and BACKGROUND_BLUE)      = BACKGROUND_BLUE      then Result := Result + [ceBlue];
  if (c and BACKGROUND_GREEN)     = BACKGROUND_GREEN     then Result := Result + [ceGreen];
  if (c and BACKGROUND_RED)       = BACKGROUND_RED       then Result := Result + [ceRed];
  if (c and BACKGROUND_INTENSITY) = BACKGROUND_INTENSITY then Result := Result + [ceIntensity];
end;{TConsoleColour.GetBackground}

procedure TConsoleColour.SetBackground;
var
  c: Cardinal;
begin
  c := Colour and (FOREGROUND_BLUE or FOREGROUND_GREEN or FOREGROUND_RED or FOREGROUND_INTENSITY);

  if ceBlue      in Value then c := c or BACKGROUND_BLUE;
  if ceGreen     in Value then c := c or BACKGROUND_GREEN;
  if ceRed       in Value then c := c or BACKGROUND_RED;
  if ceIntensity in Value then c := c or BACKGROUND_INTENSITY;

  Colour := c;
end;{TConsoleColour.SetBackground}

constructor TConsoleColour.Create;
begin
  inherited Create;

  fConsole := AConsole;
end;{TConsoleColour.Create}

class function TConsoleColour.MakeColour;
begin
  Result := [];

  if R then Result := Result + [ceRed];
  if G then Result := Result + [ceGreen];
  if B then Result := Result + [ceBlue];
  if I then Result := Result + [ceIntensity];
end;{TConsoleColour.MakeColour}
{$ENDREGION}

{$REGION 'TConsole'}
class function TConsole.GetActiveConsole;
begin
  if fActiveConsole = nil then
    SetActiveConsole(Console);

  Result := fActiveConsole;
end;

class procedure TConsole.SetActiveConsole;
begin
  if Value = nil then Value := Console;

  if not SetConsoleActiveScreenBuffer(Value.Output) then exit;

  fActiveConsole := Value;

  SetStdHandle(STD_INPUT_HANDLE,  Value.Input);
  SetStdHandle(STD_OUTPUT_HANDLE, Value.Output);
  SetStdHandle(STD_ERROR_HANDLE,  Value.Output);
end;

class constructor TConsole.Create;
begin
  fActiveConsole := nil;
end;

constructor TConsole.Create;
begin
  inherited Create;

  case AInput of
    STD_INPUT_HANDLE: fInput := GetStdHandle(STD_INPUT_HANDLE);
  else
    fInput := AInput;
  end;

  case AOutput of
    STD_OUTPUT_HANDLE, STD_ERROR_HANDLE:
    begin
      AllocConsole;

      fOutput := GetStdHandle(AOutput);
    end;

    0: fOutput := CreateConsoleScreenBuffer(GENERIC_READ or GENERIC_WRITE, 0, nil, CONSOLE_TEXTMODE_BUFFER, nil);
  else
    fOutput := AOutput;
  end;

  fCursor := TConsoleCursor.Create(Self);
  fColour := TConsoleColour.Create(Self);
end;

destructor TConsole.Destroy;
begin
  fColour.Free;
  fCursor.Free;

  CloseHandle(fInput);
  CloseHandle(fOutput);

  inherited;
end;

procedure TConsole.Clear(const Ch: Char = #32);
var
  s, n: LongWord;
begin
  with GetScreenInfo.dwSize do s := X * Y;

  FillConsoleOutputCharacter(fOutput, Ch,            s, HomeCoord, n);
  FillConsoleOutputAttribute(fOutput, Colour.Colour, s, HomeCoord, n);

  Cursor.x := HomeCoord.X;
  Cursor.y := HomeCoord.Y;
end;

function TConsole.InternalRead;
var
  r: Cardinal;
begin
  ReadConsole(fInput, @Data, Size div SizeOf(Char), r, nil);

  Result := r;
end;

function TConsole.InternalWrite;
var
  w: Cardinal;
begin
  WriteConsole(fOutput, @Data, Size div SizeOf(Char), w, nil);

  Result := w;
end;

procedure TConsole.Activate;
begin
  TConsole.ActiveConsole := Self;
end;

function TConsole.GetScreenInfo;
begin
  GetConsoleScreenBufferInfo(fOutput, Result);
end;

function TConsole.GetCursorInfo;
begin
  GetConsoleCursorInfo(fOutput, Result);
end;
{$ENDREGION}

{$REGION 'Stock console'}
var
  _Console: TConsole = nil;

function Console;
begin
  if _Console = nil then
  begin
    _Console := TConsole.Create(STD_OUTPUT_HANDLE);
    _Console.FreeAfterOp := False;
  end;

  Result := _Console;
end;
{$ENDREGION}

initialization

finalization
  if _Console <> nil then _Console.Free;

end.