jclconsole.pas

East make Tray Icon in delphi

    function PutEvents(const Events: TJclInputRecordArray): DWORD; overload;
    function GetEvent: TInputRecord;
    function PeekEvent: TInputRecord;
    function PutEvent(const Event: TInputRecord): Boolean;
    property Console: TJclConsole read FConsole;
    property Handle: THandle read FHandle;
    property Mode: TJclConsoleInputModes read GetMode write SetMode;
    property EventCount: DWORD read GetEventCount;
  end;

implementation

uses
  {$IFDEF FPC}
  WinSysUt, JwaWinNT,
  {$ENDIF FPC}
  Math, TypInfo,
  JclFileUtils, JclResources;

const
  COMMON_LVB_LEADING_BYTE    = $0100; // Leading Byte of DBCS
  COMMON_LVB_TRAILING_BYTE   = $0200; // Trailing Byte of DBCS
  COMMON_LVB_GRID_HORIZONTAL = $0400; // DBCS: Grid attribute: top horizontal.
  COMMON_LVB_GRID_LVERTICAL  = $0800; // DBCS: Grid attribute: left vertical.
  COMMON_LVB_GRID_RVERTICAL  = $1000; // DBCS: Grid attribute: right vertical.
  COMMON_LVB_REVERSE_VIDEO   = $4000; // DBCS: Reverse fore/back ground attribute.
  COMMON_LVB_UNDERSCORE      = $8000; // DBCS: Underscore.

  COMMON_LVB_SBCSDBCS        = $0300; // SBCS or DBCS flag.

const
  FontColorMask: Word = FOREGROUND_BLUE or FOREGROUND_GREEN or FOREGROUND_RED;
  BackColorMask: Word = BACKGROUND_BLUE or BACKGROUND_GREEN or BACKGROUND_RED;
  FontStyleMask: Word = COMMON_LVB_LEADING_BYTE or COMMON_LVB_TRAILING_BYTE or
    COMMON_LVB_GRID_HORIZONTAL or COMMON_LVB_GRID_LVERTICAL or COMMON_LVB_GRID_RVERTICAL or
    COMMON_LVB_REVERSE_VIDEO or COMMON_LVB_UNDERSCORE or COMMON_LVB_SBCSDBCS;

  FontColorMapping: array [TJclScreenFontColor] of Word =
   (0,
    FOREGROUND_BLUE,
    FOREGROUND_GREEN,
    FOREGROUND_RED,
    FOREGROUND_BLUE or FOREGROUND_GREEN,
    FOREGROUND_BLUE or FOREGROUND_RED,
    FOREGROUND_GREEN or FOREGROUND_RED,
    FOREGROUND_BLUE or FOREGROUND_GREEN or FOREGROUND_RED);

  BackColorMapping: array [TJclScreenBackColor] of Word =
   (0,
    BACKGROUND_BLUE,
    BACKGROUND_GREEN,
    BACKGROUND_RED,
    BACKGROUND_BLUE or BACKGROUND_GREEN,
    BACKGROUND_BLUE or BACKGROUND_RED,
    BACKGROUND_GREEN or BACKGROUND_RED,
    BACKGROUND_BLUE or BACKGROUND_GREEN or BACKGROUND_RED);

  FontStyleMapping: array [TJclScreenFontStyle] of Word =
   (COMMON_LVB_LEADING_BYTE,    // Leading Byte of DBCS
    COMMON_LVB_TRAILING_BYTE,   // Trailing Byte of DBCS
    COMMON_LVB_GRID_HORIZONTAL, // DBCS: Grid attribute: top horizontal.
    COMMON_LVB_GRID_LVERTICAL,  // DBCS: Grid attribute: left vertical.
    COMMON_LVB_GRID_RVERTICAL,  // DBCS: Grid attribute: right vertical.
    COMMON_LVB_REVERSE_VIDEO,   // DBCS: Reverse fore/back ground attribute.
    COMMON_LVB_UNDERSCORE,      // DBCS: Underscore.
    COMMON_LVB_SBCSDBCS);       // SBCS or DBCS flag.

const
  InputModeMapping: array [TJclConsoleInputMode] of DWORD =
    (ENABLE_LINE_INPUT, ENABLE_ECHO_INPUT, ENABLE_PROCESSED_INPUT,
     ENABLE_WINDOW_INPUT, ENABLE_MOUSE_INPUT);

  OutputModeMapping: array [TJclConsoleOutputMode] of DWORD =
    (ENABLE_PROCESSED_OUTPUT, ENABLE_WRAP_AT_EOL_OUTPUT);

var
  g_DefaultConsole: TJclConsole = nil;

function CtrlHandler(CtrlType: DWORD): BOOL; stdcall;
var
  Console: TJclConsole;
begin
  try
    Console := TJclConsole.Default;
    Result := True;
    case CtrlType of
      CTRL_C_EVENT:
        if Assigned(Console.OnCtrlC) then
          Console.OnCtrlC(Console);
      CTRL_BREAK_EVENT:
        if Assigned(Console.OnCtrlBreak) then
          Console.OnCtrlBreak(Console);
      CTRL_CLOSE_EVENT:
        if Assigned(Console.OnClose) then
          Console.OnClose(Console);
      CTRL_LOGOFF_EVENT:
        if Assigned(Console.OnLogOff) then
          Console.OnLogOff(Console);
      CTRL_SHUTDOWN_EVENT:
        if Assigned(Console.OnShutdown) then
          Console.OnShutdown(Console);
    else
      // (rom) disabled. Makes function result unpredictable.
      //Assert(False, 'Unknown Ctrl Event');
      Result := False;
    end;
  except
    // (rom) dubious. An exception implies that an event has been handled.
    Result := False;
  end;
end;

//=== { TJclConsole } ========================================================

constructor TJclConsole.Create;
begin
  inherited Create;
  FScreens := TObjectList.Create;
  FInput:= TJclInputBuffer.Create(Self);
  FActiveScreenIndex := FScreens.Add(TJclScreenBuffer.Create);
  FOnCtrlC := nil;
  FOnCtrlBreak := nil;
  FOnClose := nil;
  FOnLogOff := nil;
  FOnShutdown := nil;
  SetConsoleCtrlHandler(@CtrlHandler, True);
end;

destructor TJclConsole.Destroy;
begin
  // (rom) why as first line?
  inherited Destroy;
  SetConsoleCtrlHandler(@CtrlHandler, False);
  FreeAndNil(FInput);
  FreeAndNil(FScreens);
end;

class procedure TJclConsole.Alloc;
begin
  Win32Check(AllocConsole);
end;

class procedure TJclConsole.Free;
begin
  Win32Check(FreeConsole);
end;

function TJclConsole.GetScreen(const Idx: Longword): TJclScreenBuffer;
begin
  // (rom) maybe some checks on Idx here?
  Result := TJclScreenBuffer(FScreens[Idx]);
end;

function TJclConsole.GetScreenCount: Longword;
begin
  Result := FScreens.Count;
end;

function TJclConsole.GetActiveScreen: TJclScreenBuffer;
begin
  Result := Screens[FActiveScreenIndex];
end;

procedure TJclConsole.SetActiveScreen(const Value: TJclScreenBuffer);
begin
  SetActiveScreenIndex(FScreens.IndexOf(Value));
end;

procedure TJclConsole.SetActiveScreenIndex(const Value: Longword);
begin
  if ActiveScreenIndex <> Value then
  begin
    Win32Check(SetConsoleActiveScreenBuffer(Screens[Value].Handle));
    FActiveScreenIndex := Value;
  end;
end;

class function TJclConsole.Default: TJclConsole;
begin
  if not Assigned(g_DefaultConsole) then
    g_DefaultConsole := TJclConsole.Create;
  Result := g_DefaultConsole;
end;

class procedure TJclConsole.Shutdown;
begin
  FreeAndNil(g_DefaultConsole);
end;

function TJclConsole.Add(AWidth, AHeight: Smallint): TJclScreenBuffer;
begin
  if AWidth = 0 then
    AWidth := ActiveScreen.Size.X;
  if AHeight = 0 then
    AHeight := ActiveScreen.Size.Y;
  Result := TJclScreenBuffer(FScreens[FScreens.Add(TJclScreenBuffer.Create(AWidth, AHeight))]);
end;

function TJclConsole.Remove(const ScrBuf: TJclScreenBuffer): Longword;
begin
  Result := FScreens.IndexOf(ScrBuf);
  Delete(Result);
end;

procedure TJclConsole.Delete(const Idx: Longword);
begin
  FScreens.Delete(Idx);
end;

function TJclConsole.GetTitle: string;
var
  Len: Integer;
begin
  { TODO : max 64kByte instead of max 255 }
  SetLength(Result, High(Byte));
  Len := GetConsoleTitle(PChar(Result), Length(Result));
  Win32Check((0 < Len) and (Len < Length(Result)));
  SetLength(Result, Len);
end;

procedure TJclConsole.SetTitle(const Value: string);
begin
  Win32Check(SetConsoleTitle(PChar(Value)));
end;

function TJclConsole.GetInputCodePage: DWORD;
begin
  Result := GetConsoleCP;
end;

procedure TJclConsole.SetInputCodePage(const Value: DWORD);
begin
  { TODO -cTest : SetConsoleCP under Win9x }
  Win32Check(SetConsoleCP(Value));
end;

function TJclConsole.GetOutputCodePage: DWORD;
begin
  Result := GetConsoleOutputCP;
end;

procedure TJclConsole.SetOutputCodePage(const Value: DWORD);
begin
  { TODO -cTest : SetConsoleOutputCP under Win9x }
  Win32Check(SetConsoleOutputCP(Value));
end;

class function TJclConsole.IsConsole(const Module: HMODULE): Boolean;
begin
  Result := False;
  { TODO : Documentation of this solution }
  with PImageDosHeader(Module)^ do
  if e_magic = IMAGE_DOS_SIGNATURE then
    with PImageNtHeaders(Integer(Module) + {$IFDEF FPC} e_lfanew {$ELSE} _lfanew {$ENDIF})^ do
      if Signature = IMAGE_NT_SIGNATURE then
        Result := OptionalHeader.Subsystem = IMAGE_SUBSYSTEM_WINDOWS_CUI;
end;

class function TJclConsole.IsConsole(const FileName: TFileName): Boolean;
begin
  with TJclFileMappingStream.Create(FileName) do
  try
    Result := IsConsole(HMODULE(Memory));
  finally
    Free;
  end;
end;

class function TJclConsole.MouseButtonCount: DWORD;
begin
  Win32Check(GetNumberOfConsoleMouseButtons(Result));
end;

//=== { TJclScreenBuffer } ===================================================

constructor TJclScreenBuffer.Create;
begin
  inherited Create;
  FHandle := CreateFile('CONOUT$', GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  Win32Check(FHandle <> INVALID_HANDLE_VALUE);
  Init;
end;

constructor TJclScreenBuffer.Create(const AHandle: THandle);
begin
  inherited Create;
  FHandle := AHandle;
  Assert(FHandle <> INVALID_HANDLE_VALUE);
  Init;
end;

constructor TJclScreenBuffer.Create(const AWidth, AHeight: Smallint);
begin
  inherited Create;
  FHandle := CreateConsoleScreenBuffer(GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CONSOLE_TEXTMODE_BUFFER, nil);
  Win32Check(FHandle <> INVALID_HANDLE_VALUE);
  Init;
  DoResize(AWidth, AHeight);
end;

destructor TJclScreenBuffer.Destroy;
begin
  // (rom) why as first line?
  inherited Destroy;
  FreeAndNil(FFont);
  FreeAndNil(FCursor);
  FreeAndNil(FWindow);
  FreeAndNil(FCharList);
  CloseHandle(FHandle);
end;

procedure TJclScreenBuffer.Init;
begin
  FCharList := TObjectList.Create;
  FOnAfterResize := nil;
  FOnBeforeResize := nil;
  FFont := TJclScreenFont.Create(Self);
  FCursor := TJclScreenCursor.Create(Self);
  FWindow := TJclScreenWindow.Create(Self);
end;

function TJclScreenBuffer.GetInfo: TConsoleScreenBufferInfo;
begin
  Win32Check(GetConsoleScreenBufferInfo(FHandle, Result));
end;

function TJclScreenBuffer.GetSize: TCoord;
begin
  Result := Info.dwSize;
end;

procedure TJclScreenBuffer.SetSize(const Value: TCoord);
begin
  DoResize(Value);
end;

function TJclScreenBuffer.GetWidth: Smallint;
begin
  Result := Size.X;
end;

procedure TJclScreenBuffer.SetWidth(const Value: Smallint);
begin
  DoResize(Value, Size.Y);
end;

function TJclScreenBuffer.GetHeight: Smallint;
begin
  Result := Size.Y;
end;

procedure TJclScreenBuffer.SetHeight(const Value: Smallint);
begin
  DoResize(Size.X, Value);
end;

procedure TJclScreenBuffer.DoResize(const NewSize: TCoord);
var
  CanResize: Boolean;
begin
  if (Size.X <> NewSize.X) or (Size.Y <> NewSize.Y) then
  begin
    if Assigned(FOnBeforeResize) then
    begin
      CanResize := True;
      FOnBeforeResize(Self, NewSize, CanResize);
      if not CanResize then
        Exit;
    end;
    Win32Check(SetConsoleScreenBufferSize(FHandle, NewSize));
    if Assigned(FOnAfterResize) then
      FOnAfterResize(Self);