Commit | Line | Data |
---|---|---|
88b9d363 | 1 | # Copyright 2019-2022 Free Software Foundation, Inc. |
c3786b3a TT |
2 | |
3 | # This program is free software; you can redistribute it and/or modify | |
4 | # it under the terms of the GNU General Public License as published by | |
5 | # the Free Software Foundation; either version 3 of the License, or | |
6 | # (at your option) any later version. | |
7 | # | |
8 | # This program is distributed in the hope that it will be useful, | |
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | # GNU General Public License for more details. | |
12 | # | |
13 | # You should have received a copy of the GNU General Public License | |
14 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | |
15 | ||
16 | # An ANSI terminal emulator for expect. | |
17 | ||
18 | namespace eval Term { | |
c3e96aa7 | 19 | # Size of the terminal. |
c3786b3a TT |
20 | variable _rows |
21 | variable _cols | |
c3e96aa7 SM |
22 | |
23 | # Buffer / contents of the terminal. | |
c3786b3a TT |
24 | variable _chars |
25 | ||
c3e96aa7 SM |
26 | # Position of the cursor. |
27 | variable _cur_col | |
28 | variable _cur_row | |
c3786b3a TT |
29 | |
30 | variable _attrs | |
31 | ||
32 | variable _last_char | |
33 | ||
45e42163 TT |
34 | variable _resize_count |
35 | ||
730af663 SM |
36 | proc _log { what } { |
37 | verbose -log "+++ $what" | |
38 | } | |
39 | ||
40 | # Call BODY, then log WHAT along with the original and new cursor position. | |
41 | proc _log_cur { what body } { | |
42 | variable _cur_row | |
43 | variable _cur_col | |
44 | ||
45 | set orig_cur_row $_cur_row | |
46 | set orig_cur_col $_cur_col | |
47 | ||
48 | uplevel $body | |
49 | ||
50 | _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)" | |
51 | } | |
52 | ||
c3786b3a TT |
53 | # If ARG is empty, return DEF: otherwise ARG. This is useful for |
54 | # defaulting arguments in CSIs. | |
55 | proc _default {arg def} { | |
56 | if {$arg == ""} { | |
57 | return $def | |
58 | } | |
59 | return $arg | |
60 | } | |
61 | ||
62 | # Erase in the line Y from SX to just before EX. | |
63 | proc _clear_in_line {sx ex y} { | |
64 | variable _attrs | |
65 | variable _chars | |
66 | set lattr [array get _attrs] | |
67 | while {$sx < $ex} { | |
68 | set _chars($sx,$y) [list " " $lattr] | |
69 | incr sx | |
70 | } | |
71 | } | |
72 | ||
73 | # Erase the lines from SY to just before EY. | |
74 | proc _clear_lines {sy ey} { | |
75 | variable _cols | |
76 | while {$sy < $ey} { | |
77 | _clear_in_line 0 $_cols $sy | |
78 | incr sy | |
79 | } | |
80 | } | |
81 | ||
82 | # Beep. | |
83 | proc _ctl_0x07 {} { | |
84 | } | |
85 | ||
86 | # Backspace. | |
87 | proc _ctl_0x08 {} { | |
730af663 SM |
88 | _log_cur "Backspace" { |
89 | variable _cur_col | |
90 | ||
91 | incr _cur_col -1 | |
92 | if {$_cur_col < 0} { | |
93 | variable _cur_row | |
94 | variable _cols | |
95 | ||
96 | set _cur_col [expr {$_cols - 1}] | |
97 | incr _cur_row -1 | |
98 | if {$_cur_row < 0} { | |
99 | set _cur_row 0 | |
100 | } | |
c3786b3a TT |
101 | } |
102 | } | |
103 | } | |
104 | ||
105 | # Linefeed. | |
106 | proc _ctl_0x0a {} { | |
730af663 SM |
107 | _log_cur "Line feed" { |
108 | variable _cur_row | |
109 | variable _rows | |
110 | ||
111 | incr _cur_row 1 | |
112 | if {$_cur_row >= $_rows} { | |
113 | error "FIXME scroll" | |
114 | } | |
c3786b3a TT |
115 | } |
116 | } | |
117 | ||
118 | # Carriage return. | |
119 | proc _ctl_0x0d {} { | |
730af663 SM |
120 | _log_cur "Carriage return" { |
121 | variable _cur_col | |
122 | ||
123 | set _cur_col 0 | |
124 | } | |
c3786b3a TT |
125 | } |
126 | ||
6571ffc6 SM |
127 | # Insert Character. |
128 | # | |
129 | # https://vt100.net/docs/vt510-rm/ICH.html | |
3d235706 TT |
130 | proc _csi_@ {args} { |
131 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
132 | |
133 | _log_cur "Insert Character ($n)" { | |
134 | variable _cur_col | |
135 | variable _cur_row | |
136 | variable _chars | |
137 | ||
138 | set in_x $_cur_col | |
139 | set out_x [expr {$_cur_col + $n}] | |
140 | for {set i 0} {$i < $n} {incr i} { | |
141 | set _chars($out_x,$_cur_row) $_chars($in_x,$_cur_row) | |
142 | incr in_x | |
143 | incr out_x | |
144 | } | |
3d235706 TT |
145 | } |
146 | } | |
147 | ||
c3786b3a | 148 | # Cursor Up. |
6571ffc6 SM |
149 | # |
150 | # https://vt100.net/docs/vt510-rm/CUU.html | |
c3786b3a | 151 | proc _csi_A {args} { |
c3786b3a | 152 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
153 | |
154 | _log_cur "Cursor Up ($arg)" { | |
155 | variable _cur_row | |
156 | ||
157 | set _cur_row [expr {max ($_cur_row - $arg, 0)}] | |
158 | } | |
c3786b3a TT |
159 | } |
160 | ||
161 | # Cursor Down. | |
6571ffc6 SM |
162 | # |
163 | # https://vt100.net/docs/vt510-rm/CUD.html | |
c3786b3a | 164 | proc _csi_B {args} { |
c3786b3a | 165 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
166 | |
167 | _log_cur "Cursor Down ($arg)" { | |
168 | variable _cur_row | |
169 | variable _rows | |
170 | ||
171 | set _cur_row [expr {min ($_cur_row + $arg, $_rows)}] | |
172 | } | |
c3786b3a TT |
173 | } |
174 | ||
175 | # Cursor Forward. | |
6571ffc6 SM |
176 | # |
177 | # https://vt100.net/docs/vt510-rm/CUF.html | |
c3786b3a | 178 | proc _csi_C {args} { |
c3786b3a | 179 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
180 | |
181 | _log_cur "Cursor Forward ($arg)" { | |
182 | variable _cur_col | |
183 | variable _cols | |
184 | ||
185 | set _cur_col [expr {min ($_cur_col + $arg, $_cols)}] | |
186 | } | |
c3786b3a TT |
187 | } |
188 | ||
6571ffc6 SM |
189 | # Cursor Backward. |
190 | # | |
191 | # https://vt100.net/docs/vt510-rm/CUB.html | |
c3786b3a | 192 | proc _csi_D {args} { |
c3786b3a | 193 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
194 | |
195 | _log_cur "Cursor Backward ($arg)" { | |
196 | variable _cur_col | |
197 | ||
198 | set _cur_col [expr {max ($_cur_col - $arg, 0)}] | |
199 | } | |
c3786b3a TT |
200 | } |
201 | ||
202 | # Cursor Next Line. | |
6571ffc6 SM |
203 | # |
204 | # https://vt100.net/docs/vt510-rm/CNL.html | |
c3786b3a | 205 | proc _csi_E {args} { |
c3786b3a | 206 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
207 | |
208 | _log_cur "Cursor Next Line ($arg)" { | |
209 | variable _cur_col | |
210 | variable _cur_row | |
211 | variable _rows | |
212 | ||
213 | set _cur_col 0 | |
214 | set _cur_row [expr {min ($_cur_row + $arg, $_rows)}] | |
215 | } | |
c3786b3a TT |
216 | } |
217 | ||
218 | # Cursor Previous Line. | |
6571ffc6 SM |
219 | # |
220 | # https://vt100.net/docs/vt510-rm/CPL.html | |
c3786b3a | 221 | proc _csi_F {args} { |
c3786b3a | 222 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
223 | |
224 | _log_cur "Cursor Previous Line ($arg)" { | |
225 | variable _cur_col | |
226 | variable _cur_row | |
227 | variable _rows | |
228 | ||
229 | set _cur_col 0 | |
230 | set _cur_row [expr {max ($_cur_row - $arg, 0)}] | |
231 | } | |
c3786b3a TT |
232 | } |
233 | ||
234 | # Cursor Horizontal Absolute. | |
6571ffc6 SM |
235 | # |
236 | # https://vt100.net/docs/vt510-rm/CHA.html | |
c3786b3a | 237 | proc _csi_G {args} { |
c3786b3a | 238 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
239 | |
240 | _log_cur "Cursor Horizontal Absolute ($arg)" { | |
241 | variable _cur_col | |
242 | variable _cols | |
243 | ||
244 | set _cur_col [expr {min ($arg - 1, $_cols)}] | |
245 | } | |
c3786b3a TT |
246 | } |
247 | ||
6571ffc6 SM |
248 | # Cursor Position. |
249 | # | |
250 | # https://vt100.net/docs/vt510-rm/CUP.html | |
c3786b3a | 251 | proc _csi_H {args} { |
730af663 SM |
252 | set row [_default [lindex $args 0] 1] |
253 | set col [_default [lindex $args 1] 1] | |
254 | ||
255 | _log_cur "Cursor Position ($row, $col)" { | |
256 | variable _cur_col | |
257 | variable _cur_row | |
258 | ||
259 | set _cur_row [expr {$row - 1}] | |
260 | set _cur_col [expr {$col - 1}] | |
261 | } | |
c3786b3a TT |
262 | } |
263 | ||
6571ffc6 SM |
264 | # Cursor Horizontal Forward Tabulation. |
265 | # | |
266 | # https://vt100.net/docs/vt510-rm/CHT.html | |
c3786b3a TT |
267 | proc _csi_I {args} { |
268 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
269 | |
270 | _log_cur "Cursor Horizontal Forward Tabulation ($n)" { | |
271 | variable _cur_col | |
272 | variable _cols | |
273 | ||
274 | incr _cur_col [expr {$n * 8 - $_cur_col % 8}] | |
275 | if {$_cur_col >= $_cols} { | |
276 | set _cur_col [expr {$_cols - 1}] | |
277 | } | |
c3786b3a TT |
278 | } |
279 | } | |
280 | ||
6571ffc6 SM |
281 | # Erase in Display. |
282 | # | |
283 | # https://vt100.net/docs/vt510-rm/ED.html | |
c3786b3a | 284 | proc _csi_J {args} { |
c3786b3a | 285 | set arg [_default [lindex $args 0] 0] |
730af663 SM |
286 | |
287 | _log_cur "Erase in Display ($arg)" { | |
288 | variable _cur_col | |
289 | variable _cur_row | |
290 | variable _rows | |
291 | variable _cols | |
292 | ||
293 | if {$arg == 0} { | |
294 | _clear_in_line $_cur_col $_cols $_cur_row | |
295 | _clear_lines [expr {$_cur_row + 1}] $_rows | |
296 | } elseif {$arg == 1} { | |
297 | _clear_lines 0 [expr {$_cur_row - 1}] | |
298 | _clear_in_line 0 $_cur_col $_cur_row | |
299 | } elseif {$arg == 2} { | |
300 | _clear_lines 0 $_rows | |
301 | } | |
c3786b3a TT |
302 | } |
303 | } | |
304 | ||
6571ffc6 SM |
305 | # Erase in Line. |
306 | # | |
307 | # https://vt100.net/docs/vt510-rm/EL.html | |
c3786b3a | 308 | proc _csi_K {args} { |
c3786b3a | 309 | set arg [_default [lindex $args 0] 0] |
730af663 SM |
310 | |
311 | _log_cur "Erase in Line ($arg)" { | |
312 | variable _cur_col | |
313 | variable _cur_row | |
314 | variable _cols | |
315 | ||
316 | if {$arg == 0} { | |
317 | # From cursor to end. | |
318 | _clear_in_line $_cur_col $_cols $_cur_row | |
319 | } elseif {$arg == 1} { | |
320 | _clear_in_line 0 $_cur_col $_cur_row | |
321 | } elseif {$arg == 2} { | |
322 | _clear_in_line 0 $_cols $_cur_row | |
323 | } | |
c3786b3a TT |
324 | } |
325 | } | |
326 | ||
6571ffc6 SM |
327 | # Delete line. |
328 | # | |
329 | # https://vt100.net/docs/vt510-rm/DL.html | |
c3786b3a | 330 | proc _csi_M {args} { |
c3786b3a | 331 | set count [_default [lindex $args 0] 1] |
730af663 SM |
332 | |
333 | _log_cur "Delete line ($count)" { | |
334 | variable _cur_row | |
335 | variable _rows | |
336 | variable _cols | |
337 | variable _chars | |
338 | ||
339 | set y $_cur_row | |
5fb97639 AB |
340 | set next_y [expr {$y + $count}] |
341 | while {$next_y < $_rows} { | |
730af663 SM |
342 | for {set x 0} {$x < $_cols} {incr x} { |
343 | set _chars($x,$y) $_chars($x,$next_y) | |
344 | } | |
345 | incr y | |
346 | incr next_y | |
c3786b3a | 347 | } |
5fb97639 | 348 | _clear_lines $y $_rows |
c3786b3a | 349 | } |
c3786b3a TT |
350 | } |
351 | ||
352 | # Erase chars. | |
6571ffc6 SM |
353 | # |
354 | # https://vt100.net/docs/vt510-rm/ECH.html | |
c3786b3a TT |
355 | proc _csi_X {args} { |
356 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
357 | |
358 | _log_cur "Erase chars ($n)" { | |
359 | # Erase characters but don't move cursor. | |
360 | variable _cur_col | |
361 | variable _cur_row | |
362 | variable _attrs | |
363 | variable _chars | |
364 | ||
365 | set lattr [array get _attrs] | |
366 | set x $_cur_col | |
367 | for {set i 0} {$i < $n} {incr i} { | |
368 | set _chars($x,$_cur_row) [list " " $lattr] | |
369 | incr x | |
370 | } | |
3d235706 | 371 | } |
c3786b3a TT |
372 | } |
373 | ||
6571ffc6 SM |
374 | # Cursor Backward Tabulation. |
375 | # | |
376 | # https://vt100.net/docs/vt510-rm/CBT.html | |
398fdd60 TT |
377 | proc _csi_Z {args} { |
378 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
379 | |
380 | _log_cur "Cursor Backward Tabulation ($n)" { | |
381 | variable _cur_col | |
382 | ||
383 | set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}] | |
384 | } | |
398fdd60 TT |
385 | } |
386 | ||
c3786b3a | 387 | # Repeat. |
6571ffc6 SM |
388 | # |
389 | # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`) | |
c3786b3a | 390 | proc _csi_b {args} { |
c3786b3a | 391 | set n [_default [lindex $args 0] 1] |
730af663 SM |
392 | |
393 | _log_cur "Repeat ($n)" { | |
394 | variable _last_char | |
395 | ||
396 | _insert [string repeat $_last_char $n] | |
397 | } | |
c3786b3a TT |
398 | } |
399 | ||
6571ffc6 SM |
400 | # Vertical Line Position Absolute. |
401 | # | |
402 | # https://vt100.net/docs/vt510-rm/VPA.html | |
c3786b3a | 403 | proc _csi_d {args} { |
730af663 SM |
404 | set row [_default [lindex $args 0] 1] |
405 | ||
406 | _log_cur "Vertical Line Position Absolute ($row)" { | |
407 | variable _cur_row | |
408 | ||
409 | set _cur_row [expr {$row - 1}] | |
410 | } | |
c3786b3a TT |
411 | } |
412 | ||
413 | # Select Graphic Rendition. | |
6571ffc6 SM |
414 | # |
415 | # https://vt100.net/docs/vt510-rm/SGR.html | |
c3786b3a | 416 | proc _csi_m {args} { |
730af663 SM |
417 | _log_cur "Select Graphic Rendition ([join $args {, }])" { |
418 | variable _attrs | |
419 | ||
420 | foreach item $args { | |
421 | switch -exact -- $item { | |
422 | "" - 0 { | |
423 | set _attrs(intensity) normal | |
424 | set _attrs(fg) default | |
425 | set _attrs(bg) default | |
426 | set _attrs(underline) 0 | |
427 | set _attrs(reverse) 0 | |
428 | } | |
429 | 1 { | |
430 | set _attrs(intensity) bold | |
431 | } | |
432 | 2 { | |
433 | set _attrs(intensity) dim | |
434 | } | |
435 | 4 { | |
436 | set _attrs(underline) 1 | |
437 | } | |
438 | 7 { | |
439 | set _attrs(reverse) 1 | |
440 | } | |
441 | 22 { | |
442 | set _attrs(intensity) normal | |
443 | } | |
444 | 24 { | |
445 | set _attrs(underline) 0 | |
446 | } | |
447 | 27 { | |
448 | set _attrs(reverse) 1 | |
449 | } | |
450 | 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { | |
451 | set _attrs(fg) $item | |
452 | } | |
453 | 39 { | |
454 | set _attrs(fg) default | |
455 | } | |
456 | 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { | |
457 | set _attrs(bg) $item | |
458 | } | |
459 | 49 { | |
460 | set _attrs(bg) default | |
461 | } | |
462 | } | |
463 | } | |
c3786b3a TT |
464 | } |
465 | } | |
466 | ||
467 | # Insert string at the cursor location. | |
468 | proc _insert {str} { | |
730af663 SM |
469 | _log_cur "Inserted string '$str'" { |
470 | _log "Inserting string '$str'" | |
471 | ||
472 | variable _cur_col | |
473 | variable _cur_row | |
474 | variable _rows | |
475 | variable _cols | |
476 | variable _attrs | |
477 | variable _chars | |
478 | set lattr [array get _attrs] | |
479 | foreach char [split $str {}] { | |
480 | _log_cur " Inserted char '$char'" { | |
481 | set _chars($_cur_col,$_cur_row) [list $char $lattr] | |
482 | incr _cur_col | |
483 | if {$_cur_col >= $_cols} { | |
484 | set _cur_col 0 | |
485 | incr _cur_row | |
486 | if {$_cur_row >= $_rows} { | |
487 | error "FIXME scroll" | |
488 | } | |
489 | } | |
c3786b3a TT |
490 | } |
491 | } | |
492 | } | |
493 | } | |
494 | ||
495 | # Initialize. | |
496 | proc _setup {rows cols} { | |
497 | global stty_init | |
498 | set stty_init "rows $rows columns $cols" | |
499 | ||
500 | variable _rows | |
501 | variable _cols | |
c3e96aa7 SM |
502 | variable _cur_col |
503 | variable _cur_row | |
c3786b3a | 504 | variable _attrs |
45e42163 | 505 | variable _resize_count |
c3786b3a TT |
506 | |
507 | set _rows $rows | |
508 | set _cols $cols | |
c3e96aa7 SM |
509 | set _cur_col 0 |
510 | set _cur_row 0 | |
45e42163 | 511 | set _resize_count 0 |
c3786b3a TT |
512 | array set _attrs { |
513 | intensity normal | |
514 | fg default | |
515 | bg default | |
516 | underline 0 | |
517 | reverse 0 | |
518 | } | |
519 | ||
520 | _clear_lines 0 $_rows | |
521 | } | |
522 | ||
9ae6bf64 TT |
523 | # Accept some output from gdb and update the screen. WAIT_FOR is |
524 | # a regexp matching the line to wait for. Return 0 on timeout, 1 | |
525 | # on success. | |
526 | proc wait_for {wait_for} { | |
c3786b3a | 527 | global expect_out |
45e42163 | 528 | global gdb_prompt |
c3e96aa7 SM |
529 | variable _cur_col |
530 | variable _cur_row | |
45e42163 TT |
531 | |
532 | set prompt_wait_for "$gdb_prompt \$" | |
533 | ||
534 | while 1 { | |
535 | gdb_expect { | |
536 | -re "^\[\x07\x08\x0a\x0d\]" { | |
537 | scan $expect_out(0,string) %c val | |
538 | set hexval [format "%02x" $val] | |
730af663 | 539 | _log "wait_for: _ctl_0x${hexval}" |
45e42163 TT |
540 | _ctl_0x${hexval} |
541 | } | |
542 | -re "^\x1b(\[0-9a-zA-Z\])" { | |
730af663 | 543 | _log "wait_for: unsupported escape" |
45e42163 TT |
544 | error "unsupported escape" |
545 | } | |
546 | -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" { | |
547 | set cmd $expect_out(2,string) | |
548 | set params [split $expect_out(1,string) ";"] | |
730af663 | 549 | _log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>" |
45e42163 TT |
550 | eval _csi_$cmd $params |
551 | } | |
552 | -re "^\[^\x07\x08\x0a\x0d\x1b\]+" { | |
553 | _insert $expect_out(0,string) | |
554 | variable _last_char | |
555 | set _last_char [string index $expect_out(0,string) end] | |
556 | } | |
557 | ||
558 | timeout { | |
559 | # Assume a timeout means we somehow missed the | |
560 | # expected result, and carry on. | |
9ae6bf64 | 561 | return 0 |
45e42163 | 562 | } |
c3786b3a | 563 | } |
45e42163 TT |
564 | |
565 | # If the cursor appears just after the prompt, return. It | |
566 | # isn't reliable to check this only after an insertion, | |
567 | # because curses may make "unusual" redrawing decisions. | |
568 | if {$wait_for == "$prompt_wait_for"} { | |
c3e96aa7 | 569 | set prev [get_line $_cur_row $_cur_col] |
45e42163 | 570 | } else { |
c3e96aa7 | 571 | set prev [get_line $_cur_row] |
45e42163 TT |
572 | } |
573 | if {[regexp -- $wait_for $prev]} { | |
574 | if {$wait_for == "$prompt_wait_for"} { | |
575 | break | |
c3786b3a | 576 | } |
45e42163 | 577 | set wait_for $prompt_wait_for |
c3786b3a TT |
578 | } |
579 | } | |
9ae6bf64 TT |
580 | |
581 | return 1 | |
c3786b3a TT |
582 | } |
583 | ||
584 | # Like ::clean_restart, but ensures that gdb starts in an | |
585 | # environment where the TUI can work. ROWS and COLS are the size | |
2b1d00c2 TT |
586 | # of the terminal. EXECUTABLE, if given, is passed to |
587 | # clean_restart. | |
588 | proc clean_restart {rows cols {executable {}}} { | |
c3786b3a TT |
589 | global env stty_init |
590 | save_vars {env(TERM) stty_init} { | |
591 | setenv TERM ansi | |
592 | _setup $rows $cols | |
2b1d00c2 TT |
593 | if {$executable == ""} { |
594 | ::clean_restart | |
595 | } else { | |
596 | ::clean_restart $executable | |
597 | } | |
c3786b3a TT |
598 | } |
599 | } | |
600 | ||
b40aa28f AB |
601 | # Setup ready for starting the tui, but don't actually start it. |
602 | # Returns 1 on success, 0 if TUI tests should be skipped. | |
603 | proc prepare_for_tui {} { | |
c3786b3a TT |
604 | if {[skip_tui_tests]} { |
605 | return 0 | |
606 | } | |
607 | ||
608 | gdb_test_no_output "set tui border-kind ascii" | |
45e42163 | 609 | gdb_test_no_output "maint set tui-resize-message on" |
b40aa28f AB |
610 | return 1 |
611 | } | |
612 | ||
613 | # Start the TUI. Returns 1 on success, 0 if TUI tests should be | |
614 | # skipped. | |
615 | proc enter_tui {} { | |
616 | if {![prepare_for_tui]} { | |
617 | return 0 | |
618 | } | |
619 | ||
301b21e0 | 620 | command_no_prompt_prefix "tui enable" |
c3786b3a TT |
621 | return 1 |
622 | } | |
623 | ||
624 | # Send the command CMD to gdb, then wait for a gdb prompt to be | |
625 | # seen in the TUI. CMD should not end with a newline -- that will | |
626 | # be supplied by this function. | |
627 | proc command {cmd} { | |
301b21e0 TV |
628 | global gdb_prompt |
629 | send_gdb "$cmd\n" | |
630 | set str [string_to_regexp $cmd] | |
631 | set str "^$gdb_prompt $str" | |
632 | wait_for $str | |
633 | } | |
634 | ||
635 | # As proc command, but don't wait for a initial prompt. This is used for | |
636 | # inital terminal commands, where there's no prompt yet. | |
637 | proc command_no_prompt_prefix {cmd} { | |
c3786b3a | 638 | send_gdb "$cmd\n" |
301b21e0 TV |
639 | set str [string_to_regexp $cmd] |
640 | wait_for "^$str" | |
c3786b3a TT |
641 | } |
642 | ||
643 | # Return the text of screen line N, without attributes. Lines are | |
644 | # 0-based. If C is given, stop before column C. Columns are also | |
645 | # zero-based. | |
646 | proc get_line {n {c ""}} { | |
45e42163 TT |
647 | variable _rows |
648 | # This can happen during resizing, if the cursor seems to | |
649 | # temporarily be off-screen. | |
650 | if {$n >= $_rows} { | |
651 | return "" | |
652 | } | |
653 | ||
c3786b3a TT |
654 | set result "" |
655 | variable _cols | |
656 | variable _chars | |
657 | set c [_default $c $_cols] | |
658 | set x 0 | |
659 | while {$x < $c} { | |
660 | append result [lindex $_chars($x,$n) 0] | |
661 | incr x | |
662 | } | |
663 | return $result | |
664 | } | |
665 | ||
666 | # Get just the character at (X, Y). | |
667 | proc get_char {x y} { | |
668 | variable _chars | |
669 | return [lindex $_chars($x,$y) 0] | |
670 | } | |
671 | ||
672 | # Get the entire screen as a string. | |
673 | proc get_all_lines {} { | |
674 | variable _rows | |
675 | variable _cols | |
676 | variable _chars | |
677 | ||
678 | set result "" | |
679 | for {set y 0} {$y < $_rows} {incr y} { | |
680 | for {set x 0} {$x < $_cols} {incr x} { | |
681 | append result [lindex $_chars($x,$y) 0] | |
682 | } | |
683 | append result "\n" | |
684 | } | |
685 | ||
686 | return $result | |
687 | } | |
688 | ||
689 | # Get the text just before the cursor. | |
690 | proc get_current_line {} { | |
c3e96aa7 SM |
691 | variable _cur_col |
692 | variable _cur_row | |
693 | return [get_line $_cur_row $_cur_col] | |
c3786b3a TT |
694 | } |
695 | ||
696 | # Helper function for check_box. Returns empty string if the box | |
697 | # is found, description of why not otherwise. | |
698 | proc _check_box {x y width height} { | |
699 | set x2 [expr {$x + $width - 1}] | |
700 | set y2 [expr {$y + $height - 1}] | |
701 | ||
d0a3c757 SM |
702 | verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height" |
703 | ||
704 | set c [get_char $x $y] | |
705 | if {$c != "+"} { | |
706 | return "ul corner is $c, not +" | |
c3786b3a | 707 | } |
d0a3c757 SM |
708 | |
709 | set c [get_char $x $y2] | |
710 | if {$c != "+"} { | |
711 | return "ll corner is $c, not +" | |
c3786b3a | 712 | } |
d0a3c757 SM |
713 | |
714 | set c [get_char $x2 $y] | |
715 | if {$c != "+"} { | |
716 | return "ur corner is $c, not +" | |
c3786b3a | 717 | } |
d0a3c757 SM |
718 | |
719 | set c [get_char $x2 $y2] | |
720 | if {$c != "+"} { | |
721 | return "lr corner is $c, not +" | |
c3786b3a TT |
722 | } |
723 | ||
9a6d629c AB |
724 | # Note we do not check the full horizonal borders of the box. |
725 | # The top will contain a title, and the bottom may as well, if | |
726 | # it is overlapped by some other border. However, at most a | |
727 | # title should appear as '+-VERY LONG TITLE-+', so we can | |
728 | # check for the '+-' on the left, and '-+' on the right. | |
d0a3c757 SM |
729 | set c [get_char [expr {$x + 1}] $y] |
730 | if {$c != "-"} { | |
731 | return "ul title padding is $c, not -" | |
9a6d629c AB |
732 | } |
733 | ||
d0a3c757 SM |
734 | set c [get_char [expr {$x2 - 1}] $y] |
735 | if {$c != "-"} { | |
736 | return "ul title padding is $c, not -" | |
9a6d629c AB |
737 | } |
738 | ||
739 | # Now check the vertical borders. | |
c3786b3a | 740 | for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} { |
d0a3c757 SM |
741 | set c [get_char $x $i] |
742 | if {$c != "|"} { | |
743 | return "left side $i is $c, not |" | |
c3786b3a | 744 | } |
d0a3c757 SM |
745 | |
746 | set c [get_char $x2 $i] | |
747 | if {$c != "|"} { | |
748 | return "right side $i is $c, not |" | |
c3786b3a TT |
749 | } |
750 | } | |
751 | ||
752 | return "" | |
753 | } | |
754 | ||
755 | # Check for a box at the given coordinates. | |
756 | proc check_box {test_name x y width height} { | |
757 | set why [_check_box $x $y $width $height] | |
758 | if {$why == ""} { | |
759 | pass $test_name | |
760 | } else { | |
761 | dump_screen | |
762 | fail "$test_name ($why)" | |
763 | } | |
764 | } | |
765 | ||
766 | # Check whether the text contents of the terminal match the | |
767 | # regular expression. Note that text styling is not considered. | |
768 | proc check_contents {test_name regexp} { | |
769 | set contents [get_all_lines] | |
770 | if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} { | |
771 | dump_screen | |
772 | } | |
773 | } | |
774 | ||
5fb97639 AB |
775 | # Check that the region of the screen described by X, Y, WIDTH, |
776 | # and HEIGHT match REGEXP. This is like check_contents except | |
777 | # only part of the screen is checked. This can be used to check | |
778 | # the contents within a box (though check_box_contents is a better | |
779 | # choice for boxes with a border). | |
780 | proc check_region_contents { test_name x y width height regexp } { | |
781 | variable _chars | |
782 | ||
783 | # Now grab the contents of the box, join each line together | |
784 | # with a '\r\n' sequence and match against REGEXP. | |
785 | set result "" | |
786 | for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} { | |
787 | if {$yy > $y} { | |
788 | # Add the end of line sequence only if this isn't the | |
789 | # first line. | |
790 | append result "\r\n" | |
791 | } | |
792 | for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} { | |
793 | append result [lindex $_chars($xx,$yy) 0] | |
794 | } | |
795 | } | |
796 | ||
797 | if {![gdb_assert {[regexp -- $regexp $result]} $test_name]} { | |
798 | dump_screen | |
799 | } | |
800 | } | |
801 | ||
3804da7e AB |
802 | # Check the contents of a box on the screen. This is a little |
803 | # like check_contents, but doens't check the whole screen | |
804 | # contents, only the contents of a single box. This procedure | |
805 | # includes (effectively) a call to check_box to ensure there is a | |
806 | # box where expected, if there is then the contents of the box are | |
807 | # matched against REGEXP. | |
808 | proc check_box_contents {test_name x y width height regexp} { | |
809 | variable _chars | |
810 | ||
811 | set why [_check_box $x $y $width $height] | |
812 | if {$why != ""} { | |
813 | dump_screen | |
814 | fail "$test_name (box check: $why)" | |
815 | return | |
816 | } | |
817 | ||
5fb97639 AB |
818 | check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \ |
819 | [expr {$width - 2}] [expr {$height - 2}] $regexp | |
3804da7e AB |
820 | } |
821 | ||
c3786b3a TT |
822 | # A debugging function to dump the current screen, with line |
823 | # numbers. | |
824 | proc dump_screen {} { | |
825 | variable _rows | |
45e42163 | 826 | variable _cols |
63ffd7c9 | 827 | verbose -log "Screen Dump ($_cols x $_rows):" |
c3786b3a TT |
828 | for {set y 0} {$y < $_rows} {incr y} { |
829 | set fmt [format %5d $y] | |
63ffd7c9 | 830 | verbose -log "$fmt [get_line $y]" |
c3786b3a TT |
831 | } |
832 | } | |
ded631d5 TT |
833 | |
834 | # Resize the terminal. | |
45e42163 | 835 | proc _do_resize {rows cols} { |
ded631d5 TT |
836 | variable _chars |
837 | variable _rows | |
838 | variable _cols | |
839 | ||
840 | set old_rows [expr {min ($_rows, $rows)}] | |
841 | set old_cols [expr {min ($_cols, $cols)}] | |
842 | ||
843 | # Copy locally. | |
844 | array set local_chars [array get _chars] | |
845 | unset _chars | |
846 | ||
847 | set _rows $rows | |
848 | set _cols $cols | |
849 | _clear_lines 0 $_rows | |
850 | ||
851 | for {set x 0} {$x < $old_cols} {incr x} { | |
852 | for {set y 0} {$y < $old_rows} {incr y} { | |
853 | set _chars($x,$y) $local_chars($x,$y) | |
854 | } | |
855 | } | |
45e42163 TT |
856 | } |
857 | ||
858 | proc resize {rows cols} { | |
859 | variable _rows | |
860 | variable _cols | |
861 | variable _resize_count | |
ded631d5 | 862 | |
45e42163 TT |
863 | # expect handles each argument to stty separately. This means |
864 | # that gdb will see SIGWINCH twice. Rather than rely on this | |
865 | # behavior (which, after all, could be changed), we make it | |
866 | # explicit here. This also simplifies waiting for the redraw. | |
867 | _do_resize $rows $_cols | |
9edb1e01 | 868 | stty rows $_rows < $::gdb_tty_name |
45e42163 TT |
869 | # Due to the strange column resizing behavior, and because we |
870 | # don't care about this intermediate resize, we don't check | |
871 | # the size here. | |
9ae6bf64 | 872 | wait_for "@@ resize done $_resize_count" |
45e42163 | 873 | incr _resize_count |
ded631d5 TT |
874 | # Somehow the number of columns transmitted to gdb is one less |
875 | # than what we request from expect. We hide this weird | |
876 | # details from the caller. | |
45e42163 | 877 | _do_resize $_rows $cols |
9edb1e01 | 878 | stty columns [expr {$_cols + 1}] < $::gdb_tty_name |
9ae6bf64 | 879 | wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" |
45e42163 | 880 | incr _resize_count |
ded631d5 | 881 | } |
c3786b3a | 882 | } |