jclconsole.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclConsole.pas.                                                             }
{                                                                                                  }
{ The Initial Developer of the Original Code is Flier Lu. Portions created by Flier Lu are         }
{ Copyright (C) Flier Lu. All Rights Reserved.                                                     }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Flier Lu (flier)                                                                               }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ This unit contains classes and routines to support windows Character-Mode Applications           }
{                                                                                                  }
{ Unit owner: Flier Lu                                                                             }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:22 $
// For history see end of file

unit JclConsole;

{$I jcl.inc}
{$I windowsonly.inc}

{$HPPEMIT 'namespace JclConsole'}
(*$HPPEMIT '{'*)
{$HPPEMIT '__interface IJclScreenTextAttribute;'}
(*$HPPEMIT '}'*)
{$HPPEMIT 'using namespace JclConsole;'}
{$HPPEMIT ''}

interface

uses
  Windows,
  Classes, SysUtils, Contnrs,
  JclBase;

// Console
type
  TJclScreenBuffer = class;
  TJclInputBuffer = class;

  TJclConsole = class(TObject)
  private
    FScreens: TObjectList;
    FActiveScreenIndex: Longword;
    FInput: TJclInputBuffer;
    FOnCtrlC: TNotifyEvent;
    FOnCtrlBreak: TNotifyEvent;
    FOnClose: TNotifyEvent;
    FOnLogOff: TNotifyEvent;
    FOnShutdown: TNotifyEvent;
    function GetScreen(const Idx: Longword): TJclScreenBuffer;
    function GetScreenCount: Longword;
    function GetActiveScreen: TJclScreenBuffer;
    procedure SetActiveScreen(const Value: TJclScreenBuffer);
    procedure SetActiveScreenIndex(const Value: Longword);
    function GetTitle: string;
    procedure SetTitle(const Value: string);
    function GetInputCodePage: DWORD;
    function GetOutputCodePage: DWORD;
    procedure SetInputCodePage(const Value: DWORD);
    procedure SetOutputCodePage(const Value: DWORD);
  protected
    constructor Create;
  public
    destructor Destroy; override;
    class function Default: TJclConsole;
    class procedure Shutdown;
    { TODO : Add 'Attach' and other functions for WinXP/Win.Net }
    class function IsConsole(const Module: HMODULE): Boolean; overload;
    class function IsConsole(const FileName: TFileName): Boolean; overload;
    class function MouseButtonCount: DWORD;
    class procedure Alloc;
    class procedure Free;
    function Add(AWidth: Smallint = 0; AHeight: Smallint = 0): TJclScreenBuffer;
    function Remove(const ScrBuf: TJclScreenBuffer): Longword;
    procedure Delete(const Idx: Longword);
    property Title: string read GetTitle write SetTitle;
    property InputCodePage: DWORD read GetInputCodePage write SetInputCodePage;
    property OutputCodePage: DWORD read GetOutputCodePage write SetOutputCodePage;
    property Input: TJclInputBuffer read FInput;
    property Screens[const Idx: Longword]: TJclScreenBuffer read GetScreen;
    property ScreenCount: Longword read GetScreenCount;
    property ActiveScreenIndex: Longword read FActiveScreenIndex write SetActiveScreenIndex;
    property ActiveScreen: TJclScreenBuffer read GetActiveScreen write SetActiveScreen;
    property OnCtrlC: TNotifyEvent read FOnCtrlC write FOnCtrlC;
    property OnCtrlBreak: TNotifyEvent read FOnCtrlBreak write FOnCtrlBreak;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnLogOff: TNotifyEvent read FOnLogOff write FOnLogOff;
    property OnShutdown: TNotifyEvent read FOnShutdown write FOnShutdown;
  end;

  TJclConsoleInputMode = (imLine, imEcho, imProcessed, imWindow, imMouse);
  TJclConsoleInputModes = set of TJclConsoleInputMode;
  TJclConsoleOutputMode = (omProcessed, omWrapAtEol);
  TJclConsoleOutputModes = set of TJclConsoleOutputMode;

  IJclScreenTextAttribute = interface;
  TJclScreenFont = class;
  TJclScreenCharacter = class;
  TJclScreenCursor = class;
  TJclScreenWindow = class;

  // Console screen buffer
  TJclScreenBufferBeforeResizeEvent = procedure(Sender: TObject; const NewSize: TCoord; var CanResize: Boolean) of object;
  TJclScreenBufferAfterResizeEvent = procedure(Sender: TObject) of object;

  TJclScreenBufferTextHorizontalAlign = (thaCurrent, thaLeft, thaCenter, thaRight);
  TJclScreenBufferTextVerticalAlign = (tvaCurrent, tvaTop, tvaCenter, tvaBottom);

  TJclScreenBuffer = class(TObject)
  private
    FHandle: THandle;
    FFont: TJclScreenFont;
    FCursor: TJclScreenCursor;
    FWindow: TJclScreenWindow;
    FCharList: TObjectList;
    FOnAfterResize: TJclScreenBufferAfterResizeEvent;
    FOnBeforeResize: TJclScreenBufferBeforeResizeEvent;
    function GetInfo: TConsoleScreenBufferInfo;
    function GetSize: TCoord;
    procedure SetSize(const Value: TCoord);
    function GetHeight: Smallint;
    function GetWidth: Smallint;
    procedure SetHeight(const Value: Smallint);
    procedure SetWidth(const Value: Smallint);
    function GetMode: TJclConsoleOutputModes;
    procedure SetMode(const Value: TJclConsoleOutputModes);
  protected
    constructor Create; overload;
    constructor Create(const AHandle: THandle); overload;
    constructor Create(const AWidth, AHeight: Smallint); overload;
    procedure Init;
    procedure DoResize(const NewSize: TCoord); overload;
    procedure DoResize(const NewWidth, NewHeight: Smallint); overload;
    property Info: TConsoleScreenBufferInfo read GetInfo;
  public
    destructor Destroy; override;
    function Write(const Text: string;
      const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;
    function Writeln(const Text: string = '';
      const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;
    function Write(const Text: string; const X: Smallint; const Y: Smallint;
      const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;
    function Write(const Text: string; const X: Smallint; const Y: Smallint;
      pAttrs: PWORD): DWORD; overload;
    function Write(const Text: string;
      const HorizontalAlign: TJclScreenBufferTextHorizontalAlign;
      const VerticalAlign: TJclScreenBufferTextVerticalAlign = tvaCurrent;
      const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;
    function Read(const Count: Integer): string; overload;
    function Read(X: Smallint; Y: Smallint; const Count: Integer): string; overload;
    function Readln: string; overload;
    function Readln(X: Smallint; Y: Smallint): string; overload;
    procedure Fill(const ch: Char; const ATextAttribute: IJclScreenTextAttribute = nil);
    procedure Clear;
    property Handle: THandle read FHandle;
    property Font: TJclScreenFont read FFont;
    property Cursor: TJclScreenCursor read FCursor;
    property Window: TJclScreenWindow read FWindow;
    property Size: TCoord read GetSize write SetSize;
    property Width: Smallint read GetWidth write SetWidth;
    property Height: Smallint read GetHeight write SetHeight;
    property Mode: TJclConsoleOutputModes read GetMode write SetMode;
    property OnBeforeResize: TJclScreenBufferBeforeResizeEvent read FOnBeforeResize write FOnBeforeResize;
    property OnAfterResize: TJclScreenBufferAfterResizeEvent read FOnAfterResize write FOnAfterResize;
  end;

  // Console screen text attributes
  TJclScreenFontColor = (fclBlack, fclBlue, fclGreen, fclRed, fclCyan, fclMagenta, fclYellow, fclWhite);
  TJclScreenBackColor = (bclBlack, bclBlue, bclGreen, bclRed, bclCyan, bclMagenta, bclYellow, bclWhite);
  TJclScreenFontStyle = (fsLeadingByte, fsTrailingByte, fsGridHorizontal, fsGridLeftVertical, fsGridRightVertical, fsReverseVideo, fsUnderscore, fsSbcsDbcs);
  TJclScreenFontStyles = set of TJclScreenFontStyle;

  IJclScreenTextAttribute = interface
    ['{B880B1AC-9F1A-4F42-9D44-EA482B4F3510}']
    function GetTextAttribute: Word;
    procedure SetTextAttribute(const Value: Word);

    property TextAttribute: Word read GetTextAttribute write SetTextAttribute;

    function GetColor: TJclScreenFontColor;
    procedure SetColor(const Value: TJclScreenFontColor);
    function GetBgColor: TJclScreenBackColor;
    procedure SetBgColor(const Value: TJclScreenBackColor);
    function GetHighlight: Boolean;
    procedure SetHighlight(const Value: Boolean);
    function GetBgHighlight: Boolean;
    procedure SetBgHighlight(const Value: Boolean);
    function GetStyle: TJclScreenFontStyles;
    procedure SetStyle(const Value: TJclScreenFontStyles);

    property Color: TJclScreenFontColor read GetColor write SetColor;
    property BgColor: TJclScreenBackColor read GetBgColor write SetBgColor;
    property Highlight: Boolean read GetHighlight write SetHighlight;
    property BgHighlight: Boolean read GetBgHighlight write SetBgHighlight;
    property Style: TJclScreenFontStyles read GetStyle write SetStyle;
  end;

  TJclScreenCustomTextAttribute = class(TInterfacedObject, IJclScreenTextAttribute)
  private
    function GetBgColor: TJclScreenBackColor;
    function GetBgHighlight: Boolean;
    function GetColor: TJclScreenFontColor;
    function GetHighlight: Boolean;
    function GetStyle: TJclScreenFontStyles;
    procedure SetBgColor(const Value: TJclScreenBackColor);
    procedure SetBgHighlight(const Value: Boolean);
    procedure SetColor(const Value: TJclScreenFontColor);
    procedure SetHighlight(const Value: Boolean);
    procedure SetStyle(const Value: TJclScreenFontStyles);
  protected
    function GetTextAttribute: Word; virtual; abstract;
    procedure SetTextAttribute(const Value: Word); virtual; abstract;
  public
    constructor Create(const Attr: TJclScreenCustomTextAttribute = nil); overload;
    procedure Clear;
    property TextAttribute: Word read GetTextAttribute write SetTextAttribute;
    property Color: TJclScreenFontColor read GetColor write SetColor;
    property BgColor: TJclScreenBackColor read GetBgColor write SetBgColor;
    property Highlight: Boolean read GetHighlight write SetHighlight;
    property BgHighlight: Boolean read GetBgHighlight write SetBgHighlight;
    property Style: TJclScreenFontStyles read GetStyle write SetStyle;
  end;

  TJclScreenFont = class(TJclScreenCustomTextAttribute)
  private
    FScreenBuffer: TJclScreenBuffer;
  protected
    constructor Create(const AScrBuf: TJclScreenBuffer);
    function GetTextAttribute: Word; override;
    procedure SetTextAttribute(const Value: Word); override;
  public
    property ScreenBuffer: TJclScreenBuffer read FScreenBuffer;
  end;

  TJclScreenTextAttribute = class(TJclScreenCustomTextAttribute)
  private
    FAttribute: Word;
  protected
    function GetTextAttribute: Word; override;
    procedure SetTextAttribute(const Value: Word); override;
  public
    constructor Create(const Attribute: Word); overload;
    constructor Create(const AColor: TJclScreenFontColor = fclWhite;
      const ABgColor: TJclScreenBackColor = bclBlack;
      const AHighLight: Boolean = False;
      const ABgHighLight: Boolean = False;
      const AStyle: TJclScreenFontStyles = []); overload;
  end;

  TJclScreenCharacter = class(TJclScreenCustomTextAttribute)
  private
    FCharInfo: TCharInfo;
    function GetCharacter: Char;
    procedure SetCharacter(const Value: Char);
  protected
    constructor Create(const CharInfo: TCharInfo);
    function GetTextAttribute: Word; override;
    procedure SetTextAttribute(const Value: Word); override;
  public
    property Info: TCharInfo read FCharInfo write FCharInfo;
    property Character: Char read GetCharacter write SetCharacter;
  end;

  TJclScreenCursorSize = 1..100;

  TJclScreenCursor = class(TObject)
  private
    FScreenBuffer: TJclScreenBuffer;
    function GetInfo: TConsoleCursorInfo;
    procedure SetInfo(const Value: TConsoleCursorInfo);
    function GetPosition: TCoord;
    procedure SetPosition(const Value: TCoord);
    function GetSize: TJclScreenCursorSize;
    procedure SetSize(const Value: TJclScreenCursorSize);
    function GetVisible: Boolean;
    procedure SetVisible(const Value: Boolean);
  protected
    constructor Create(const AScrBuf: TJclScreenBuffer);
    property Info: TConsoleCursorInfo read GetInfo write SetInfo;
  public
    property ScreenBuffer: TJclScreenBuffer read FScreenBuffer;
    procedure MoveTo(const DestPos: TCoord); overload;
    procedure MoveTo(const x, y: Smallint); overload;
    procedure MoveBy(const Delta: TCoord); overload;
    procedure MoveBy(const cx, cy: Smallint); overload;
    property Position: TCoord read GetPosition write SetPosition;
    property Size: TJclScreenCursorSize read GetSize write SetSize;
    property Visible: Boolean read GetVisible write SetVisible;
  end;

  // Console screen window
  TJclScreenWindow = class(TObject)
  private
    FScreenBuffer: TJclScreenBuffer;
    function GetMaxConsoleWindowSize: TCoord;
    function GetMaxWindow: TCoord;
    function GetLeft: Smallint;
    function GetTop: Smallint;
    function GetWidth: Smallint;
    function GetHeight: Smallint;
    function GetPosition: TCoord;
    function GetSize: TCoord;
    function GetBottom: Smallint;
    function GetRight: Smallint;
    procedure SetLeft(const Value: Smallint);
    procedure SetTop(const Value: Smallint);
    procedure SetWidth(const Value: Smallint);
    procedure SetHeight(const Value: Smallint);
    procedure SetPosition(const Value: TCoord);
    procedure SetSize(const Value: TCoord);
    procedure SetBottom(const Value: Smallint);
    procedure SetRight(const Value: Smallint);
    procedure InternalSetPosition(const X, Y: SmallInt);
    procedure InternalSetSize(const X, Y: SmallInt);
  protected
    constructor Create(const AScrBuf: TJclScreenBuffer);
    procedure DoResize(const NewRect: TSmallRect; bAbsolute: Boolean = True);
  public
    procedure Scroll(const cx, cy: Smallint);
    property ScreenBuffer: TJclScreenBuffer read FScreenBuffer;
    property MaxConsoleWindowSize: TCoord read GetMaxConsoleWindowSize;
    property MaxWindow: TCoord read GetMaxWindow;
    property Position: TCoord read GetPosition write SetPosition;
    property Size: TCoord read GetSize write SetSize;
    property Left: Smallint read GetLeft write SetLeft;
    property Right: Smallint read GetRight write SetRight;
    property Top: Smallint read GetTop write SetTop;
    property Bottom: Smallint read GetBottom write SetBottom;
    property Width: Smallint read GetWidth write SetWidth;
    property Height: Smallint read GetHeight write SetHeight;
  end;

  // Console input buffer
  TJclInputCtrlEvent = ( ceCtrlC, ceCtrlBreak, ceCtrlClose, ceCtrlLogOff, ceCtrlShutdown );

  TJclInputRecordArray = array of TInputRecord;

  TJclInputBuffer = class(TObject)
  private
    FConsole: TJclConsole;
    FHandle: THandle;
    function GetMode: TJclConsoleInputModes;
    procedure SetMode(const Value: TJclConsoleInputModes);
    function GetEventCount: DWORD;
  protected
    constructor Create(const AConsole: TJclConsole);
  public
    destructor Destroy; override;
    procedure Clear;
    procedure RaiseCtrlEvent(const AEvent: TJclInputCtrlEvent; const ProcessGroupId: DWORD = 0);
    function WaitEvent(const TimeOut: DWORD = INFINITE): Boolean;
    function GetEvents(var Events: TJclInputRecordArray): DWORD; overload;
    function GetEvents(const Count: Integer): TJclInputRecordArray; overload;
    function PeekEvents(var Events: TJclInputRecordArray): DWORD; overload;
    function PeekEvents(const Count: Integer): TJclInputRecordArray; overload;