home *** CD-ROM | disk | FTP | other *** search
/ Delphi Developer's Kit 1996 / Delphi Developer's Kit 1996.iso / power / consl / console.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-12-22  |  49.0 KB  |  1,813 lines
  1. unit Console;
  2. {$A+,B-,F-,Q-,R-,S-,W-,X+}
  3.  
  4. {  Text Console component
  5.  
  6.    Copyright (c) 1995 by Danny Thorpe
  7.  
  8. }
  9.  
  10. interface
  11.  
  12. uses WinTypes, WinProcs, Messages, Classes, Controls,
  13.      Forms, Graphics, SysUtils;
  14.  
  15.  
  16. { TConsole
  17.  
  18.   TConsole implements a WinCRT-like control for routing text file I/O
  19.   (readlns and writelns) to a scrollable window.  A text cursor can be
  20.   positioned using X,Y text coordinates.  TConsole is not intended to be a
  21.   text editor, merely a TTY text output device.  TConsole does not store
  22.   its text buffers when it is streamed.  Max display text is 64k
  23.   (rows * columns <= 64k). You can set the TConsole font name, style or
  24.   other properties, but only fixed-pitch fonts will be accepted (all
  25.   others raise an exception).
  26.  
  27.   TConsole can be extended to support text color attributes and multiple
  28.   fonts, and can support multiple terminal emulation command decoders (like
  29.   ANSI-BBS or DEC VT-100).
  30.  
  31.   TConsole supports keyboard input via the Pascal standard input functions
  32.   ReadKey, Keypressed, and Readln.  Note that the modal nature of Readln
  33.   (execution doesn't return until EOL is received) is problematic in
  34.   single-threaded 16 bit Windows.  Only one outstanding Console Readln
  35.   operation is supported for the entire application. Calling readln while
  36.   another readln is pending (eg Readln on a button click) will raise an
  37.   exception.  This readln limitation should be resolvable in multi-treaded
  38.   32 bit Windows.  For now, use Readln with Console controls very carefully.
  39.  
  40.   TConsole provides a performance option called toLazyWrite.  With this option
  41.   turned off, each write operation to the Console is immediately displayed
  42.   on the screen.  With toLazyWrite turned on, screen updating is delayed
  43.   slightly so that multiple text changes can be displayed in one Paint operation.
  44.   Despite the 'lazy' name, this consolidation results in dramatically better
  45.   display performance - a factor of 10 to 100 times faster than writing each
  46.   little piece of text immediately. toLazyWrite is enabled by default.
  47.  
  48.   The public ScrollTo and TrackCursor methods don't use toLazyWrite, nor do
  49.   the ReadKey or ReadBuf routines.  When these routines modify the display or
  50.   text buffer, the Console is updated immediately.
  51.  
  52. TColorConsole
  53.  
  54.   TColorConsole implements support for multiple text color attributes.  The
  55.   Console's font properties determine the text color color, background color,
  56.   font, style, etc of the display text.  Text foreground color is
  57.   Console.Font.Color; text background is Console.Font.BkColor.  Set the
  58.   Console's font properties, then writeln to the Console's text file
  59.   and that text will be displayed with those attributes.
  60.  
  61.   Max display text for TColorConsole is 32k. (rows * cols <= 32k)  Maximum
  62.   unique text attribute sets: 16k. (unique = font+color+bkcolor) Text attribute
  63.   sets are maintained in a pool.  Each attr set is released when the last char
  64.   in the display buffer using that set is overwritten with different
  65.   attributes.
  66.  
  67.   Multiple fonts are supported, but the cell height and width of
  68.   the fonts must be the same.  That is, you can output text in Courier New
  69.   10pt, Courier New 10pt Bold, and Lucida Sans Monospace 10pt Italic all on the
  70.   same screen.  If the Console's font size is changed, that size change is
  71.   applied to all fonts used by the Console control and the control is
  72.   repainted.
  73.  
  74.   Fonts of the same height often have different widths.  When a wider font is
  75.   selected into the Console control, the character cell dimensions for all the
  76.   text is enlarged to accommodate the wider font.  Characters of narrower
  77.   fonts will be spaced further apart to maintain column alignment.  This rarely
  78.   looks appealing, so take it easy on the fonts.  TrueType fonts (like
  79.   Courier New) tend to work better than bitmap fonts (like Courier).
  80.  
  81.  
  82. TConsole's output routines
  83.  
  84.   Most of the time, you'll use a text file to write data to the Console window.
  85.   For more speciallized work, such as extending these objects or adding
  86.   terminal emulation processor methods, you can use some of TConsole's
  87.   speciallized output routines.
  88.  
  89. WriteChar
  90.   Calls WriteCodedBuf to output one character using the current font/color
  91.   attributes.
  92.  
  93. WriteString
  94.   Calls WriteCodedBuf to output the characters in the string using the
  95.   current font/color attributes.
  96.  
  97. WriteCodedBuf
  98.   Passes control to the ProcessControlCodes method pointer if
  99.   it is assigned.  If the pointer is not assigned, WriteBuf is called instead.
  100.   WriteCodedBuf is called by the internal text file device driver, WriteChar,
  101.   and WriteString.
  102.  
  103.   The ProcessControlCodes routine should parse the buffer to find and execute
  104.   complex display formatting control codes and command sequences embedded
  105.   in the data stream (such as ANSI terminal codes).
  106.  
  107.   ProcessControlCodes is a method pointer so that it can be
  108.   reassigned dynamically at runtime - for example, to switch from
  109.   ANSI emulation to Wyse terminal emulation.  Control code processing
  110.   methods have full responsibility for displaying the actual text -
  111.   they should parse their control codes, set the cursor position or
  112.   font/color attributes as needed, and then call WriteBuf, WriteBlock,
  113.   or WriteFill as necessary to display the actual text (sans codes).
  114.   Be sure to honor the plain-text and line-length requirements of
  115.   WriteBlock if you make calls to that low-level routine.
  116.  
  117. WriteBuf
  118.   This is an internal (protected) mid-level method to process simple text file
  119.   formatting codes.  It scans the data stream for special characters
  120.   (Carriage return, Linefeed, Backspace, Bell), wraps text at the right
  121.   margin, and calls WriteBlock or WriteFill for actual output.
  122.  
  123. WriteFill
  124.   This is an internal (protected) low-level method to replicate a single
  125.   character N times starting from text coordinate X,Y and flowing down the page.
  126.   All the replicated chars are displayed with the currently selected font
  127.   and color attributes.  The copy count can be any length up to (rows * cols).
  128.   TColorConsole overrides this method to add additional color support.
  129.  
  130. WriteBlock
  131.   This is an internal (protected) low-level method to output a string of
  132.   characters.  The string parameter has been stripped of all special
  133.   characters and is guaranteed to contain no more than one line of text
  134.   (length <= Cols).  All the characters in the string are displayed with the
  135.   currently selected font and color attributes.  TColorConsole overrides
  136.   this method to add additional color support.
  137. }
  138.  
  139. const
  140.   CM_TrackCursor = wm_User + 100;
  141.   CM_ScrollBy    = wm_User + 101;
  142.  
  143. type
  144.   EInvalidFont = class(Exception);
  145.  
  146.   TCMScrollBy = record
  147.     Msg: Cardinal;
  148.     dx : Integer;
  149.     dy : Longint;
  150.   end;
  151.  
  152.   TConsole = class;  { forward declaration }
  153.  
  154.   TFixedFont = class(TFont)
  155.   private
  156.     FBkColor: TColor;
  157.     procedure SetBkColor(NewColor: TColor);
  158.   public
  159.     constructor Create;
  160.     procedure Assign(Source: TPersistent); override;
  161.   published
  162.     property BkColor: TColor read FBkColor write SetBkColor default clWindow;
  163.   end;
  164.  
  165.   TConsoleOption = (coAutoTracking, coCheckEOF, coCheckBreak,
  166.              coFulltimeCursor, coLazyWrite, coStdInput, coStdOutput);
  167.   TConsoleOptions = set of TConsoleOption;
  168.  
  169.   { CR/LF translation.
  170.         CRLF = no translation
  171.         CR   = on CR add LF
  172.         LF   = on LF add CR   }
  173.   TConsoleLineBreak = (CRLF, CR, LF);
  174.  
  175.   TProcessControlCodes = procedure (Sender: TConsole;
  176.                     Buffer: PChar; Count: Word) of object;
  177.  
  178.   TConsole = class(TCustomControl)
  179.   private
  180.     FOptions: TConsoleOptions;
  181.     FFocused: Boolean;
  182.     FFont: TFixedFont;
  183.     FCols: Integer;                        { Screen buffer dimensions }
  184.     FRows: Integer;
  185.     FProcessControlCodes: TProcessControlCodes;
  186.     FLineBreak: TConsoleLineBreak;        { CR/LF/CRLF translation }
  187.     procedure InternalClrScr;
  188.     procedure SetOptions(NewOptions: TConsoleOptions);
  189.     procedure SetCols(N: Integer);
  190.     procedure SetRows(N: Integer);
  191.     procedure SetFont(F: TFixedFont);
  192.     procedure DoScroll(Which, Action, Thumb: Integer);
  193.     procedure CMTrackCursor(var M); message CM_TrackCursor;
  194.     procedure CMScrollBy(var M: TCMScrollBy); message CM_ScrollBy;
  195.     procedure WMCreate(var M); message wm_Create;
  196.     procedure WMSize(var M: TWMSize); message wm_Size;
  197.     procedure WMHScroll(var M: TWMHScroll); message wm_HScroll;
  198.     procedure WMVScroll(var M: TWMVScroll); message wm_VScroll;
  199.     procedure WMSetFocus(var M: TWMSetFocus); message wm_SetFocus;
  200.     procedure WMKillFocus(var M: TWMKillFocus); message wm_KillFocus;
  201.     procedure WMGetDlgCode(var M: TWMGetDlgCode); message wm_GetDlgCode;
  202.     procedure WMEraseBkgnd(var M: TWMEraseBkgnd); message wm_EraseBkgnd;
  203.   protected
  204.     FReading: Boolean;                     { Reading from CRT window? }
  205.     FOldFont: TFixedFont;
  206.     FFirstLine: Integer;           { First visible line in circular buffer }
  207.     FKeyCount: Integer;                    { Count of keys in KeyBuffer }
  208.     FBuffer: PChar;                        { Screen buffer pointer }
  209.     FRange: TPoint;                        { Scroll bar ranges }
  210.     FOrigin: TPoint;                       { Client/scroll origin }
  211.     FClientSize: TPoint;                   { Number of visible whole cells }
  212.     FCharSize: TPoint;                     { Character cell size }
  213.     FCharAscent: Integer;                  { Baseline location (for caret) }
  214.     FOverhang: Integer;                    { Extra space needed for chars }
  215.     FKeyBuffer: array[0..63] of Char;      { Keyboard type-ahead buffer }
  216.     Cursor: TPoint;                        { Cursor location }
  217.     procedure CreateParams(var P: TCreateParams); override;
  218.     procedure ResizeBuffer; dynamic;
  219.     procedure SetName(const NewName: TComponentName); override;
  220.     procedure SetMetrics(const Metrics: TTextMetric); virtual;
  221.     procedure RecalibrateFont;
  222.     procedure RecalcSizeAndRange;
  223.     function  ScreenPtr(X, Y: Integer): PChar;
  224.     procedure ShowText(L, R: Integer);
  225.     procedure WriteBlock(X,Y: Integer; Buffer: PChar; Count: Word); virtual;
  226.     procedure WriteBuf(Buffer: PChar; Count: Word);
  227.     procedure WriteFill(X,Y: Integer; Ch: Char; Count: Word); virtual;
  228.     procedure SetScrollbars;
  229.     procedure Paint; override;
  230.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  231.     procedure KeyPress(var Key: Char); override;
  232.     procedure DoCtrlBreak; dynamic;
  233.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  234.          X, Y: Integer); override;
  235.     procedure LazyTrackCursor;
  236.     procedure LazyScrollBy(dx, dy: Integer);
  237.     procedure Loaded; override;
  238.   public
  239.     constructor Create(AnOwner: TComponent); override;
  240.     destructor Destroy; override;
  241.     procedure WriteCodedBuf(Buffer: PChar; Count: Word);
  242.     procedure WriteChar(Ch: Char);
  243.     procedure WriteString(const S: String);
  244.     function  KeyPressed: Boolean;
  245.     function  ReadKey: Char;
  246.     function  ReadBuf(Buffer: PChar; Count: Word): Word;
  247.     procedure ClrScr;
  248.     procedure ClrEol;
  249.     procedure CursorTo(X, Y: Integer);
  250.     procedure ScrollTo(X, Y: Integer);
  251.     procedure TrackCursor;
  252.     procedure AssignCrt(var F: Text); dynamic;
  253.     procedure ShowCursor; virtual;
  254.     procedure HideCursor;
  255.   published
  256.     procedure FontChanged(Sender: TObject);
  257.     property Align;
  258.     property ParentColor;
  259.     property Color;
  260.     property Font: TFixedFont read FFont write SetFont;
  261.     property Options: TConsoleOptions read FOptions write SetOptions
  262.       default [coAutoTracking, coCheckBreak, coLazyWrite];
  263.     property Cols: Integer read FCols write SetCols default 80;
  264.     property Rows: Integer read FRows write SetRows default 25;
  265.     property LineBreak: TConsoleLineBreak read FLineBreak write FLineBreak;
  266.     property ProcessControlCodes: TProcessControlCodes
  267.            read FProcessControlCodes write FProcessControlCodes;
  268.   end;
  269.  
  270.  
  271. type
  272.   PIntArray = ^TIntArray;
  273.   TIntArray = array [0..MaxInt-1] of SmallInt;
  274.  
  275. type
  276.   TAttr = class(TFixedFont)
  277.   protected
  278.     RefCount: Cardinal;
  279.     Overhang: ShortInt;
  280.     Underhang: ShortInt;
  281.   public
  282.     constructor Create(F: TFixedFont);
  283.   end;
  284.  
  285.   TAttrManager = class(TPersistent)
  286.   private
  287.     FList: TList;
  288.     FCache: TAttr;
  289.     FCacheIndex: Integer;
  290.     FFreeList: Integer;
  291.     function GetCount: Integer;
  292.   protected
  293.     function  GetAttr(Index: Integer): TAttr;
  294.     procedure SetAttr(Index: Integer; NewAttr: TAttr);
  295.     function  InFreeList(P: Pointer): Boolean;
  296.     function  FirstFreeIndex: Integer;
  297.     function  NextFreeIndex(P: Pointer): Integer;
  298.     procedure SetFree(Index: Integer);
  299.     function  AllocIndex: Integer;
  300.   public
  301.     constructor Create;
  302.     destructor Destroy; override;
  303.     function  Allocate(F: TFixedFont): Integer;
  304.     procedure Clear;
  305.     procedure Reference(Index: Integer; Delta: Integer);
  306.     property  Attr[Index: Integer]: TAttr read GetAttr write SetAttr; default;
  307.     property  Count: Integer read GetCount;
  308.   end;
  309.  
  310.   TColorConsole = class(TConsole)
  311.   private
  312.     FIndexes: PIntArray;
  313.     FAttrList: TAttrManager;
  314.     FCellWidths: PIntArray;
  315.     procedure FillAttr(X,Y: Integer; Count: Word);
  316.   protected
  317.     function  IndexPtr(X,Y: Integer): PInteger;
  318.     procedure ResizeBuffer; override;
  319.     procedure SetMetrics(const Metrics: TTextMetric); override;
  320.     procedure WriteFill(X,Y: Integer; Ch: Char; Count: Word); override;
  321.     procedure WriteBlock(X,Y: Integer; Buffer: PChar; Count: Word); override;
  322.     procedure Paint; override;
  323.   public
  324.     constructor Create(Owner: TComponent); override;
  325.     destructor Destroy; override;
  326.   end;
  327.  
  328. procedure Register;
  329.  
  330. procedure Exchange(var X,Y: Pointer);
  331. procedure FillWord(var Buf; Count, Value: Word);
  332.  
  333. implementation
  334.  
  335. { Scroll key definition record }
  336.  
  337. type
  338.   TScrollKey = record
  339.     sKey: Byte;
  340.     Ctrl: Boolean;
  341.     SBar: Byte;
  342.     Action: Byte;
  343.   end;
  344.  
  345. const
  346.   ReadActive: Boolean = False;  { Anybody in a Readln? }
  347.  
  348. { Scroll keys table }
  349.  
  350. const
  351.   ScrollKeyCount = 12;
  352.   ScrollKeys: array[1..ScrollKeyCount] of TScrollKey = (
  353.     (sKey: vk_Left;  Ctrl: False; SBar: sb_Horz; Action: sb_LineUp),
  354.     (sKey: vk_Right; Ctrl: False; SBar: sb_Horz; Action: sb_LineDown),
  355.     (sKey: vk_Left;  Ctrl: True;  SBar: sb_Horz; Action: sb_PageUp),
  356.     (sKey: vk_Right; Ctrl: True;  SBar: sb_Horz; Action: sb_PageDown),
  357.     (sKey: vk_Home;  Ctrl: False; SBar: sb_Horz; Action: sb_Top),
  358.     (sKey: vk_End;   Ctrl: False; SBar: sb_Horz; Action: sb_Bottom),
  359.     (sKey: vk_Up;    Ctrl: False; SBar: sb_Vert; Action: sb_LineUp),
  360.     (sKey: vk_Down;  Ctrl: False; SBar: sb_Vert; Action: sb_LineDown),
  361.     (sKey: vk_Prior; Ctrl: False; SBar: sb_Vert; Action: sb_PageUp),
  362.     (sKey: vk_Next;  Ctrl: False; SBar: sb_Vert; Action: sb_PageDown),
  363.     (sKey: vk_Home;  Ctrl: True;  SBar: sb_Vert; Action: sb_Top),
  364.     (sKey: vk_End;   Ctrl: True;  SBar: sb_Vert; Action: sb_Bottom));
  365.  
  366. { Return the smaller of two integer values }
  367.  
  368. function Min(X, Y: Integer): Integer;
  369. begin
  370.   if X < Y then Min := X else Min := Y;
  371. end;
  372.  
  373. { Return the larger of two integer values }
  374.  
  375. function Max(X, Y: Integer): Integer;
  376. begin
  377.   if X > Y then Max := X else Max := Y;
  378. end;
  379.  
  380. procedure Exchange(var X,Y: Pointer);
  381. var
  382.   Temp: Pointer;
  383. begin
  384.   Temp := X;
  385.   X := Y;
  386.   Y := Temp;
  387. end;
  388.  
  389. procedure FillWord(var Buf; Count, Value: Word); assembler;
  390. asm
  391.   LES  DI, BUF
  392.   MOV  CX, COUNT
  393.   MOV  AX, VALUE
  394.   CLD
  395.   REP STOSW
  396. end;
  397.  
  398.  
  399. constructor TFixedFont.Create;
  400. begin
  401.   inherited Create;
  402.   Name := 'Courier New';
  403.   FBkColor := clWindow;
  404. end;
  405.  
  406. procedure TFixedFont.Assign(Source: TPersistent);
  407. var
  408.   Temp: TColor;
  409. begin
  410.   Temp := FBkColor;
  411.   if Source is TFixedFont then
  412.     FBkColor := TFixedFont(Source).BkColor;
  413.   try
  414.     inherited Assign(Source);        { inherited will call Changed }
  415.   except
  416.     FBkColor := Temp;   { Restore original if inherited fails }
  417.     raise;
  418.   end;
  419. end;
  420.  
  421. procedure TFixedFont.SetBkColor(NewColor: TColor);
  422. begin
  423.   FBkColor := NewColor;
  424.   Changed;
  425. end;
  426.  
  427.  
  428. constructor TConsole.Create(AnOwner: TComponent);
  429. begin
  430.   inherited Create(AnOwner);
  431.   Width := 160;
  432.   Height := 88;
  433.   Options := [coAutoTracking, coCheckBreak, coLazyWrite];
  434.   ControlStyle := ControlStyle + [csOpaque];
  435.   FRows := 25;
  436.   FCols := 80;
  437.   ParentColor := False;
  438.   Color := clWindow;
  439.   FOldFont := TFixedFont.Create;
  440.   FOldFont.Handle := GetStockObject(Ansi_Fixed_Font);
  441.   FFont := TFixedFont.Create;
  442.   FFont.Name := 'Courier';
  443.   FFont.OnChange := FontChanged;
  444.   ResizeBuffer;
  445.   TabStop := True;
  446.   Enabled := True;
  447. end;
  448.  
  449. destructor TConsole.Destroy;
  450. begin
  451.   Options := Options - [coStdInput, coStdOutput];  { close files }
  452.   StrDispose(FBuffer);
  453.   FOldFont.Free;
  454.   FFont.Free;
  455.   inherited Destroy;
  456. end;
  457.  
  458. procedure TConsole.Loaded;
  459. begin
  460.   inherited Loaded;
  461.   ClrScr;
  462. end;
  463.  
  464. procedure TConsole.CreateParams(var P: TCreateParams);
  465. begin
  466.   inherited CreateParams(P);
  467.   P.WindowClass.Style := P.WindowClass.Style and not (cs_HRedraw or cs_VRedraw);
  468. end;
  469.  
  470. procedure TConsole.WMCreate(var M);
  471. begin
  472.   inherited;
  473.   RecalibrateFont;    { don't ClrScr, because text may already be in buffer }
  474. end;
  475.  
  476. procedure TConsole.ResizeBuffer;
  477. var Temp: PChar;
  478. begin
  479.   Temp := StrAlloc(Cols * Rows);
  480.   StrDispose(FBuffer);
  481.   FBuffer := Temp;
  482.   FillChar(FBuffer^,Cols * Rows,' ');
  483. end;
  484.  
  485. procedure TConsole.SetCols(N: Integer);
  486. begin
  487.   if FCols <> N then
  488.   begin
  489.     FCols := N;
  490.     ResizeBuffer;
  491.   end;
  492. end;
  493.  
  494. procedure TConsole.SetRows(N: Integer);
  495. begin
  496.   if FRows <> N then
  497.   begin
  498.     FRows := N;
  499.     ResizeBuffer;
  500.   end;
  501. end;
  502.  
  503. procedure TConsole.SetFont(F: TFixedFont);
  504. begin
  505.   FFont.Assign(F);
  506. end;
  507.  
  508. procedure TConsole.FontChanged(Sender: TObject);
  509. var
  510.   DC: HDC;
  511.   Save: THandle;
  512.   Metrics: TTextMetric;
  513.   Temp: String;
  514. begin
  515.   if Font.Handle <> FOldFont.Handle then
  516.   begin
  517.     DC := GetDC(0);
  518.     Save := SelectObject(DC, Font.Handle);
  519.     GetTextMetrics(DC, Metrics);
  520.     SelectObject(DC, Save);
  521.     ReleaseDC(0, DC);
  522.     if not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and
  523.             ((Metrics.tmPitchAndFamily and $01) = 0)) then
  524.     begin
  525.       Temp := 'TConsole: ' + Font.Name + ' is not fixed-pitch';
  526.       Font.Name := FOldFont.Name;  { Keep other attributes of font }
  527.       raise EInvalidFont.Create(Temp);
  528.     end;
  529.     SetMetrics(Metrics);
  530.   end;
  531.   FOldFont.Assign(Font);
  532.   if csDesigning in ComponentState then
  533.     InternalClrScr;
  534. end;
  535.  
  536. { If the character cell is different, accept changes and redraw }
  537. procedure TConsole.SetMetrics(const Metrics: TTextMetric);
  538. begin
  539.   with Metrics do
  540.   begin
  541.     FCharSize.X := tmAveCharWidth;
  542.     FCharSize.Y := tmHeight + tmExternalLeading;
  543.     FCharAscent := tmAscent;
  544.     FOverhang   := Max(tmOverhang, tmMaxCharWidth - tmAveCharWidth);
  545.     Invalidate;
  546.     RecalcSizeAndRange;
  547.   end;
  548. end;
  549.  
  550. procedure TConsole.RecalcSizeAndRange;
  551. begin
  552.   if HandleAllocated then
  553.   begin
  554.     FClientSize.X := ClientWidth div FCharSize.X;
  555.     FClientSize.Y := ClientHeight div FCharSize.Y;
  556.     FRange.X := Max(0, Cols - FClientSize.X);
  557.     FRange.Y := Max(0, Rows - FClientSize.Y);
  558.     ScrollTo(Min(FOrigin.X, FRange.X), Min(FOrigin.Y, FRange.Y));
  559.     SetScrollBars;
  560.   end;
  561. end;
  562.  
  563. procedure TConsole.SetName(const NewName: TComponentName);
  564. begin
  565.   inherited SetName(NewName);
  566.   if csDesigning in ComponentState then
  567.     ClrScr;
  568. end;
  569.  
  570.  
  571. { Return pointer to text location in screen buffer }
  572. { Always call ScreenPtr to get the next line you want, since the
  573.   circular text buffer may wrap around between lines N and N+1.
  574.   For the same reason, do not do pointer arithmetic between rows. }
  575.  
  576. function TConsole.ScreenPtr(X, Y: Integer): PChar;
  577. begin
  578.   Inc(Y, FFirstLine);
  579.   if Y >= Rows then Dec(Y, Rows);
  580.   Result := @FBuffer[Y * Cols + X];
  581. end;
  582.  
  583. { Update text on cursor line }
  584.  
  585. procedure TConsole.ShowText(L, R: Integer);
  586. var
  587.   B: TRect;
  588. begin
  589.   if HandleAllocated and (L < R) then
  590.   begin
  591.     B.Left := (L - FOrigin.X) * FCharSize.X;
  592.     B.Top  := (Cursor.Y - FOrigin.Y) * FCharSize.Y;
  593.     B.Right:= (R - FOrigin.X) * FCharSize.X + FOverhang;
  594.     B.Bottom := B.Top + FCharSize.Y;
  595.     InvalidateRect(Handle, @B, False);
  596.     if not (coLazyWrite in Options) then
  597.       Update;
  598.   end;
  599. end;
  600.  
  601. { Show caret }
  602.  
  603. procedure TConsole.ShowCursor;
  604. begin
  605.   if not HandleAllocated then Exit;
  606.   CreateCaret(Handle, 0, FCharSize.X, 2);
  607.   SetCaretPos((Cursor.X - FOrigin.X) * FCharSize.X,
  608.     (Cursor.Y - FOrigin.Y) * FCharSize.Y + FCharAscent);
  609.   ShowCaret(Handle);
  610. end;
  611.  
  612. { Hide caret }
  613.  
  614. procedure TConsole.HideCursor;
  615. begin
  616.   DestroyCaret;
  617. end;
  618.  
  619. { Set cursor position }
  620.  
  621. procedure TConsole.CursorTo(X, Y: Integer);
  622. begin
  623.   Cursor.X := Max(0, Min(X, Cols - 1));
  624.   Cursor.Y := Max(0, Min(Y, Rows - 1));
  625.   if FFocused and (FReading or (coFullTimeCursor in Options)) then
  626.     ShowCursor;
  627. end;
  628.  
  629. { Request asynchronous (lazy) ScrollBy, or update pending request }
  630.  
  631. procedure TConsole.LazyScrollBy(dx, dy: Integer);
  632. var
  633.   Msg: TMsg;
  634. begin
  635.   if (coLazyWrite in Options) and HandleAllocated then
  636.   begin
  637.     if PeekMessage(Msg, Handle, cm_ScrollBy,
  638.          cm_ScrollBy, PM_NoYield or PM_Remove) then
  639.     begin
  640.       Inc(dx, Msg.WParam);
  641.       Inc(dy, Msg.LParam);
  642.     end;          { Flush accumulated scroll when delta >= half a screen }
  643.     if (Abs(dx) >= Min(FClientSize.X, Cols) div 2) or
  644.        (Abs(dy) >= Min(FClientSize.Y, Rows) div 2) then
  645.       Perform(CM_ScrollBy, dx, dy)
  646.     else
  647.       if (dx or dy) <> 0 then
  648.         PostMessage(Handle, cm_ScrollBy, dx, dy);
  649.   end
  650.   else
  651.     Perform(CM_ScrollBy, dx, dy);
  652. end;
  653.  
  654. { Respond to asynchronous (lazy) ScrollBy request }
  655.  
  656. procedure TConsole.CMScrollBy(var M: TCMScrollBy);
  657. begin
  658.   ScrollTo(FOrigin.X + M.dx, FOrigin.Y + M.dy);
  659. end;
  660.  
  661.  
  662. { Scroll window to given origin }
  663. { If font has overlapping cells (ie, italic), additional work is done to
  664.   remove the residual overlapped pixels from the leftmost column.
  665.   Using the clip rect with ScrollWindowEx helps eliminate pixel flicker in
  666.   the left column.  }
  667. procedure TConsole.ScrollTo(X, Y: Integer);
  668. var
  669.   R: TRect;
  670.   OldOrigin: TPoint;
  671. begin
  672.   X := Max(0, Min(X, FRange.X));
  673.   Y := Max(0, Min(Y, FRange.Y));
  674.   if (X <> FOrigin.X) or (Y <> FOrigin.Y) then
  675.   begin
  676.     OldOrigin := FOrigin;
  677.     FOrigin.X := X;
  678.     FOrigin.Y := Y;
  679.     if HandleAllocated then
  680.     begin
  681.       R := ClientRect;
  682.       if X > OldOrigin.X then Inc(R.Left, FOverhang);
  683.       if Y > OldOrigin.Y then R.Bottom := FClientSize.Y * FCharSize.Y;
  684.       ScrollWindowEx(Handle,
  685.        (OldOrigin.X - X) * FCharSize.X,
  686.        (OldOrigin.Y - Y) * FCharSize.Y, nil, @R, 0, @R, 0);
  687.       if Y <> OldOrigin.Y then
  688.       begin
  689.         SetScrollPos(Handle, sb_Vert, Y, True);
  690.         if Y > OldOrigin.Y then
  691.         begin
  692.           InvalidateRect(Handle, @R, False);
  693.           Update;
  694.           R.Top := R.Bottom;
  695.           R.Bottom := ClientRect.Bottom;
  696.         end;
  697.       end;
  698.       if X <> OldOrigin.X then
  699.       begin
  700.         SetScrollPos(Handle, sb_Horz, X, True);
  701.         if (FOverhang > 0) then
  702.         begin
  703.           if (X < OldOrigin.X) then { Scroll right - left edge repaint }
  704.           begin
  705.           { Add overhang to invalidation rect to redraw leftmost char pair }
  706.             R.Left := 0;
  707.             R.Right := Max(R.Right, (OldOrigin.X - X) * FCharSize.X + FOverhang);
  708.           end
  709.           else    { Scroll left - right edge repaint }
  710.           begin
  711.             { Redraw leftmost chars to remove prev chars' overhang }
  712.             InvalidateRect(Handle, @R, False);
  713.             Update;   { Update right side, before invalidating left side }
  714.             R.Left := 0;
  715.             R.Top  := 0;
  716.             R.Right := FOverhang;
  717.             R.Bottom := ClientHeight;
  718.           end;
  719.         end;
  720.       end;
  721.       InvalidateRect(Handle, @R, False);
  722.       Update;
  723.     end;
  724.   end;
  725. end;
  726.  
  727. { Request asynchronous (lazy) TrackCursor, if not already pending }
  728.  
  729. procedure TConsole.LazyTrackCursor;
  730. var
  731.   Msg: TMsg;
  732. begin
  733.   if (coLazyWrite in Options) and HandleAllocated then
  734.   begin   { Only post msg if there is not one already in the queue }
  735.     if not PeekMessage(Msg, Handle, cm_TrackCursor,
  736.              cm_TrackCursor, PM_NoYield or PM_NoRemove) then
  737.       PostMessage(Handle, cm_TrackCursor, 0, 0);
  738.   end
  739.   else
  740.     TrackCursor;
  741. end;
  742.  
  743. { Respond to asynchronous (lazy) TrackCursor request }
  744.  
  745. procedure TConsole.CMTrackCursor(var M);
  746. begin
  747.   TrackCursor;
  748. end;
  749.  
  750. { Scroll to make cursor visible (synchronous - immediate update)}
  751.  
  752. procedure TConsole.TrackCursor;
  753. begin
  754.   ScrollTo(Max(Cursor.X - FClientSize.X + 1, Min(FOrigin.X, Cursor.X)),
  755.     Max(Cursor.Y - FClientSize.Y + 1, Min(FOrigin.Y, Cursor.Y)));
  756. end;
  757.  
  758. { Update scroll bars }
  759.  
  760. procedure TConsole.SetScrollBars;
  761. begin
  762.   if not HandleAllocated then Exit;
  763.   SetScrollRange(Handle, sb_Horz, 0, Max(1, FRange.X), False);
  764.   SetScrollPos(Handle, sb_Horz, FOrigin.X, True);
  765.   SetScrollRange(Handle, sb_Vert, 0, Max(1, FRange.Y), False);
  766.   SetScrollPos(Handle, sb_Vert, FOrigin.Y, True);
  767. end;
  768.  
  769. { Clear screen }
  770.  
  771. procedure TConsole.InternalClrScr;
  772. begin
  773.   WriteFill(0,0,' ',Cols * Rows);
  774.   FOrigin.X := 0;
  775.   FOrigin.Y := 0;
  776.   Cursor.X := 0;
  777.   Cursor.Y := 0;
  778.   if (csDesigning in ComponentState) then
  779.     WriteString(Name);
  780.   Invalidate;
  781. end;
  782.  
  783. procedure TConsole.ClrScr;
  784. begin
  785.   InternalClrScr;
  786.   RecalibrateFont;
  787. end;
  788.  
  789. procedure TConsole.RecalibrateFont;
  790. begin
  791.   FCharSize.X := 0;
  792.   FCharSize.Y := 0;
  793.   FCharAscent := 0;
  794.   FOverhang := 0;
  795.   FOldFont.Handle := 0;
  796.   FOldFont.Size := 0;
  797.   FontChanged(FFont);     { This will force a repaint and recalibrate }
  798. end;
  799.  
  800. { Clear to end of line }
  801.  
  802. procedure TConsole.ClrEol;
  803. begin
  804.   WriteFill(Cursor.X, Cursor.Y, ' ', Cols - Cursor.X);
  805.   ShowText(Cursor.X, Cols);
  806. end;
  807.  
  808.  
  809. procedure TConsole.WriteBlock(X,Y: Integer; Buffer: PChar; Count: Word);
  810. begin
  811.   Move(Buffer^, ScreenPtr(X,Y)^, Count);
  812. end;
  813.  
  814.  
  815. { Write text buffer to CRT window
  816.    - Process any special characters in buffer
  817.    - Insert line breaks
  818. }
  819. procedure TConsole.WriteBuf(Buffer: PChar; Count: Word);
  820. var
  821.   L, R: Integer;
  822.  
  823.   procedure Return;
  824.   begin
  825.     L := 0;
  826.     R := 0;
  827.     Cursor.X := 0;
  828.   end;
  829.  
  830.   procedure LineFeed;
  831.   var
  832.     Rect: TRect;
  833.   begin
  834.     Inc(Cursor.Y);
  835.     if Cursor.Y = Rows then
  836.     begin
  837.       Dec(Cursor.Y);
  838.       Inc(FFirstLine);
  839.       if FFirstLine = Rows then FFirstline := 0;
  840.       WriteFill(0, Cursor.Y, ' ', Cols);
  841.       Dec(FOrigin.Y, 1);
  842.       LazyScrollBy(0, 1);
  843.     end;
  844.   end;
  845.  
  846. var
  847.   BlockEnd, BlockLen: Integer;
  848.   P: PChar;
  849.  
  850. begin
  851.   L := Cursor.X;
  852.   R := Cursor.X;
  853.   while Count > 0 do
  854.   begin
  855.     BlockEnd := Min(Cols - Cursor.X, Count);
  856.     P := Buffer;
  857. {   BlockStart := BlockEnd;
  858.     while (BlockEnd > 0) and (Buffer^ in [#32..#255]) do
  859.     begin
  860.       Inc(Buffer);
  861.       Dec(BlockEnd);
  862.     end;
  863.     BlockLen := BlockStart - BlockEnd;
  864. }   asm
  865.       PUSH   DS
  866.       LDS    SI, Buffer
  867.       MOV    CX, BlockEnd
  868.       MOV    DX, CX
  869.       CLD
  870.     @@1:
  871.       LODSB
  872.       CMP    AL,' '
  873.       JB     @@2
  874.       LOOP   @@1
  875.       INC    SI
  876.     @@2:
  877.       DEC    SI
  878.       MOV    Buffer.Word[0],SI
  879.       MOV    BlockEnd, CX
  880.       SUB    DX,CX
  881.       MOV    BlockLen, DX
  882.       POP    DS
  883.     end;
  884.     if BlockLen > 0 then
  885.     begin
  886.       Dec(Count, BlockLen);
  887.       WriteBlock(Cursor.X, Cursor.Y, P, BlockLen);
  888.       Inc(Cursor.X, BlockLen);
  889.       if Cursor.X > R then R := Cursor.X;
  890.  
  891.       if (BlockEnd = 0) and (Count > 0) then
  892.       begin
  893.         ShowText(L,R);
  894.         Return;
  895.         LineFeed;
  896.         Continue;
  897.       end;
  898.     end;
  899.  
  900.     if Count > 0 then
  901.     begin
  902.       case Buffer^ of
  903.     #13: begin
  904.               ShowText(L,R);
  905.               Return;
  906.               if LineBreak = CR then LineFeed;
  907.             end;
  908.        #10: begin
  909.               ShowText(L,R);
  910.               if LineBreak = LF then Return;
  911.               LineFeed;
  912.             end;
  913.      #8: if Cursor.X > 0 then
  914.          begin
  915.            Dec(Cursor.X);
  916.            WriteFill(Cursor.X, Cursor.Y, ' ', 1);
  917.            if Cursor.X < L then L := Cursor.X;
  918.          end;
  919.      #7: MessageBeep(0);
  920.       end;
  921.       Inc(Buffer);
  922.       Dec(Count);
  923.     end;
  924.   end;
  925.   ShowText(L, R);
  926.   if coAutoTracking in Options then
  927.     LazyTrackCursor;
  928.   if FFocused and (coFullTimeCursor in Options) then
  929.     ShowCursor;
  930. end;
  931.  
  932. procedure TConsole.WriteCodedBuf(Buffer: PChar; Count: Word);
  933. begin
  934.   if Assigned(FProcessControlCodes) then
  935.     FProcessControlCodes(Self, Buffer, Count)
  936.   else
  937.     WriteBuf(Buffer, Count);
  938. end;
  939.  
  940. { Write character to CRT window }
  941.  
  942. procedure TConsole.WriteChar(Ch: Char);
  943. begin
  944.   WriteCodedBuf(@Ch, 1);
  945. end;
  946.  
  947. procedure TConsole.WriteString(const S: String);
  948. begin
  949.   WriteCodedBuf(@S[1], Length(S));
  950. end;
  951.  
  952. procedure TConsole.WriteFill(X,Y: Integer; Ch: Char; Count: Word);
  953. var
  954.   I: Integer;
  955. begin
  956.   if Count = 0 then Exit;
  957.   if (X + Count) > Cols then
  958.   begin
  959.     FillChar(ScreenPtr(X,Y)^, Cols - X, Ch);
  960.     Dec(Count, Cols - X);
  961.     I := Cols;
  962.     while Count > 0 do
  963.     begin
  964.       Inc(Y);
  965.       FillChar(ScreenPtr(X,Y)^, I, Ch);
  966.       Dec(Count, I);
  967.     end;
  968.   end
  969.   else
  970.     FillChar(ScreenPtr(X,Y)^, Count, Ch);
  971. end;
  972.  
  973. { Return keyboard status }
  974.  
  975. function TConsole.KeyPressed: Boolean;
  976. begin
  977.   Result := FKeyCount > 0;
  978.   if (not Result) then
  979.   begin
  980.     Application.ProcessMessages;
  981.     Result := FKeyCount > 0;
  982.   end;
  983. end;
  984.  
  985. { Read key from CRT window }
  986.  
  987. function TConsole.ReadKey: Char;
  988. begin
  989.   TrackCursor;
  990.   if not KeyPressed then
  991.   begin
  992.     SetFocus;
  993.     if FReading or ReadActive then
  994.       raise EInvalidOperation.Create('Read already active');
  995.     try
  996.       FReading := True;
  997.       ReadActive := True;
  998.       if FFocused then ShowCursor;
  999.       repeat
  1000.     Application.HandleMessage
  1001.       until Application.Terminated or (FKeyCount > 0);
  1002.       if Application.Terminated then
  1003. {!!        raise ETerminateApp.Create('WM_Quit received during ReadKey');}
  1004.      raise Exception.Create('WM_Quit received during ReadKey');
  1005.     finally
  1006.       if FFocused and not (coFullTimeCursor in Options) then
  1007.         HideCursor;
  1008.       FReading := False;
  1009.       ReadActive := False;
  1010.     end;
  1011.   end;
  1012.   ReadKey := FKeyBuffer[0];
  1013.   Dec(FKeyCount);
  1014.   Move(FKeyBuffer[1], FKeyBuffer[0], FKeyCount);
  1015. end;
  1016.  
  1017. { Read text buffer from CRT window }
  1018.  
  1019. function TConsole.ReadBuf(Buffer: PChar; Count: Word): Word;
  1020. var
  1021.   Ch: Char;
  1022.   I: Word;
  1023. begin
  1024.   I := 0;
  1025.   repeat
  1026.     Ch := ReadKey;
  1027.     case Ch of
  1028.       #8:
  1029.     if I > 0 then
  1030.     begin
  1031.       Dec(I);
  1032.       WriteChar(#8);
  1033.     end;
  1034.       #32..#255:
  1035.     if I < Count - 2 then
  1036.     begin
  1037.       Buffer[I] := Ch;
  1038.       Inc(I);
  1039.       WriteChar(Ch);
  1040.     end;
  1041.     end;
  1042.   until (Ch in [#0,#13]) or ((coCheckEOF in Options) and (Ch = #26));
  1043.   Buffer[I] := Ch;
  1044.   Inc(I);
  1045.   if Ch = #13 then
  1046.   begin
  1047.     Buffer[I] := #10;
  1048.     Inc(I);
  1049.     WriteBuf(#13#10,2);
  1050.   end;
  1051.   TrackCursor;
  1052.   ReadBuf := I;
  1053.   if FFocused and (coFullTimeCursor in Options) then ShowCursor;
  1054. end;
  1055.  
  1056. { TTextRec }
  1057. type
  1058.   TTextRec = record
  1059.     Handle: Word;
  1060.     Mode: Word;
  1061.     BufSize: Word;
  1062.     Reserved: Word;
  1063.     BufPos: Word;
  1064.     BufEnd: Word;
  1065.     BufPtr: PChar;
  1066.     OpenFunc: Pointer;
  1067.     InOutFunc: Pointer;
  1068.     FlushFunc: Pointer;
  1069.     CloseFunc: Pointer;
  1070.     UserData: array[1..16] of Byte;
  1071.     Name: array[0..79] of Char;
  1072.     Buffer: array[0..127] of Char;
  1073.   end;
  1074.  
  1075. const
  1076.   fmClosed = $D7B0;
  1077.   fmInput = $D7B1;
  1078.   fmOutput = $D7B2;
  1079.   fmInOut = $D7B3;
  1080.  
  1081. { Text file device driver output function }
  1082.  
  1083. function CrtOutput(var F: TTextRec): Integer; far;
  1084. begin
  1085.   if F.BufPos <> 0 then
  1086.   with TObject((@F.UserData)^) as TConsole do
  1087.   begin
  1088.     WriteCodedBuf(PChar(F.BufPtr), F.BufPos);
  1089.     F.BufPos := 0;
  1090.   end;
  1091.   CrtOutput := 0;
  1092. end;
  1093.  
  1094. { Text file device driver input function }
  1095.  
  1096. function CrtInput(var F: TTextRec): Integer; far;
  1097. begin
  1098.   with TObject((@F.UserData)^) as TConsole do
  1099.     F.BufEnd := ReadBuf(PChar(F.BufPtr), F.BufSize);
  1100.   F.BufPos := 0;
  1101.   CrtInput := 0;
  1102. end;
  1103.  
  1104. { Text file device driver close function }
  1105.  
  1106. function CrtClose(var F: TTextRec): Integer; far;
  1107. begin
  1108.   CrtClose := 0;
  1109. end;
  1110.  
  1111. { Text file device driver open function }
  1112.  
  1113. function CrtOpen(var F: TTextRec): Integer; far;
  1114. begin
  1115.   if F.Mode = fmInput then
  1116.   begin
  1117.     F.InOutFunc := @CrtInput;
  1118.     F.FlushFunc := nil;
  1119.   end else
  1120.   begin
  1121.     F.Mode := fmOutput;
  1122.     F.InOutFunc := @CrtOutput;
  1123.     F.FlushFunc := @CrtOutput;
  1124.   end;
  1125.   F.CloseFunc := @CrtClose;
  1126.   CrtOpen := 0;
  1127. end;
  1128.  
  1129. { Assign text file to CRT device }
  1130.  
  1131. procedure TConsole.AssignCrt(var F: Text);
  1132. begin
  1133.   with TTextRec(F) do
  1134.   begin
  1135.     Handle := $FFFF;
  1136.     Mode := fmClosed;
  1137.     BufSize := SizeOf(Buffer);
  1138.     BufPtr := @Buffer;
  1139.     OpenFunc := @CrtOpen;
  1140.     Move(Self, UserData[1],4);
  1141.     Name[0] := #0;
  1142.   end;
  1143. end;
  1144.  
  1145. procedure TConsole.SetOptions(NewOptions: TConsoleOptions);
  1146. begin
  1147.   if not (csDesigning in ComponentState) then { don't open files at design time }
  1148.   begin
  1149.     if (coStdInput in (NewOptions - Options)) then
  1150.       with TTextRec(Input) do
  1151.       begin
  1152.         if (Mode <> fmClosed) and (Mode <> 0) then
  1153.           raise Exception.Create('TConsole.SetOptions: Standard Input is already open');
  1154.         AssignCrt(Input);
  1155.         Reset(Input);
  1156.         Include(FOptions, coStdInput);  { in case opening output fails }
  1157.       end
  1158.     else
  1159.       if (coStdInput in (Options - NewOptions)) then
  1160.         System.Close(Input);
  1161.  
  1162.     if (coStdOutput in (NewOptions - Options)) then
  1163.       with TTextRec(Output) do
  1164.       begin
  1165.         if (Mode <> fmClosed) and (Mode <> 0) then
  1166.           raise Exception.Create('TConsole.SetOptions: Standard Output is already open');
  1167.         AssignCrt(Output);
  1168.         Rewrite(Output);
  1169.       end
  1170.     else
  1171.       if (coStdOutput in (Options - NewOptions)) then
  1172.         System.Close(Output);
  1173.   end;
  1174.   FOptions := NewOptions;
  1175. end;
  1176.  
  1177.  
  1178. { wm_Paint message handler }
  1179.  
  1180. procedure TConsole.Paint;
  1181. var
  1182.   X1, X2, Y1, Y2, PX, PY: Integer;
  1183.   R: TRect;
  1184. begin
  1185.   Canvas.Font := Font;
  1186.   Canvas.Brush.Color := Font.BkColor;
  1187.   SetViewportOrg(Canvas.Handle, -FOrigin.X * FCharSize.X, -FOrigin.Y * FCharSize.Y);
  1188.   GetClipBox(Canvas.Handle, R);
  1189.   X1 := Max(FOrigin.X, (R.left - FOverhang) div FCharSize.X);
  1190.   X2 := Min(Cols, (R.right + FCharSize.X) div FCharSize.X);
  1191.   Y1 := Max(0, R.top div FCharSize.Y);
  1192.   Y2 := Min(Rows, (R.bottom + FCharSize.Y - 1) div FCharSize.Y);
  1193.   PX := X1 * FCharSize.X;
  1194.   PY := Y1 * FCharSize.Y;
  1195.   { Draw first line using ETO_Opaque and the entire clipping region. }
  1196.   ExtTextOut(Canvas.Handle, PX, PY, ETO_Opaque, @R, ScreenPtr(X1, Y1), X2 - X1, nil);
  1197.   Inc(Y1);
  1198.   Inc(PY, FCharSize.Y);
  1199.   while Y1 < Y2 do
  1200.   begin
  1201.     { Draw subsequent lines without any background fill or clipping rect }
  1202.     ExtTextOut(Canvas.Handle, PX, PY, 0, nil, ScreenPtr(X1, Y1), X2 - X1, nil);
  1203.     Inc(Y1);
  1204.     Inc(PY, FCharSize.Y);
  1205.   end;
  1206. end;
  1207.  
  1208. procedure TConsole.WMSize(var M: TWMSize);
  1209. var
  1210.   W,H: Integer;
  1211. begin
  1212.   if FFocused and (FReading or (coFullTimeCursor in Options)) then
  1213.     HideCursor;
  1214.   inherited;
  1215.   RecalcSizeAndRange;
  1216.   if FFocused and (FReading or (coFullTimeCursor in Options)) then
  1217.     ShowCursor;
  1218. end;
  1219.  
  1220.  
  1221. procedure TConsole.DoScroll(Which, Action, Thumb: Integer);
  1222. var
  1223.   X, Y: Integer;
  1224.  
  1225. function GetNewPos(Pos, Page, Range: Integer): Integer;
  1226. begin
  1227.   case Action of
  1228.     sb_LineUp: GetNewPos := Pos - 1;
  1229.     sb_LineDown: GetNewPos := Pos + 1;
  1230.     sb_PageUp: GetNewPos := Pos - Page;
  1231.     sb_PageDown: GetNewPos := Pos + Page;
  1232.     sb_Top: GetNewPos := 0;
  1233.     sb_Bottom: GetNewPos := Range;
  1234.     sb_ThumbPosition,
  1235.     sb_ThumbTrack    : GetNewPos := Thumb;
  1236.   else
  1237.     GetNewPos := Pos;
  1238.   end;
  1239. end;
  1240.  
  1241. begin
  1242.   X := FOrigin.X;
  1243.   Y := FOrigin.Y;
  1244.   case Which of
  1245.     sb_Horz: X := GetNewPos(X, FClientSize.X div 2, FRange.X);
  1246.     sb_Vert: Y := GetNewPos(Y, FClientSize.Y, FRange.Y);
  1247.   end;
  1248.   ScrollTo(X, Y);
  1249. end;
  1250.  
  1251. procedure TConsole.WMHScroll(var M: TWMHScroll);
  1252. begin
  1253.   DoScroll(sb_Horz, M.ScrollCode, M.Pos);
  1254. end;
  1255.  
  1256. procedure TConsole.WMVScroll(var M: TWMVScroll);
  1257. begin
  1258.   DoScroll(sb_Vert, M.ScrollCode, M.Pos);
  1259. end;
  1260.  
  1261. procedure TConsole.KeyPress(var Key: Char);
  1262. begin
  1263.   inherited KeyPress(Key);
  1264.   if Key <> #0 then
  1265.   begin
  1266.     if (coCheckBreak in Options) and (Key = #3) then
  1267.       DoCtrlBreak;
  1268.     if FKeyCount < SizeOf(FKeyBuffer) then
  1269.     begin
  1270.       FKeyBuffer[FKeyCount] := Key;
  1271.       Inc(FKeyCount);
  1272.     end;
  1273.   end;
  1274. end;
  1275.  
  1276. procedure TConsole.KeyDown(var Key: Word; Shift: TShiftState);
  1277. var
  1278.   I: Integer;
  1279. begin
  1280.   inherited KeyDown(Key, Shift);
  1281.   if Key = 0 then Exit;
  1282.   if (coCheckBreak in Options) and (Key = vk_Cancel) then
  1283.     DoCtrlBreak;
  1284.   for I := 1 to ScrollKeyCount do
  1285.     with ScrollKeys[I] do
  1286.       if (sKey = Key) and (Ctrl = (Shift = [ssCtrl])) then
  1287.       begin
  1288.     DoScroll(SBar, Action, 0);
  1289.     Exit;
  1290.       end;
  1291. end;
  1292.  
  1293. procedure TConsole.WMSetFocus(var M: TWMSetFocus);
  1294. begin
  1295.   FFocused := True;
  1296.   if FReading or (coFullTimeCursor in Options) then
  1297.     ShowCursor;
  1298.   inherited;
  1299. end;
  1300.  
  1301. procedure TConsole.WMKillFocus(var M: TWMKillFocus);
  1302. begin
  1303.   inherited;
  1304.   if FReading or (coFullTimeCursor in Options) then
  1305.     HideCursor;
  1306.   FFocused := False;
  1307. end;
  1308.  
  1309. procedure TConsole.WMGetDlgCode(var M: TWMGetDlgCode);
  1310. begin
  1311.   M.Result := dlgc_WantArrows or dlgc_WantChars;
  1312. end;
  1313.  
  1314. procedure TConsole.WMEraseBkgnd(var M: TWMEraseBkgnd);
  1315. begin
  1316.   M.Result := 1;
  1317. end;
  1318.  
  1319. procedure TConsole.DoCtrlBreak;
  1320. begin
  1321. end;
  1322.  
  1323. procedure TConsole.MouseDown(Button: TMouseButton;
  1324.   Shift: TShiftState; X, Y: Integer);
  1325. begin
  1326.   SetFocus;
  1327.   inherited MouseDown(Button, Shift, X, Y);
  1328. end;
  1329.  
  1330.  
  1331.  
  1332. {****************  TAttrManager  ****************}
  1333.  
  1334. constructor TAttr.Create(F: TFixedFont);
  1335. var
  1336.   DC: HDC;
  1337.   Save: THandle;
  1338.   TM: TTextMetric;
  1339. begin
  1340.   inherited Create;
  1341.   Assign(F);
  1342.   BkColor := F.BkColor;
  1343.   DC := GetDC(0);
  1344.   Save := SelectObject(DC, F.Handle);
  1345.   GetTextMetrics(DC, TM);
  1346.   SelectObject(DC, Save);
  1347.   ReleaseDC(0,DC);
  1348.   Overhang := TM.tmOverhang;
  1349.   Underhang := MulDiv(TM.tmDescent, TM.tmOverhang, TM.tmAscent);
  1350. end;
  1351.  
  1352.  
  1353. {****************  TAttrManager  ****************}
  1354.  
  1355. { The list of free slots in the TAttrManager's FList is maintained in the
  1356.   unused pointer slots inside the FList.  FFreeList is the index of the first
  1357.   free slot, or -1 if there are no free slots.  The pointer FList[FFreeList]
  1358.   contains the negative of the integer index of the next free slot, and so on.
  1359.   In 16 bit, this code assumes $FFFF will never appear as a selector.
  1360.   In 32 bit, this code would assume FList indexes and pointers stored in the
  1361.   FList are positive (>=0) when evaluated as signed integers.
  1362. }
  1363.  
  1364. const
  1365.   EndOfList = -32768;       { ifdef for 32 bit }
  1366.  
  1367. constructor TAttrManager.Create;
  1368. begin
  1369.   inherited Create;
  1370.   FList := TList.Create;
  1371. end;
  1372.  
  1373. destructor TAttrManager.Destroy;
  1374. begin
  1375.   inherited Destroy;
  1376.   Clear;
  1377.   FList.Free;
  1378. end;
  1379.  
  1380. function TAttrManager.GetCount;
  1381. begin
  1382.   Result := FList.Count;
  1383. end;
  1384.  
  1385. function  TAttrManager.InFreeList(P: Pointer): Boolean;
  1386. begin
  1387.   Result := (EndOfList <= Longint(P)) and (Longint(P) < 0);
  1388. end;
  1389.  
  1390. function  TAttrManager.FirstFreeIndex: Integer;
  1391. begin
  1392.   Result := FFreeList;
  1393. end;
  1394.  
  1395. function  TAttrManager.NextFreeIndex(P: Pointer): Integer;
  1396. begin
  1397.   if (EndOfList < Longint(P)) and (Longint(P) < 0) then
  1398.     Result := -Longint(P) - 1
  1399.   else
  1400.     Result := -1;
  1401. end;
  1402.  
  1403. procedure TAttrManager.SetFree(Index: Integer);
  1404. begin
  1405.   if FFreeList < 0 then
  1406.     FList[Index] := Pointer(Longint(EndOfList))
  1407.   else
  1408.     FList[Index] := Pointer(Longint(-FFreeList - 1));
  1409.   FFreeList := Index;
  1410. end;
  1411.  
  1412. function TAttrManager.AllocIndex: Integer;
  1413. begin
  1414.   if FFreeList >= 0 then
  1415.   begin
  1416.     Result := FFreeList;
  1417.     FFreeList := NextFreeIndex(FList[FFreeList]);
  1418.   end
  1419.   else
  1420.     Result := FList.Count;
  1421. end;
  1422.  
  1423. function  TAttrManager.Allocate(F: TFixedFont): Integer;
  1424. var
  1425.   P: ^Pointer;
  1426.   H: THandle;
  1427.   C,B: TColor;
  1428.   N: Integer;
  1429. begin
  1430.   Result := FCacheIndex;
  1431.   with F do
  1432.   begin
  1433.     C := Color;
  1434.     B := BkColor;
  1435.     H := Handle;
  1436.   end;
  1437.   if FCache <> nil then
  1438.   with FCache do
  1439.     if (Color = C) and (BkColor = B) and (Handle = H) then
  1440.       Exit;
  1441.  
  1442.   { Search for a match }
  1443.   Result := FList.Count;
  1444.   P := Pointer(FList.List);  { Use pointer interator instead of For loop }
  1445.   while (Result > 0) do
  1446.   begin
  1447.     if not InFreeList(P^) then
  1448.     with TAttr(P^) do
  1449.       if (Color = C) and (BkColor = B) and (Handle = H) then
  1450.       begin
  1451.         FCache := TAttr(P^);
  1452.         Result := FList.Count - Result;
  1453.         FCacheIndex := Result;
  1454.         Exit;
  1455.       end;
  1456.     Inc(P);
  1457.     Dec(Result);
  1458.   end;
  1459.  
  1460.   { No match found, so create a new TAttr in an empty slot }
  1461.   Result := AllocIndex;
  1462.   Attr[Result] := TAttr.Create(F);
  1463. end;
  1464.  
  1465. procedure TAttrManager.Clear;
  1466. var
  1467.   I: Integer;
  1468. begin
  1469.   for I := 0 to FList.Count - 1 do
  1470.     if not InFreeList(FList[I]) then
  1471.       TObject(FList[I]).Free;
  1472.   FList.Clear;
  1473.   FCacheIndex := 0;
  1474.   FCache := nil;
  1475.   FFreeList := -1;
  1476. end;
  1477.  
  1478. procedure TAttrManager.Reference(Index: Integer; Delta: Integer);
  1479. begin
  1480.   with Attr[Index] do
  1481.   begin
  1482.     Inc(RefCount, Delta);
  1483.     if RefCount <= 0 then
  1484.       Attr[Index] := nil;
  1485.   end;
  1486. end;
  1487.  
  1488. function  TAttrManager.GetAttr(Index: Integer): TAttr;
  1489. begin
  1490.   Result := TAttr(FList[Index]);
  1491.   if InFreeList(Result) then
  1492.     Result := nil;
  1493. end;
  1494.  
  1495. procedure TAttrManager.SetAttr(Index: Integer; NewAttr: TAttr);
  1496. var
  1497.   Temp: TAttr;
  1498. begin
  1499.   if NewAttr = nil then
  1500.   begin
  1501.     TObject(FList[Index]).Free;
  1502.     SetFree(Index);
  1503.   end
  1504.   else
  1505.     if Index = FList.Count then
  1506.       FList.Expand.Add(NewAttr)
  1507.     else
  1508.       FList[Index] := NewAttr;
  1509.   FCacheIndex := Index;
  1510.   FCache := NewAttr;
  1511. end;
  1512.  
  1513.  
  1514. { *************  TColorConsole *************** }
  1515.  
  1516. constructor TColorConsole.Create(Owner: TComponent);
  1517. begin
  1518.   FAttrList := TAttrManager.Create;
  1519.   inherited Create(Owner);
  1520. end;
  1521.  
  1522. destructor TColorConsole.Destroy;
  1523. begin
  1524.   inherited Destroy;
  1525.   StrDispose(Pointer(FIndexes));
  1526.   FAttrList.Free;
  1527. end;
  1528.  
  1529. function TColorConsole.IndexPtr(X,Y: Integer): PInteger;
  1530. begin
  1531.   Result := @FIndexes^[Longint(ScreenPtr(X,Y)) - Longint(FBuffer)];
  1532. end;
  1533.  
  1534. { ResizeBuffer
  1535.    - Called by constructor to init buffers, and called by SetCols/SetRows
  1536.      when Cols or Rows change.  Cols and Rows will be set to their new
  1537.      values before ResizeBuffer is called.
  1538.    - StrAlloc will fail (raise xptn) if Cols * Rows is greater than 32k - 2
  1539.    - No attempt is made to preserve the contents of the buffers.  Resizing
  1540.    the buffers is equivallent to a ClrScr.
  1541. }
  1542.  
  1543. procedure TColorConsole.ResizeBuffer;
  1544. var
  1545.   I: Integer;
  1546.   A: Integer;
  1547.   P: PInteger;
  1548.   P2: Pointer;
  1549. begin
  1550.   inherited ResizeBuffer;
  1551.   Pointer(P) := nil;
  1552.   P2 := nil;
  1553.   try
  1554.     Pointer(P) := StrAlloc(Longint(Cols) * Rows * Sizeof(Integer));
  1555.     P2 := StrAlloc(Cols * SizeOf(Integer));
  1556.     Exchange(Pointer(FIndexes), Pointer(P));
  1557.     Exchange(Pointer(FCellWidths), P2);
  1558.   finally
  1559.     StrDispose(Pointer(P));
  1560.     StrDispose(P2);
  1561.   end;
  1562.   FAttrList.Clear;
  1563.   A := FAttrList.Allocate(Font);
  1564.   FillWord(FIndexes^, Cols * Rows, A);
  1565.   FAttrList.Reference(A, Cols * Rows );
  1566.   FillWord(FCellWidths^, Cols, FCharSize.X);
  1567. end;
  1568.  
  1569. { If the character cell is larger, expand settings and redraw }
  1570. procedure TColorConsole.SetMetrics(const Metrics: TTextMetric);
  1571. var
  1572.   Changed: Boolean;
  1573.   I: Integer;
  1574.   A: TAttr;
  1575.  
  1576.   procedure Check(var A: Integer; const B: Integer);
  1577.   begin
  1578.     if A < B then
  1579.     begin
  1580.       A := B;
  1581.       Changed := True;
  1582.     end;
  1583.   end;
  1584.  
  1585. begin
  1586.     { Different fonts of the same point size have slightly different char
  1587.       cells.  Keep the global char cell large enough for all. }
  1588.   if FOldFont.Size = Font.Size then
  1589.   with Metrics do
  1590.   begin
  1591.     Changed := False;              { TT fonts don't report overhang }
  1592.     Check(FOverhang, Max(tmOverhang, tmMaxCharWidth - tmAveCharWidth));
  1593.     Check(FCharSize.X, tmAveCharWidth);
  1594.     Check(FCharSize.Y, tmHeight + tmExternalLeading);
  1595.     Check(FCharAscent, tmAscent);
  1596.     if Changed then
  1597.     begin
  1598.       if FCellWidths <> nil then
  1599.         FillWord(FCellWidths^, Cols, FCharSize.X);
  1600.       RecalcSizeAndRange;
  1601.       Invalidate;
  1602.     end;
  1603.   end
  1604.   else
  1605.   begin { If font size changed, accept new cell verbatim. }
  1606.     { Update all cached fonts to new size }
  1607.     for I := 0 to FAttrList.Count - 1 do
  1608.     begin
  1609.       A:= FAttrList[I];
  1610.       if A <> nil then
  1611.         A.Size := Font.Size;
  1612.     end;
  1613.     if FCellWidths <> nil then
  1614.       FillWord(FCellWidths^, Cols, Metrics.tmAveCharWidth);
  1615.     inherited SetMetrics(Metrics);
  1616.   end;
  1617. end;
  1618.  
  1619.  
  1620. procedure TColorConsole.WriteFill(X,Y: Integer; Ch: Char; Count: Word);
  1621. begin
  1622.   if Count = 0 then Exit;
  1623.   FillAttr(X,Y,Count);
  1624.   inherited WriteFill(X,Y,Ch,Count);  { write ch to the char buffer }
  1625. end;
  1626.  
  1627. procedure TColorConsole.FillAttr(X,Y: Integer; Count: Word);
  1628.  
  1629.   procedure ReplaceAttr(A: Integer; P: PInteger; Count: Word);
  1630.   var
  1631.     RunCount: Integer;
  1632.     RunValue: Integer;
  1633.   begin
  1634.     while Count > 0 do
  1635.     begin
  1636. {      RunValue := P^;
  1637.       RunCount := 0;
  1638.       repeat
  1639.         P^ := A;
  1640.         Inc(P);
  1641.         Inc(RunCount);
  1642.       until (RunCount >= Count) or (P^ <> RunValue);
  1643. }     asm
  1644.         LES   DI, P
  1645.         MOV   SI, DI
  1646.         MOV   AX, ES:[DI]
  1647.         MOV   CX, Count
  1648.         MOV   DX, CX
  1649.         REPE  SCASW
  1650.         JZ    @@1
  1651.         INC   CX
  1652.         DEC   DI
  1653.         DEC   DI
  1654.       @@1:
  1655.         SUB   DX, CX
  1656.         MOV   RunCount, DX
  1657.         MOV   RunValue, AX
  1658.         MOV   P.Word[0], DI
  1659.         CMP   AX, A         { If attrs are same, no need to write over them. }
  1660.         JE    @@2
  1661.         MOV   DI, SI
  1662.         MOV   CX, DX
  1663.         MOV   AX, A
  1664.         REP   STOSW
  1665.       @@2:
  1666.       end;
  1667.       FAttrList.Reference(RunValue, -RunCount);
  1668.       Dec(Count, RunCount);
  1669.     end;
  1670.   end;
  1671.  
  1672. var
  1673.   A: Integer;
  1674.   I: Integer;
  1675. begin
  1676.   A := FAttrList.Allocate(Font);
  1677.   FAttrList.Reference(A, Count);
  1678.   if (X + Count) > Cols then
  1679.   begin
  1680.     ReplaceAttr(A, IndexPtr(X,Y), Cols - X);
  1681.     Dec(Count, Cols - X);
  1682.     I := Cols;
  1683.     while Count > 0 do
  1684.     begin
  1685.       Inc(Y);
  1686.       ReplaceAttr(A, IndexPtr(X,Y), I);
  1687.       Dec(Count, I);
  1688.     end;
  1689.   end
  1690.   else
  1691.     ReplaceAttr(A, IndexPtr(X,Y), Count);
  1692. end;
  1693.  
  1694. procedure TColorConsole.WriteBlock(X,Y: Integer; Buffer: PChar; Count: Word);
  1695. begin
  1696.   if Count = 0 then Exit;
  1697.   FillAttr(X,Y,Count);                     { fill range with current attr }
  1698.   inherited WriteBlock(X,Y,Buffer,Count);  { copy chars to char buf }
  1699. end;
  1700.  
  1701. procedure TColorConsole.Paint;
  1702. var
  1703.   X1, X2, Y1, Y2, RunValue, RunEnd, Len, Count, Prev: Integer;
  1704.   R: TRect;
  1705.   P: PInteger;
  1706.   Buf: PChar;
  1707.   A: TAttr;
  1708.   C: TPoint;
  1709.   DC: HDC;
  1710. begin
  1711.   C := FCharSize;
  1712.   SetViewportOrg(Canvas.Handle, -FOrigin.X * FCharSize.X, -FOrigin.Y * C.Y);
  1713.   GetClipBox(Canvas.Handle, R);
  1714.   X1 := Max(FOrigin.X, (R.left - FOverhang) div C.X);
  1715.   X2 := Min(Cols, (R.right + C.X) div C.X);
  1716.   Y1 := Max(0, R.top div C.Y);
  1717.   Y2 := Min(Rows, (R.bottom + C.Y - 1) div C.Y);
  1718.   if ((Cols * C.X) < R.Right) then
  1719.   begin
  1720.     Canvas.Brush := Brush;
  1721.     Count := R.Left;
  1722.     R.Left := Cols * C.X;
  1723.     Canvas.FillRect(R);
  1724.     R.Right := R.Left;
  1725.     R.Left := Count;
  1726.   end;
  1727.   if (Rows * C.Y) < R.Bottom then
  1728.   begin
  1729.     Canvas.Brush := Brush;
  1730.     R.Top := Rows * C.Y;
  1731.     Canvas.FillRect(R);
  1732.   end;
  1733.     { In this tight display loop, we don't need all the automatic services
  1734.       provided by TCanvas.  To optimize performance, we'll select the text
  1735.       font and colors into the DC 'manually'. }
  1736.   DC := Canvas.Handle;
  1737.   SetBkMode(DC, OPAQUE);
  1738.   SetTextAlign(DC, TA_BaseLine);
  1739.   R.Top := Y1 * C.Y;
  1740.   R.Bottom := R.Top + C.Y;
  1741.   Prev := -1;
  1742.   while Y1 < Y2 do
  1743.   begin
  1744.     Buf := ScreenPtr(X1,Y1);
  1745.     P := IndexPtr(X1,Y1);
  1746.     Count := X2 - X1;
  1747.     RunEnd := X1;
  1748.     R.Left := X1 * C.X;
  1749.     while Count > 0 do
  1750.     begin
  1751. {      RunStart := RunEnd;
  1752.       RunValue := P^[RunEnd];
  1753.       repeat
  1754.         Inc(RunEnd);
  1755.       until (RunEnd >= X2) or (P^[RunEnd] <> RunValue);
  1756.       Len := (RunEnd - RunStart);
  1757.       Count := X2 - RunEnd;
  1758. }     asm
  1759.         LES   DI, P
  1760.         MOV   AX, ES:[DI]   { AX := P^ }
  1761.         MOV   CX, Count
  1762.         MOV   BX, CX
  1763.         REPE  SCASW
  1764.         JZ    @@1
  1765.         INC   CX
  1766.         DEC   DI
  1767.         DEC   DI
  1768.       @@1:
  1769.         MOV   P.Word[0], DI
  1770.         MOV   RunValue, AX
  1771.         SUB   BX, CX
  1772.         MOV   Count, CX
  1773.         MOV   Len, BX
  1774.         ADD   RunEnd, BX    { RunEnd := RunStart + Length }
  1775.       end;
  1776.       if RunValue <> Prev then   { Only select objects when we have to }
  1777.       begin                      { (this helps at line breaks )        }
  1778.         A := FAttrList[RunValue];
  1779.         SelectObject(DC, A.Handle);
  1780.         SetTextColor(DC, ColorToRGB(A.Color));
  1781.         SetBkColor(DC, ColorToRGB(A.BkColor));
  1782.         Prev := RunValue;
  1783.       end;
  1784.       R.Right := R.Left + Len * C.X;
  1785.       ExtTextOut(DC, R.Left - A.Underhang, R.Top + FCharAscent,
  1786.         ETO_Opaque or ETO_Clipped, @R, Buf, Len, Pointer(FCellWidths));
  1787.       R.Left := R.Right;
  1788.       Inc(Buf, Len);
  1789.     end;
  1790.     Inc(Y1);
  1791.     Inc(R.Top, C.Y);
  1792.     Inc(R.Bottom, C.Y);
  1793.   end;
  1794.    { Since we've manipulated the DC directly, and the canvas may think its
  1795.      current objects are still selected, we should force the canvas to
  1796.      deselect all GDI objects }
  1797.   Canvas.Handle := 0;
  1798. end;
  1799.  
  1800.  
  1801. procedure Register;
  1802. begin
  1803.   RegisterComponents('Additional', [TConsole, TColorConsole]);
  1804.   RegisterClasses([TFixedFont]);
  1805. end;
  1806.  
  1807.  
  1808. end.
  1809.  
  1810.  
  1811.  
  1812.  
  1813.