Commit | Line | Data |
---|---|---|
c3786b3a TT |
1 | # Copyright 2019 Free Software Foundation, Inc. |
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 { | |
19 | variable _rows | |
20 | variable _cols | |
21 | variable _chars | |
22 | ||
23 | variable _cur_x | |
24 | variable _cur_y | |
25 | ||
26 | variable _attrs | |
27 | ||
28 | variable _last_char | |
29 | ||
30 | # If ARG is empty, return DEF: otherwise ARG. This is useful for | |
31 | # defaulting arguments in CSIs. | |
32 | proc _default {arg def} { | |
33 | if {$arg == ""} { | |
34 | return $def | |
35 | } | |
36 | return $arg | |
37 | } | |
38 | ||
39 | # Erase in the line Y from SX to just before EX. | |
40 | proc _clear_in_line {sx ex y} { | |
41 | variable _attrs | |
42 | variable _chars | |
43 | set lattr [array get _attrs] | |
44 | while {$sx < $ex} { | |
45 | set _chars($sx,$y) [list " " $lattr] | |
46 | incr sx | |
47 | } | |
48 | } | |
49 | ||
50 | # Erase the lines from SY to just before EY. | |
51 | proc _clear_lines {sy ey} { | |
52 | variable _cols | |
53 | while {$sy < $ey} { | |
54 | _clear_in_line 0 $_cols $sy | |
55 | incr sy | |
56 | } | |
57 | } | |
58 | ||
59 | # Beep. | |
60 | proc _ctl_0x07 {} { | |
61 | } | |
62 | ||
63 | # Backspace. | |
64 | proc _ctl_0x08 {} { | |
65 | variable _cur_x | |
66 | incr _cur_x -1 | |
67 | if {$_cur_x < 0} { | |
68 | variable _cur_y | |
69 | variable _cols | |
70 | set _cur_x [expr {$_cols - 1}] | |
71 | incr _cur_y -1 | |
72 | if {$_cur_y < 0} { | |
73 | set _cur_y 0 | |
74 | } | |
75 | } | |
76 | } | |
77 | ||
78 | # Linefeed. | |
79 | proc _ctl_0x0a {} { | |
80 | variable _cur_y | |
81 | variable _rows | |
82 | incr _cur_y 1 | |
83 | if {$_cur_y >= $_rows} { | |
84 | error "FIXME scroll" | |
85 | } | |
86 | } | |
87 | ||
88 | # Carriage return. | |
89 | proc _ctl_0x0d {} { | |
90 | variable _cur_x | |
91 | set _cur_x 0 | |
92 | } | |
93 | ||
94 | # Cursor Up. | |
95 | proc _csi_A {args} { | |
96 | variable _cur_y | |
97 | set arg [_default [lindex $args 0] 1] | |
98 | set _cur_y [expr {max ($_cur_y - $arg, 0)}] | |
99 | } | |
100 | ||
101 | # Cursor Down. | |
102 | proc _csi_B {args} { | |
103 | variable _cur_y | |
104 | variable _rows | |
105 | set arg [_default [lindex $args 0] 1] | |
106 | set _cur_y [expr {min ($_cur_y + $arg, $_rows)}] | |
107 | } | |
108 | ||
109 | # Cursor Forward. | |
110 | proc _csi_C {args} { | |
111 | variable _cur_x | |
112 | variable _cols | |
113 | set arg [_default [lindex $args 0] 1] | |
114 | set _cur_x [expr {min ($_cur_x + $arg, $_cols)}] | |
115 | } | |
116 | ||
117 | # Cursor Back. | |
118 | proc _csi_D {args} { | |
119 | variable _cur_x | |
120 | set arg [_default [lindex $args 0] 1] | |
121 | set _cur_x [expr {max ($_cur_x - $arg, 0)}] | |
122 | } | |
123 | ||
124 | # Cursor Next Line. | |
125 | proc _csi_E {args} { | |
126 | variable _cur_x | |
127 | variable _cur_y | |
128 | variable _rows | |
129 | set arg [_default [lindex $args 0] 1] | |
130 | set _cur_x 0 | |
131 | set _cur_y [expr {min ($_cur_y + $arg, $_rows)}] | |
132 | } | |
133 | ||
134 | # Cursor Previous Line. | |
135 | proc _csi_F {args} { | |
136 | variable _cur_x | |
137 | variable _cur_y | |
138 | variable _rows | |
139 | set arg [_default [lindex $args 0] 1] | |
140 | set _cur_x 0 | |
141 | set _cur_y [expr {max ($_cur_y - $arg, 0)}] | |
142 | } | |
143 | ||
144 | # Cursor Horizontal Absolute. | |
145 | proc _csi_G {args} { | |
146 | variable _cur_x | |
147 | variable _cols | |
148 | set arg [_default [lindex $args 0] 1] | |
149 | set _cur_x [expr {min ($arg - 1, $_cols)}] | |
150 | } | |
151 | ||
152 | # Move cursor (don't know the official name of this one). | |
153 | proc _csi_H {args} { | |
154 | variable _cur_x | |
155 | variable _cur_y | |
156 | set _cur_y [expr {[_default [lindex $args 0] 1] - 1}] | |
157 | set _cur_x [expr {[_default [lindex $args 1] 1] - 1}] | |
158 | } | |
159 | ||
160 | # Cursor Forward Tabulation. | |
161 | proc _csi_I {args} { | |
162 | set n [_default [lindex $args 0] 1] | |
163 | variable _cur_x | |
164 | variable _cols | |
165 | incr _cur_x [expr {$n * 8 - $_cur_x % 8}] | |
166 | if {$_cur_x >= $_cols} { | |
167 | set _cur_x [expr {$_cols - 1}] | |
168 | } | |
169 | } | |
170 | ||
171 | # Erase. | |
172 | proc _csi_J {args} { | |
173 | variable _cur_x | |
174 | variable _cur_y | |
175 | variable _rows | |
176 | variable _cols | |
177 | set arg [_default [lindex $args 0] 0] | |
178 | if {$arg == 0} { | |
179 | _clear_in_line $_cur_x $_cols $_cur_y | |
180 | _clear_lines [expr {$_cur_y + 1}] $_rows | |
181 | } elseif {$arg == 1} { | |
182 | _clear_lines 0 [expr {$_cur_y - 1}] | |
183 | _clear_in_line 0 $_cur_x $_cur_y | |
184 | } elseif {$arg == 2} { | |
185 | _clear_lines 0 $_rows | |
186 | } | |
187 | } | |
188 | ||
189 | # Erase Line. | |
190 | proc _csi_K {args} { | |
191 | variable _cur_x | |
192 | variable _cur_y | |
193 | variable _cols | |
194 | set arg [_default [lindex $args 0] 0] | |
195 | if {$arg == 0} { | |
196 | # From cursor to end. | |
197 | _clear_in_line $_cur_x $_cols $_cur_y | |
198 | } elseif {$arg == 1} { | |
199 | _clear_in_line 0 $_cur_x $_cur_y | |
200 | } elseif {$arg == 2} { | |
201 | _clear_in_line 0 $_cols $_cur_y | |
202 | } | |
203 | } | |
204 | ||
205 | # Delete lines. | |
206 | proc _csi_M {args} { | |
207 | variable _cur_y | |
208 | variable _rows | |
209 | variable _cols | |
210 | variable _chars | |
211 | set count [_default [lindex $args 0] 1] | |
212 | set y $_cur_y | |
213 | set next_y [expr {$y + 1}] | |
214 | while {$count > 0 && $next_y < $_rows} { | |
215 | for {set x 0} {$x < $_cols} {incr x} { | |
216 | set _chars($x,$y) $_chars($x,$next_y) | |
217 | } | |
218 | incr y | |
219 | incr next_y | |
220 | incr count -1 | |
221 | } | |
222 | _clear_lines $next_y $_rows | |
223 | } | |
224 | ||
225 | # Erase chars. | |
226 | proc _csi_X {args} { | |
227 | set n [_default [lindex $args 0] 1] | |
228 | _insert [string repeat " " $n] | |
229 | } | |
230 | ||
231 | # Repeat. | |
232 | proc _csi_b {args} { | |
233 | variable _last_char | |
234 | set n [_default [lindex $args 0] 1] | |
235 | _insert [string repeat $_last_char $n] | |
236 | } | |
237 | ||
238 | # Line Position Absolute. | |
239 | proc _csi_d {args} { | |
240 | variable _cur_y | |
241 | set _cur_y [expr {[_default [lindex $args 0] 1] - 1}] | |
242 | } | |
243 | ||
244 | # Select Graphic Rendition. | |
245 | proc _csi_m {args} { | |
246 | variable _attrs | |
247 | foreach item $args { | |
248 | switch -exact -- $item { | |
249 | "" - 0 { | |
250 | set _attrs(intensity) normal | |
251 | set _attrs(fg) default | |
252 | set _attrs(bg) default | |
253 | set _attrs(underline) 0 | |
254 | set _attrs(reverse) 0 | |
255 | } | |
256 | 1 { | |
257 | set _attrs(intensity) bold | |
258 | } | |
259 | 2 { | |
260 | set _attrs(intensity) dim | |
261 | } | |
262 | 4 { | |
263 | set _attrs(underline) 1 | |
264 | } | |
265 | 7 { | |
266 | set _attrs(reverse) 1 | |
267 | } | |
268 | 22 { | |
269 | set _attrs(intensity) normal | |
270 | } | |
271 | 24 { | |
272 | set _attrs(underline) 0 | |
273 | } | |
274 | 27 { | |
275 | set _attrs(reverse) 1 | |
276 | } | |
277 | 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { | |
278 | set _attrs(fg) $item | |
279 | } | |
280 | 39 { | |
281 | set _attrs(fg) default | |
282 | } | |
283 | 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { | |
284 | set _attrs(bg) $item | |
285 | } | |
286 | 49 { | |
287 | set _attrs(bg) default | |
288 | } | |
289 | } | |
290 | } | |
291 | } | |
292 | ||
293 | # Insert string at the cursor location. | |
294 | proc _insert {str} { | |
295 | verbose "INSERT <<$str>>" | |
296 | variable _cur_x | |
297 | variable _cur_y | |
298 | variable _rows | |
299 | variable _cols | |
300 | variable _attrs | |
301 | variable _chars | |
302 | set lattr [array get _attrs] | |
303 | foreach char [split $str {}] { | |
304 | set _chars($_cur_x,$_cur_y) [list $char $lattr] | |
305 | incr _cur_x | |
306 | if {$_cur_x >= $_cols} { | |
307 | set _cur_x 0 | |
308 | incr _cur_y | |
309 | if {$_cur_y >= $_rows} { | |
310 | error "FIXME scroll" | |
311 | } | |
312 | } | |
313 | } | |
314 | } | |
315 | ||
316 | # Initialize. | |
317 | proc _setup {rows cols} { | |
318 | global stty_init | |
319 | set stty_init "rows $rows columns $cols" | |
320 | ||
321 | variable _rows | |
322 | variable _cols | |
323 | variable _cur_x | |
324 | variable _cur_y | |
325 | variable _attrs | |
326 | ||
327 | set _rows $rows | |
328 | set _cols $cols | |
329 | set _cur_x 0 | |
330 | set _cur_y 0 | |
331 | array set _attrs { | |
332 | intensity normal | |
333 | fg default | |
334 | bg default | |
335 | underline 0 | |
336 | reverse 0 | |
337 | } | |
338 | ||
339 | _clear_lines 0 $_rows | |
340 | } | |
341 | ||
342 | # Accept some output from gdb and update the screen. | |
343 | proc _accept {} { | |
344 | global expect_out | |
345 | gdb_expect { | |
346 | -re "^\[\x07\x08\x0a\x0d\]" { | |
347 | scan $expect_out(0,string) %c val | |
348 | set hexval [format "%02x" $val] | |
349 | verbose "+++ _ctl_0x${hexval}" | |
350 | _ctl_0x${hexval} | |
351 | exp_continue | |
352 | } | |
353 | -re "^\x1b(\[0-9a-zA-Z\])" { | |
354 | verbose "+++ unsupported escape" | |
355 | error "unsupported escape" | |
356 | } | |
357 | -re "^\x1b\\\[(\[0-9;\]*)(\[0-9a-zA-Z@\])" { | |
358 | set cmd $expect_out(2,string) | |
359 | set params [split $expect_out(1,string) ";"] | |
360 | verbose "+++ _csi_$cmd <<<$expect_out(1,string)>>>" | |
361 | eval _csi_$cmd $params | |
362 | exp_continue | |
363 | } | |
364 | -re "^\[^\x07\x08\x0a\x0d\x1b\]+" { | |
365 | _insert $expect_out(0,string) | |
366 | variable _last_char | |
367 | set _last_char [string index $expect_out(0,string) end] | |
368 | # If the prompt was just inserted, return. | |
369 | variable _cur_x | |
370 | variable _cur_y | |
371 | global gdb_prompt | |
372 | set prev [get_line $_cur_y $_cur_x] | |
373 | if {![regexp -- "$gdb_prompt \$" $prev]} { | |
374 | exp_continue | |
375 | } | |
376 | } | |
377 | } | |
378 | } | |
379 | ||
380 | # Like ::clean_restart, but ensures that gdb starts in an | |
381 | # environment where the TUI can work. ROWS and COLS are the size | |
382 | # of the terminal. EXECUTABLE is passed to clean_restart. | |
383 | proc clean_restart {rows cols executable} { | |
384 | global env stty_init | |
385 | save_vars {env(TERM) stty_init} { | |
386 | setenv TERM ansi | |
387 | _setup $rows $cols | |
388 | ::clean_restart $executable | |
389 | } | |
390 | } | |
391 | ||
392 | # Start the TUI. Returns 1 on success, 0 if TUI tests should be | |
393 | # skipped. | |
394 | proc enter_tui {} { | |
395 | if {[skip_tui_tests]} { | |
396 | return 0 | |
397 | } | |
398 | ||
399 | gdb_test_no_output "set tui border-kind ascii" | |
400 | command "tui enable" | |
401 | return 1 | |
402 | } | |
403 | ||
404 | # Send the command CMD to gdb, then wait for a gdb prompt to be | |
405 | # seen in the TUI. CMD should not end with a newline -- that will | |
406 | # be supplied by this function. | |
407 | proc command {cmd} { | |
408 | send_gdb "$cmd\n" | |
409 | _accept | |
410 | } | |
411 | ||
412 | # Return the text of screen line N, without attributes. Lines are | |
413 | # 0-based. If C is given, stop before column C. Columns are also | |
414 | # zero-based. | |
415 | proc get_line {n {c ""}} { | |
416 | set result "" | |
417 | variable _cols | |
418 | variable _chars | |
419 | set c [_default $c $_cols] | |
420 | set x 0 | |
421 | while {$x < $c} { | |
422 | append result [lindex $_chars($x,$n) 0] | |
423 | incr x | |
424 | } | |
425 | return $result | |
426 | } | |
427 | ||
428 | # Get just the character at (X, Y). | |
429 | proc get_char {x y} { | |
430 | variable _chars | |
431 | return [lindex $_chars($x,$y) 0] | |
432 | } | |
433 | ||
434 | # Get the entire screen as a string. | |
435 | proc get_all_lines {} { | |
436 | variable _rows | |
437 | variable _cols | |
438 | variable _chars | |
439 | ||
440 | set result "" | |
441 | for {set y 0} {$y < $_rows} {incr y} { | |
442 | for {set x 0} {$x < $_cols} {incr x} { | |
443 | append result [lindex $_chars($x,$y) 0] | |
444 | } | |
445 | append result "\n" | |
446 | } | |
447 | ||
448 | return $result | |
449 | } | |
450 | ||
451 | # Get the text just before the cursor. | |
452 | proc get_current_line {} { | |
453 | variable _cur_x | |
454 | variable _cur_y | |
455 | return [get_line $_cur_y $_cur_x] | |
456 | } | |
457 | ||
458 | # Helper function for check_box. Returns empty string if the box | |
459 | # is found, description of why not otherwise. | |
460 | proc _check_box {x y width height} { | |
461 | set x2 [expr {$x + $width - 1}] | |
462 | set y2 [expr {$y + $height - 1}] | |
463 | ||
464 | if {[get_char $x $y] != "+"} { | |
465 | return "ul corner" | |
466 | } | |
467 | if {[get_char $x $y2] != "+"} { | |
468 | return "ll corner" | |
469 | } | |
470 | if {[get_char $x2 $y] != "+"} { | |
471 | return "ur corner" | |
472 | } | |
473 | if {[get_char $x2 $y2] != "+"} { | |
474 | return "lr corner" | |
475 | } | |
476 | ||
477 | for {set i [expr {$x + 1}]} {$i < $x2 - 1} {incr i} { | |
478 | # Note we do not check the top border of the box, because | |
479 | # it will contain a title. | |
480 | if {[get_char $i $y2] != "-"} { | |
481 | return "bottom border $i" | |
482 | } | |
483 | } | |
484 | for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} { | |
485 | if {[get_char $x $i] != "|"} { | |
486 | return "left side $i" | |
487 | } | |
488 | if {[get_char $x2 $i] != "|"} { | |
489 | return "right side $i" | |
490 | } | |
491 | } | |
492 | ||
493 | return "" | |
494 | } | |
495 | ||
496 | # Check for a box at the given coordinates. | |
497 | proc check_box {test_name x y width height} { | |
498 | set why [_check_box $x $y $width $height] | |
499 | if {$why == ""} { | |
500 | pass $test_name | |
501 | } else { | |
502 | dump_screen | |
503 | fail "$test_name ($why)" | |
504 | } | |
505 | } | |
506 | ||
507 | # Check whether the text contents of the terminal match the | |
508 | # regular expression. Note that text styling is not considered. | |
509 | proc check_contents {test_name regexp} { | |
510 | set contents [get_all_lines] | |
511 | if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} { | |
512 | dump_screen | |
513 | } | |
514 | } | |
515 | ||
516 | # A debugging function to dump the current screen, with line | |
517 | # numbers. | |
518 | proc dump_screen {} { | |
519 | variable _rows | |
520 | verbose "Screen Dump:" | |
521 | for {set y 0} {$y < $_rows} {incr y} { | |
522 | set fmt [format %5d $y] | |
523 | verbose "$fmt [get_line $y]" | |
524 | } | |
525 | } | |
526 | } |