From 4358281aed386de7d127e77d660b4e8abd1262b1 Mon Sep 17 00:00:00 2001 From: martin Date: Wed, 18 Jul 2018 16:36:18 +0000 Subject: [PATCH] Debugger: Enhance console output win. Issue #33935 git-svn-id: trunk@58563 - --- .gitattributes | 2 + debugger/pseudoterminaldlg.lfm | 214 +++++++++++- debugger/pseudoterminaldlg.pp | 505 ++++++++++++++++++++++++++-- debugger/test/testconsolescroll.lpi | 53 +++ debugger/test/testconsolescroll.pas | 27 ++ debugger/test/watchconsolesize.pas | 2 + 6 files changed, 766 insertions(+), 37 deletions(-) create mode 100644 debugger/test/testconsolescroll.lpi create mode 100644 debugger/test/testconsolescroll.pas diff --git a/.gitattributes b/.gitattributes index 956403cacf..4996c70517 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/debugger/pseudoterminaldlg.lfm b/debugger/pseudoterminaldlg.lfm index cac83e536d..0f7029b1c3 100644 --- a/debugger/pseudoterminaldlg.lfm +++ b/debugger/pseudoterminaldlg.lfm @@ -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 diff --git a/debugger/pseudoterminaldlg.pp b/debugger/pseudoterminaldlg.pp index 0237543e5c..062e808e62 100644 --- a/debugger/pseudoterminaldlg.pp +++ b/debugger/pseudoterminaldlg.pp @@ -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} diff --git a/debugger/test/testconsolescroll.lpi b/debugger/test/testconsolescroll.lpi new file mode 100644 index 0000000000..ec090e0499 --- /dev/null +++ b/debugger/test/testconsolescroll.lpi @@ -0,0 +1,53 @@ + + + + + + + + + + + + + <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> diff --git a/debugger/test/testconsolescroll.pas b/debugger/test/testconsolescroll.pas new file mode 100644 index 0000000000..182977491d --- /dev/null +++ b/debugger/test/testconsolescroll.pas @@ -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. + diff --git a/debugger/test/watchconsolesize.pas b/debugger/test/watchconsolesize.pas index 305b0f30ff..766384eb08 100644 --- a/debugger/test/watchconsolesize.pas +++ b/debugger/test/watchconsolesize.pas @@ -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