mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-10 19:56:21 +02:00
Debugger: Enhance console output win. Issue #33935
git-svn-id: trunk@58563 -
This commit is contained in:
martin
parent
e279c0a839
commit
4358281aed
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -5481,6 +5481,8 @@ debugger/pseudoterminaldlg.lfm svneol=native#text/plain
|
||||
debugger/pseudoterminaldlg.pp svneol=native#text/pascal
|
||||
debugger/registersdlg.lfm svneol=native#text/pascal
|
||||
debugger/registersdlg.pp svneol=native#text/pascal
|
||||
debugger/test/testconsolescroll.lpi svneol=native#text/plain
|
||||
debugger/test/testconsolescroll.pas svneol=native#text/plain
|
||||
debugger/test/watchconsolesize.lpi svneol=native#text/pascal
|
||||
debugger/test/watchconsolesize.pas svneol=native#text/pascal
|
||||
debugger/threaddlg.lfm svneol=native#text/plain
|
||||
|
||||
@ -1,24 +1,212 @@
|
||||
object PseudoConsoleDlg: TPseudoConsoleDlg
|
||||
Left = 697
|
||||
Height = 240
|
||||
Top = 327
|
||||
Width = 320
|
||||
Left = 438
|
||||
Height = 480
|
||||
Top = 321
|
||||
Width = 800
|
||||
Caption = 'Console'
|
||||
ClientHeight = 240
|
||||
ClientWidth = 320
|
||||
ClientHeight = 480
|
||||
ClientWidth = 800
|
||||
DockSite = True
|
||||
OnResize = FormResize
|
||||
LCLVersion = '1.9.0.0'
|
||||
object Memo1: TMemo
|
||||
object PageControl1: TPageControl
|
||||
Left = 0
|
||||
Height = 240
|
||||
Height = 460
|
||||
Top = 0
|
||||
Width = 320
|
||||
Width = 800
|
||||
ActivePage = TabSheetRaw
|
||||
Align = alClient
|
||||
OnUTF8KeyPress = Memo1UTF8KeyPress
|
||||
ReadOnly = True
|
||||
ScrollBars = ssAutoBoth
|
||||
TabIndex = 1
|
||||
TabOrder = 0
|
||||
WantTabs = True
|
||||
object TabSheet1: TTabSheet
|
||||
Caption = 'Formatted'
|
||||
ClientHeight = 430
|
||||
ClientWidth = 790
|
||||
TabVisible = False
|
||||
object Panel1: TPanel
|
||||
Left = 470
|
||||
Height = 430
|
||||
Top = 0
|
||||
Width = 160
|
||||
Align = alRight
|
||||
Caption = 'Panel1'
|
||||
TabOrder = 0
|
||||
end
|
||||
end
|
||||
object TabSheetRaw: TTabSheet
|
||||
Caption = 'Raw Output'
|
||||
ClientHeight = 430
|
||||
ClientWidth = 790
|
||||
object PairSplitterRaw: TPairSplitter
|
||||
Left = 0
|
||||
Height = 430
|
||||
Top = 0
|
||||
Width = 790
|
||||
Align = alClient
|
||||
Position = 600
|
||||
object PairSplitterRawLeft: TPairSplitterSide
|
||||
Cursor = crArrow
|
||||
Left = 0
|
||||
Height = 430
|
||||
Top = 0
|
||||
Width = 600
|
||||
ClientWidth = 600
|
||||
ClientHeight = 430
|
||||
Constraints.MinWidth = 200
|
||||
object Memo1: TMemo
|
||||
Left = 4
|
||||
Height = 422
|
||||
Top = 4
|
||||
Width = 592
|
||||
Align = alClient
|
||||
BorderSpacing.Around = 4
|
||||
Font.Name = 'Monospace'
|
||||
OnUTF8KeyPress = Memo1UTF8KeyPress
|
||||
ParentFont = False
|
||||
ReadOnly = True
|
||||
ScrollBars = ssAutoBoth
|
||||
TabOrder = 0
|
||||
WantTabs = True
|
||||
end
|
||||
end
|
||||
object PairSplitterRawRight: TPairSplitterSide
|
||||
Cursor = crArrow
|
||||
Left = 605
|
||||
Height = 430
|
||||
Top = 0
|
||||
Width = 200
|
||||
ClientWidth = 200
|
||||
ClientHeight = 430
|
||||
Constraints.MinWidth = 200
|
||||
OnResize = PairSplitterRawRightResize
|
||||
object RadioGroupRight: TRadioGroup
|
||||
Left = 0
|
||||
Height = 103
|
||||
Top = 0
|
||||
Width = 200
|
||||
Align = alTop
|
||||
AutoFill = True
|
||||
AutoSize = True
|
||||
Caption = 'Output Style'
|
||||
ChildSizing.LeftRightSpacing = 6
|
||||
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
|
||||
ChildSizing.EnlargeVertical = crsHomogenousChildResize
|
||||
ChildSizing.ShrinkHorizontal = crsScaleChilds
|
||||
ChildSizing.ShrinkVertical = crsScaleChilds
|
||||
ChildSizing.Layout = cclLeftToRightThenTopToBottom
|
||||
ChildSizing.ControlsPerLine = 1
|
||||
ClientHeight = 84
|
||||
ClientWidth = 198
|
||||
ItemIndex = 0
|
||||
Items.Strings = (
|
||||
'Unformatted'
|
||||
'C0 as Control Pictures'
|
||||
'C0 as ISO 2047'
|
||||
'Hex + ASCII'
|
||||
)
|
||||
OnSelectionChanged = RadioGroupRightSelectionChanged
|
||||
TabOrder = 1
|
||||
end
|
||||
object PanelRightBelowRG: TPanel
|
||||
Left = 0
|
||||
Height = 327
|
||||
Top = 103
|
||||
Width = 200
|
||||
Align = alClient
|
||||
BevelOuter = bvNone
|
||||
ClientHeight = 327
|
||||
ClientWidth = 200
|
||||
TabOrder = 0
|
||||
object CheckGroupRight: TCheckGroup
|
||||
Left = 0
|
||||
Height = 73
|
||||
Top = 0
|
||||
Width = 200
|
||||
Align = alTop
|
||||
AutoFill = True
|
||||
AutoSize = True
|
||||
Caption = 'Decorations'
|
||||
ChildSizing.LeftRightSpacing = 6
|
||||
ChildSizing.TopBottomSpacing = 6
|
||||
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
|
||||
ChildSizing.EnlargeVertical = crsHomogenousChildResize
|
||||
ChildSizing.ShrinkHorizontal = crsScaleChilds
|
||||
ChildSizing.ShrinkVertical = crsScaleChilds
|
||||
ChildSizing.Layout = cclLeftToRightThenTopToBottom
|
||||
ChildSizing.ControlsPerLine = 1
|
||||
ClientHeight = 54
|
||||
ClientWidth = 198
|
||||
Enabled = False
|
||||
Items.Strings = (
|
||||
'Line numbers'
|
||||
'C1 as C0 + Underbar'
|
||||
)
|
||||
TabOrder = 1
|
||||
Data = {
|
||||
020000000202
|
||||
}
|
||||
end
|
||||
object PanelRightBelowCG: TPanel
|
||||
Left = 0
|
||||
Height = 254
|
||||
Top = 73
|
||||
Width = 200
|
||||
Align = alClient
|
||||
BevelOuter = bvNone
|
||||
ClientHeight = 254
|
||||
ClientWidth = 200
|
||||
TabOrder = 0
|
||||
object GroupBoxRight: TGroupBox
|
||||
Left = 0
|
||||
Height = 64
|
||||
Top = 0
|
||||
Width = 200
|
||||
Align = alTop
|
||||
Caption = 'Line limit'
|
||||
ClientHeight = 45
|
||||
ClientWidth = 198
|
||||
TabOrder = 0
|
||||
object MaskEdit1: TMaskEdit
|
||||
Left = 9
|
||||
Height = 30
|
||||
Top = 0
|
||||
Width = 128
|
||||
CharCase = ecNormal
|
||||
MaxLength = 7
|
||||
TabOrder = 0
|
||||
EditMask = '#######'
|
||||
Text = '5000 '
|
||||
SpaceChar = '_'
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
object StatusBar1: TStatusBar
|
||||
Left = 0
|
||||
Height = 20
|
||||
Top = 460
|
||||
Width = 800
|
||||
Panels = <
|
||||
item
|
||||
Text = ' dumb'
|
||||
Width = 160
|
||||
end
|
||||
item
|
||||
Text = '00 x 00 chars'
|
||||
Width = 160
|
||||
end
|
||||
item
|
||||
Text = '000 x 000 pixels'
|
||||
Width = 160
|
||||
end
|
||||
item
|
||||
Text = 'Not resized'
|
||||
Width = 160
|
||||
end>
|
||||
SimplePanel = False
|
||||
end
|
||||
end
|
||||
|
||||
@ -27,25 +27,42 @@
|
||||
}
|
||||
|
||||
unit PseudoTerminalDlg;
|
||||
{$IFDEF linux} {$DEFINE DBG_ENABLE_TERMINAL} {$ENDIF}
|
||||
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{$IFDEF linux} {$DEFINE DBG_ENABLE_TERMINAL} {$ENDIF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
IDEWindowIntf, Classes, Graphics,
|
||||
Forms, StdCtrls, DebuggerDlg, BaseDebugManager, LazarusIDEStrConsts, LCLType;
|
||||
IDEWindowIntf, Classes, Graphics, Forms, StdCtrls, DebuggerDlg,
|
||||
BaseDebugManager, LazarusIDEStrConsts, LCLType, ComCtrls, ExtCtrls, MaskEdit,
|
||||
PairSplitter;
|
||||
|
||||
type
|
||||
|
||||
{ TPseudoConsoleDlg }
|
||||
|
||||
TPseudoConsoleDlg = class(TDebuggerDlg)
|
||||
CheckGroupRight: TCheckGroup;
|
||||
GroupBoxRight: TGroupBox;
|
||||
MaskEdit1: TMaskEdit;
|
||||
Memo1: TMemo;
|
||||
PageControl1: TPageControl;
|
||||
PairSplitterRaw: TPairSplitter;
|
||||
PairSplitterRawLeft: TPairSplitterSide;
|
||||
PairSplitterRawRight: TPairSplitterSide;
|
||||
Panel1: TPanel;
|
||||
PanelRightBelowRG: TPanel;
|
||||
PanelRightBelowCG: TPanel;
|
||||
RadioGroupRight: TRadioGroup;
|
||||
StatusBar1: TStatusBar;
|
||||
TabSheet1: TTabSheet;
|
||||
TabSheetRaw: TTabSheet;
|
||||
procedure FormResize(Sender: TObject);
|
||||
procedure Memo1UTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
|
||||
procedure PairSplitterRawRightResize(Sender: TObject);
|
||||
procedure RadioGroupRightSelectionChanged(Sender: TObject);
|
||||
private
|
||||
{ private declarations }
|
||||
ttyHandle: System.THandle; (* Used only by unix for console size tracking *)
|
||||
@ -53,6 +70,7 @@ type
|
||||
fCharWidth: word;
|
||||
fRowsPerScreen: integer;
|
||||
fColsPerRow: integer;
|
||||
fFirstLine: integer;
|
||||
procedure getCharHeightAndWidth(consoleFont: TFont; out h, w: word);
|
||||
procedure consoleSizeChanged;
|
||||
protected
|
||||
@ -75,7 +93,7 @@ var
|
||||
implementation
|
||||
|
||||
uses
|
||||
SysUtils, LazLoggerBase
|
||||
SysUtils, StrUtils, LazLoggerBase
|
||||
{$IFDEF DBG_ENABLE_TERMINAL}
|
||||
, Unix, BaseUnix, termio
|
||||
{$ENDIF DBG_ENABLE_TERMINAL}
|
||||
@ -98,6 +116,50 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure TPseudoConsoleDlg.PairSplitterRawRightResize(Sender: TObject);
|
||||
|
||||
var
|
||||
ttyNotYetInitialised: boolean;
|
||||
|
||||
begin
|
||||
|
||||
(* These are not errors so much as conditions we will see while the IDE is *)
|
||||
(* starting up. *)
|
||||
|
||||
if DebugBoss = nil then
|
||||
exit;
|
||||
if DebugBoss.PseudoTerminal = nil then
|
||||
exit;
|
||||
|
||||
(* Even if the IDE is initialised this can be called before the TTY is set up, *)
|
||||
(* so while we prefer success we also consider that failure /is/ an acceptable *)
|
||||
(* option in this case. *)
|
||||
|
||||
ttyNotYetInitialised := ttyHandle = handleUnopened;
|
||||
//DebugLn(DBG_VERBOSE, ['TPseudoConsoleDlg.SplitterRawRightResize Calling consoleSizeChanged']);
|
||||
consoleSizeChanged;
|
||||
if ttyNotYetInitialised and (integer(ttyHandle) < 0) then begin
|
||||
DebugLn(DBG_WARNINGS, ['TPseudoConsoleDlg.SplitterRawRightResize Bad PseudoTerminal -> unopened']);
|
||||
ttyHandle := handleUnopened
|
||||
end;
|
||||
StatusBar1.Panels[3].Text := 'Splitter resized'
|
||||
end { TPseudoConsoleDlg.PairSplitterRawRightResize } ;
|
||||
|
||||
|
||||
(* The C1 underbar decoration is only relevant when C0 is being displayed as
|
||||
control pictures or ISO 2047 glyphs.
|
||||
*)
|
||||
procedure TPseudoConsoleDlg.RadioGroupRightSelectionChanged(Sender: TObject);
|
||||
|
||||
begin
|
||||
case RadioGroupRight.ItemIndex of
|
||||
1, 2: CheckGroupRight.CheckEnabled[1] := true
|
||||
otherwise
|
||||
CheckGroupRight.CheckEnabled[1] := false
|
||||
end
|
||||
end { TPseudoConsoleDlg.RadioGroupRightSelectionChanged } ;
|
||||
|
||||
|
||||
(* The form size has changed. Call a procedure to pass this to the kernel etc.,
|
||||
assuming that this works out the best control to track.
|
||||
*)
|
||||
@ -126,11 +188,13 @@ begin
|
||||
if ttyNotYetInitialised and (integer(ttyHandle) < 0) then begin
|
||||
DebugLn(DBG_WARNINGS, ['TPseudoConsoleDlg.FormResize Bad PseudoTerminal -> unopened']);
|
||||
ttyHandle := handleUnopened
|
||||
end
|
||||
end;
|
||||
end;
|
||||
StatusBar1.Panels[3].Text := 'Window resized'
|
||||
end { TPseudoConsoleDlg.FormResize } ;
|
||||
|
||||
|
||||
procedure TPseudoConsoleDlg.DoClose(var CloseAction: TCloseAction);
|
||||
|
||||
begin
|
||||
{$IFDEF DBG_ENABLE_TERMINAL}
|
||||
if integer(ttyHandle) >= 0 then begin
|
||||
@ -140,17 +204,20 @@ begin
|
||||
{$ENDIF DBG_ENABLE_TERMINAL}
|
||||
inherited DoClose(CloseAction);
|
||||
CloseAction := caHide;
|
||||
end;
|
||||
end { TPseudoConsoleDlg.DoClose } ;
|
||||
|
||||
|
||||
constructor TPseudoConsoleDlg.Create(TheOwner: TComponent);
|
||||
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
font.Name := 'monospace';
|
||||
Caption:= lisDbgTerminal;
|
||||
ttyHandle := handleUnopened;
|
||||
fRowsPerScreen := -1;
|
||||
fColsPerRow := -1
|
||||
end;
|
||||
fColsPerRow := -1;
|
||||
fFirstLine := 1
|
||||
end { TPseudoConsoleDlg.Create } ;
|
||||
|
||||
|
||||
(* Get the height and width for characters described by the fount specified by
|
||||
@ -173,7 +240,7 @@ begin
|
||||
finally
|
||||
bm.Free
|
||||
end
|
||||
end;
|
||||
end { TPseudoConsoleDlg.getCharHeightAndWidth } ;
|
||||
|
||||
|
||||
(* Assume that the console size has changed, either because it's just starting
|
||||
@ -184,7 +251,7 @@ end;
|
||||
*)
|
||||
procedure TPseudoConsoleDlg.consoleSizeChanged;
|
||||
|
||||
{$IFDEF DBG_ENABLE_TERMINAL }
|
||||
{$IFDEF DBG_ENABLE_TERMINAL}
|
||||
{ DEFINE USE_SLAVE_HANDLE }
|
||||
{ DEFINE SEND_EXPLICIT_SIGNAL }
|
||||
|
||||
@ -274,34 +341,424 @@ begin
|
||||
{$ELSE }
|
||||
begin
|
||||
ttyHandle := THandle(-1); (* Not used in non-unix OSes *)
|
||||
{$ENDIF DBG_ENABLE_TERMINAL }
|
||||
Assert(ttyHandle <> handleUnopened, 'TPseudoConsoleDlg.consoleSizeChanged: TTY handle still in virgin state at exit')
|
||||
end;
|
||||
{$ENDIF DBG_ENABLE_TERMINAL}
|
||||
Assert(ttyHandle <> handleUnopened, 'TPseudoConsoleDlg.consoleSizeChanged: TTY handle still in virgin state at exit');
|
||||
RadioGroupRightSelectionChanged(nil); (* Sort out initial state *)
|
||||
StatusBar1.Panels[0].Width := Width div 4;
|
||||
StatusBar1.Panels[0].Text := ' ' ; // + DebugBoss.Debugger.Environment.Values['TERM'];
|
||||
StatusBar1.Panels[1].Width := Width div 4;
|
||||
{$IFDEF DBG_ENABLE_TERMINAL}
|
||||
StatusBar1.Panels[1].Text := Format('%d cols x %d rows', [winsize.ws_col, winsize.ws_row]);
|
||||
{$ENDIF DBG_ENABLE_TERMINAL}
|
||||
StatusBar1.Panels[2].Width := Width div 4;
|
||||
{$IFDEF DBG_ENABLE_TERMINAL}
|
||||
StatusBar1.Panels[2].Text := Format('%d x %d pixels', [winsize.ws_xpixel, winsize.ws_ypixel])
|
||||
{$ENDIF DBG_ENABLE_TERMINAL}
|
||||
end { TPseudoConsoleDlg.consoleSizeChanged } ;
|
||||
|
||||
|
||||
procedure TPseudoConsoleDlg.AddOutput(const AText: String);
|
||||
|
||||
var
|
||||
lineLimit, numLength, i: integer;
|
||||
buffer: TStringList;
|
||||
|
||||
|
||||
(* Translate C0 control codes to "control pictures", and optionally C1 codes
|
||||
to the same glyph but with an underbar.
|
||||
*)
|
||||
function withControlPictures(const str: widestring; c1Underbar: boolean): widestring;
|
||||
|
||||
const
|
||||
nul= #$2400; // ␀
|
||||
soh= #$2401; // ␁
|
||||
stx= #$2402; // ␂
|
||||
etx= #$2403; // ␃
|
||||
eot= #$2404; // ␄
|
||||
enq= #$2405; // ␅
|
||||
ack= #$2406; // ␆
|
||||
bel= #$2407; // ␇
|
||||
bs= #$2408; // ␈
|
||||
ht= #$2409; // ␉
|
||||
lf= #$240a; // ␊
|
||||
vt= #$240b; // ␋
|
||||
ff= #$240c; // ␌
|
||||
cr= #$240d; // ␍
|
||||
so= #$240e; // ␎
|
||||
si= #$240f; // ␏
|
||||
dle= #$2410; // ␐
|
||||
dc1= #$2411; // ␑
|
||||
dc2= #$2412; // ␒
|
||||
dc3= #$2413; // ␓
|
||||
dc4= #$2414; // ␔
|
||||
nak= #$2415; // ␕
|
||||
syn= #$2416; // ␖
|
||||
etb= #$2417; // ␗
|
||||
can= #$2418; // ␘
|
||||
em= #$2419; // ␙
|
||||
sub= #$241a; // ␚
|
||||
esc= #$241b; // ␛
|
||||
fs= #$241c; // ␜
|
||||
gs= #$241d; // ␝
|
||||
rs= #$241e; // ␞
|
||||
us= #$241f; // ␟
|
||||
del= #$2420; // ␡
|
||||
bar= #$033c; // ̼'
|
||||
|
||||
var
|
||||
i, test, masked: integer;
|
||||
|
||||
begin
|
||||
result := str;
|
||||
|
||||
(* This should probably be recoded to use a persistent table, but doing it *)
|
||||
(* this way results in no lookup for plain text which is likely to be the *)
|
||||
(* bulk of the output. I'm not making any assumptions about the Unicode *)
|
||||
(* characters being sequential so that this code can be used both for control *)
|
||||
(* pictures and ISO-2047 glyphs, and so that if somebody has (good) reason to *)
|
||||
(* want to adjust them he can do so. *)
|
||||
|
||||
for i := Length(result) downto 1 do begin
|
||||
test := Ord(result[i]);
|
||||
if c1Underbar then
|
||||
masked := test and $7f (* Handle both C0 and C1 in one operation *)
|
||||
else
|
||||
masked := test;
|
||||
case masked of
|
||||
$00: result[i] := nul;
|
||||
$01: result[i] := soh;
|
||||
$02: result[i] := stx;
|
||||
$03: result[i] := etx;
|
||||
$04: result[i] := eot;
|
||||
$05: result[i] := enq;
|
||||
$06: result[i] := ack;
|
||||
$07: result[i] := bel;
|
||||
$08: result[i] := bs;
|
||||
$09: result[i] := ht;
|
||||
$0a: result[i] := lf;
|
||||
$0b: result[i] := vt;
|
||||
$0c: result[i] := ff;
|
||||
$0d: result[i] := cr;
|
||||
$0e: result[i] := so;
|
||||
$0f: result[i] := si;
|
||||
$10: result[i] := dle;
|
||||
$11: result[i] := dc1;
|
||||
$12: result[i] := dc2;
|
||||
$13: result[i] := dc3;
|
||||
$14: result[i] := dc4;
|
||||
$15: result[i] := nak;
|
||||
$16: result[i] := syn;
|
||||
$17: result[i] := etb;
|
||||
$18: result[i] := can;
|
||||
$19: result[i] := em;
|
||||
$1a: result[i] := sub;
|
||||
$1b: result[i] := esc;
|
||||
$1c: result[i] := fs;
|
||||
$1d: result[i] := gs;
|
||||
$1e: result[i] := rs;
|
||||
$1f: result[i] := us;
|
||||
$7f: result[i] := del
|
||||
otherwise
|
||||
end;
|
||||
if c1Underbar and (* Now fix changed C1 characters *)
|
||||
(Ord(result[i]) <> test) and (* Was changed, so must be C0 or C1 *)
|
||||
(masked <> test) then (* MSB masked so must be C1, add bar *)
|
||||
Insert(bar, result, i + 1)
|
||||
end
|
||||
end { withControlPictures } ;
|
||||
|
||||
|
||||
(* Translate C0 control codes to "pretty pictures", and optionally C1 codes
|
||||
to the same glyph but with an underbar.
|
||||
*)
|
||||
function withIso2047(const str: widestring; c1Underbar: boolean): widestring;
|
||||
|
||||
(* I've not got access to a pukka copy of ISO-2047, so like (it appears) *)
|
||||
(* almost everybody else I'm assuming that the Wikipedia page is correct. *)
|
||||
(* this differs from the ECMA standard (only) in the backspace glyph, some *)
|
||||
(* terminals in particular the Burroughs TD730/830 range manufactured in the *)
|
||||
(* 1970s and 1980s depart slightly more. I've found limited open source *)
|
||||
(* projects that refer to this encoding, and those I've found have attempted *)
|
||||
(* to "correct" details like the "direction of rotation" of the glyphs for *)
|
||||
(* the DC1 through DC4 codes. *)
|
||||
(* *)
|
||||
(* Suffixes W, E and B below refer to the variants found in the Wikipedia *)
|
||||
(* article, the ECMA standard and the Burroughs terminal documentation. *)
|
||||
|
||||
const
|
||||
nul= #$2395; // ⎕
|
||||
soh= #$2308; // ⌈
|
||||
stx= #$22A5; // ⊥
|
||||
etx= #$230B; // ⌋
|
||||
eot= #$2301; // ⌁
|
||||
enq= #$22A0; // ⊠
|
||||
ack= #$2713; // ✓
|
||||
bel= #$237E; // ⍾
|
||||
bsW= #$232B; // ⌫
|
||||
bsB= #$2196; // ↖ The ECMA glyph is slightly curved
|
||||
bs= bsB; // and has no Unicode representation.
|
||||
ht= #$2AAB; // ⪫
|
||||
lf= #$2261; // ≡
|
||||
vt= #$2A5B; // ⩛
|
||||
ff= #$21A1; // ↡
|
||||
crW= #$2aaa; // ⪪ ECMA the same
|
||||
crB= #$25bf; // ▿
|
||||
cr= crW;
|
||||
so= #$2297; // ⊗
|
||||
si= #$2299; // ⊙
|
||||
dle= #$229F; // ⊟
|
||||
dc1= #$25F7; // ◷ Nota bene: these rotate deosil
|
||||
dc2= #$25F6; // ◶
|
||||
dc3= #$25F5; // ◵
|
||||
dc4= #$25F4; // ◴
|
||||
nak= #$237B; // ⍻
|
||||
syn= #$238D; // ⎍
|
||||
etb= #$22A3; // ⊣
|
||||
can= #$29D6; // ⧖
|
||||
em= #$237F; // ⍿
|
||||
sub= #$2426; // ␦
|
||||
esc= #$2296; // ⊖
|
||||
fs= #$25F0; // ◰ Nota bene: these rotate widdershins
|
||||
gsW= #$25F1; // ◱ ECMA the same
|
||||
gsB= #$25b5; // ▵
|
||||
gs= gsW;
|
||||
rsW= #$25F2; // ◲ ECMA the same
|
||||
rsB= #$25c3; // ◃
|
||||
rs= rsW;
|
||||
usW= #$25F3; // ◳ ECMA the same
|
||||
usB= #$25b9; // ▹
|
||||
us= usW;
|
||||
del= #$2425; // ␥
|
||||
bar= #$033c; // ̼'
|
||||
|
||||
(* Not represented above is a Burroughs glyph for ETX, which in the material *)
|
||||
(* available to me appears indistinguisable from CAN. If anybody has variant *)
|
||||
(* glyphs from other manufacturers please contribute. *)
|
||||
|
||||
var
|
||||
i, test, masked: integer;
|
||||
|
||||
begin
|
||||
result := str;
|
||||
|
||||
(* This should probably be recoded to use a persistent table, but doing it *)
|
||||
(* this way results in no lookup for plain text which is likely to be the *)
|
||||
(* bulk of the output. I'm not making any assumptions about the Unicode *)
|
||||
(* characters being sequential so that this code can be used both for control *)
|
||||
(* pictures and ISO-2047 glyphs, and so that if somebody has (good) reason to *)
|
||||
(* want to adjust them she can do so. *)
|
||||
|
||||
for i := Length(result) downto 1 do begin
|
||||
test := Ord(result[i]);
|
||||
if c1Underbar then
|
||||
masked := test and $7f (* Handle both C0 and C1 in one operation *)
|
||||
else
|
||||
masked := test;
|
||||
case masked of
|
||||
$00: result[i] := nul;
|
||||
$01: result[i] := soh;
|
||||
$02: result[i] := stx;
|
||||
$03: result[i] := etx;
|
||||
$04: result[i] := eot;
|
||||
$05: result[i] := enq;
|
||||
$06: result[i] := ack;
|
||||
$07: result[i] := bel;
|
||||
$08: result[i] := bs;
|
||||
$09: result[i] := ht;
|
||||
$0a: result[i] := lf;
|
||||
$0b: result[i] := vt;
|
||||
$0c: result[i] := ff;
|
||||
$0d: result[i] := cr;
|
||||
$0e: result[i] := so;
|
||||
$0f: result[i] := si;
|
||||
$10: result[i] := dle;
|
||||
$11: result[i] := dc1;
|
||||
$12: result[i] := dc2;
|
||||
$13: result[i] := dc3;
|
||||
$14: result[i] := dc4;
|
||||
$15: result[i] := nak;
|
||||
$16: result[i] := syn;
|
||||
$17: result[i] := etb;
|
||||
$18: result[i] := can;
|
||||
$19: result[i] := em;
|
||||
$1a: result[i] := sub;
|
||||
$1b: result[i] := esc;
|
||||
$1c: result[i] := fs;
|
||||
$1d: result[i] := gs;
|
||||
$1e: result[i] := rs;
|
||||
$1f: result[i] := us;
|
||||
$7f: result[i] := del
|
||||
otherwise
|
||||
end;
|
||||
if c1Underbar and (* Now fix changed C1 characters *)
|
||||
(Ord(result[i]) <> test) and (* Was changed, so must be C0 or C1 *)
|
||||
(masked <> test) then (* MSB masked so must be C1, add bar *)
|
||||
Insert(bar, result, i + 1)
|
||||
end
|
||||
end { withIso2047 } ;
|
||||
|
||||
|
||||
(* Look at the line index cl in a TStringList. Assume that at the start there
|
||||
will be a line number and padding occupying nl characters, after that will
|
||||
be text. Convert the text to hex possibly inserting extra lines after the
|
||||
one being processed, only the first (i.e. original) line has a line number.
|
||||
*)
|
||||
procedure expandAsHex(var stringList: TStringList; currentLine, lineNumberLength: integer);
|
||||
|
||||
var
|
||||
lineNumberAsText, scratch : string;
|
||||
dataAsByteArray: TBytes;
|
||||
lengthLastBlock, startLastBlock: integer;
|
||||
|
||||
|
||||
(* Recursively process the byte array from the end to the beginning. All
|
||||
lines are inserted immediately after the original current line, except for
|
||||
the final line processed which overwrites the original.
|
||||
*)
|
||||
procedure hexLines(start, bytes: integer);
|
||||
|
||||
|
||||
(* The parameter is a line number as text or an equivalent run of spaces.
|
||||
The result is a line of hex + ASCII data.
|
||||
*)
|
||||
function oneHexLine(const lineNum: string): widestring;
|
||||
|
||||
var
|
||||
i: integer;
|
||||
|
||||
begin
|
||||
result := lineNum;
|
||||
for i := 0 to 15 do
|
||||
if i < bytes then
|
||||
result += LowerCase(HexStr(dataAsByteArray[start + i], 2)) + ' '
|
||||
else
|
||||
result += ' ';
|
||||
result += ' '; (* Between hex and ASCII *)
|
||||
for i := 0 to 15 do
|
||||
if i < bytes then
|
||||
case dataAsByteArray[start + i] of
|
||||
$20..$7e: result += Chr(dataAsByteArray[start + i])
|
||||
otherwise
|
||||
result += #$00B7 // ·
|
||||
end
|
||||
end { oneHexLine } ;
|
||||
|
||||
|
||||
begin
|
||||
if start = 0 then
|
||||
stringList[currentLine] := oneHexLine(lineNumberAsText)
|
||||
else begin
|
||||
stringList.insert(currentLine + 1, oneHexLine(PadLeft('', Length(lineNumberAsText))));
|
||||
hexLines(start - 16, 16)
|
||||
end
|
||||
end { hexLines } ;
|
||||
|
||||
|
||||
begin
|
||||
if lineNumberLength = 0 then begin
|
||||
lineNumberAsText := '';
|
||||
dataAsByteArray := BytesOf(Copy(stringList[currentLine], 1,
|
||||
Length(stringList[currentLine])))
|
||||
end else begin (* Remember one extra space after number *)
|
||||
lineNumberAsText := Copy(stringList[currentLine], 1, lineNumberLength + 1);
|
||||
dataAsByteArray := BytesOf(Copy(stringList[currentLine], lineNumberLength + 2,
|
||||
Length(stringList[currentLine]) - (lineNumberLength + 1)))
|
||||
end;
|
||||
lengthLastBlock := Length(dataAsByteArray) mod 16;
|
||||
startLastBlock := Length(dataAsByteArray) - lengthLastBlock;
|
||||
hexLines(startLastBlock, lengthLastBlock)
|
||||
end { expandAsHex } ;
|
||||
|
||||
|
||||
begin
|
||||
if ttyHandle = handleUnopened then begin (* Do this at first output only *)
|
||||
//DebugLn(DBG_VERBOSE, ['TPseudoConsoleDlg.AddOutput Calling consoleSizeChanged']);
|
||||
consoleSizeChanged
|
||||
end;
|
||||
while Memo1.Lines.Count > 5000 do
|
||||
|
||||
(* Get the maximum number of lines to be displayed from the user interface, *)
|
||||
(* work out how much space is needed to display a line number, and if necessary *)
|
||||
(* trim the amount of currently-stored text. *)
|
||||
|
||||
try
|
||||
lineLimit := StrToInt(Trim(MaskEdit1.Text))
|
||||
except
|
||||
MaskEdit1.Text := '5000';
|
||||
lineLimit := 5000
|
||||
end;
|
||||
if CheckGroupRight.Checked[0] then (* Line numbers? *)
|
||||
case lineLimit + fFirstLine - 1 of
|
||||
0..999: numLength := 3;
|
||||
1000..99999: numLength := 5;
|
||||
100000..9999999: numLength := 7
|
||||
otherwise
|
||||
numLength := 9
|
||||
end
|
||||
else
|
||||
numLength := 0;
|
||||
Memo1.Lines.BeginUpdate;
|
||||
while Memo1.Lines.Count > lineLimit do
|
||||
Memo1.Lines.Delete(0);
|
||||
|
||||
// Working note: make any adjustment to the number of lines etc. before we
|
||||
// start to add text which might include escape handling.
|
||||
(* Use an intermediate buffer to process the line or potentially lines of text *)
|
||||
(* passed as the parameter; where formatting as hex breaks it up into multiple *)
|
||||
(* lines, the line number is blanked on the synthetic ones. When lines or lists *)
|
||||
(* of lines are processed in reverse it is because an indeterminate number of *)
|
||||
(* insertions (e.g. Unicode combining diacritics or extended hex output) may be *)
|
||||
(* inserted after the current index. *)
|
||||
(* *)
|
||||
(* This might look like a bit of a palaver, but a standard memo might exhibit *)
|
||||
(* "interesting" behavior once the amount of text causes it to start scrolling *)
|
||||
(* so having an intermediate that can be inspected might be useful. *)
|
||||
|
||||
buffer := TStringList.Create;
|
||||
try
|
||||
buffer.Text := AText; (* Decides what line breaks it wants to swallow *)
|
||||
if buffer.Count = 1 then
|
||||
i := 12345 (* Good place for a breakpoint *)
|
||||
else
|
||||
i := 67890; (* Another good place for a breakpoint *)
|
||||
case RadioGroupRight.ItemIndex of
|
||||
1: for i := 0 to buffer.Count - 1 do
|
||||
buffer[i] := withControlPictures(buffer[i], CheckGroupRight.Checked[1]);
|
||||
2: for i := 0 to buffer.Count - 1 do
|
||||
buffer[i] := withIso2047(buffer[i], CheckGroupRight.Checked[1])
|
||||
otherwise
|
||||
end;
|
||||
for i := 0 to buffer.Count - 1 do begin (* Line numbers *)
|
||||
if numLength > 0 then
|
||||
buffer[i] := PadLeft(IntToStr(fFirstLine), numLength) + ' ' + buffer[i];
|
||||
fFirstLine += 1
|
||||
end;
|
||||
if RadioGroupRight.ItemIndex = 3 then (* Expand hex line-by-line in reverse *)
|
||||
for i := buffer.Count - 1 downto 0 do
|
||||
expandAsHex(buffer, i, numLength);
|
||||
|
||||
(* Add the buffered text to the visible control(s), and clean up. *)
|
||||
|
||||
Memo1.Lines.AddStrings(buffer)
|
||||
finally
|
||||
buffer.Free;
|
||||
Memo1.Lines.EndUpdate
|
||||
end;
|
||||
Memo1.SelStart := length(Memo1.Text)
|
||||
end { TPseudoConsoleDlg.AddOutput } ;
|
||||
|
||||
Memo1.Text:=Memo1.Text+AText;
|
||||
Memo1.SelStart := length(Memo1.Text);
|
||||
end;
|
||||
|
||||
procedure TPseudoConsoleDlg.Clear;
|
||||
|
||||
begin
|
||||
//DebugLn(DBG_VERBOSE, ['TPseudoConsoleDlg.Clear Calling FormResize']);
|
||||
FormResize(nil); (* Safe during IDE initialisation *)
|
||||
Memo1.Text := '';
|
||||
end;
|
||||
Memo1.Lines.BeginUpdate;
|
||||
try
|
||||
FormResize(nil); (* Safe during IDE initialisation *)
|
||||
Memo1.Text := ''
|
||||
finally
|
||||
Memo1.Lines.EndUpdate;
|
||||
end;
|
||||
fFirstLine := 1
|
||||
end { TPseudoConsoleDlg.Clear } ;
|
||||
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
|
||||
53
debugger/test/testconsolescroll.lpi
Normal file
53
debugger/test/testconsolescroll.lpi
Normal file
@ -0,0 +1,53 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="11"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasScaledStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="My Application"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
<Modes Count="0"/>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="testconsolescroll.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="TestConsoleScroll"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<Target>
|
||||
<Filename Value="testconsolescroll"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="2">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
27
debugger/test/testconsolescroll.pas
Normal file
27
debugger/test/testconsolescroll.pas
Normal file
@ -0,0 +1,27 @@
|
||||
program TestConsoleScroll;
|
||||
|
||||
(* This console-mode program for Linux or other unix implementations outputs *)
|
||||
(* 100 numbered lines, followed by all 256 8-bit characters as a block. The *)
|
||||
(* lines should be presented without intervening blanks, the character block *)
|
||||
(* should make sense provided that a formatted console style is selected. *)
|
||||
(* *)
|
||||
(* It DOES NOT attempt any formatted output using escape sequences etc. MarkMLl *)
|
||||
|
||||
uses
|
||||
SysUtils;
|
||||
|
||||
var
|
||||
i, j: integer;
|
||||
|
||||
begin
|
||||
for i := 1 to 100 do
|
||||
WriteLn(i);
|
||||
WriteLn;
|
||||
for i := 0 to 15 do begin
|
||||
for j := 1 to 15 do
|
||||
Write(Chr(16 * i + j));
|
||||
WriteLn
|
||||
end;
|
||||
WriteLn
|
||||
end.
|
||||
|
||||
@ -53,6 +53,8 @@ end { hookWinch } ;
|
||||
|
||||
|
||||
begin
|
||||
WriteLn('This header line comprises 50 characters plus EOL.');
|
||||
WriteLn;
|
||||
WriteLn('Press key to terminate.'); // http://ars.userfriendly.org/cartoons/?id=20030128
|
||||
reportSize;
|
||||
if not hookWinch() then
|
||||
|
||||
Loading…
Reference in New Issue
Block a user