]>
Commit | Line | Data |
---|---|---|
1d506c26 | 1 | # Copyright 2019-2024 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 | 36 | proc _log { what } { |
1457d766 | 37 | verbose "+++ $what" |
730af663 SM |
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 | ||
e5f7752a SM |
91 | if {$_cur_col > 0} { |
92 | incr _cur_col -1 | |
c3786b3a TT |
93 | } |
94 | } | |
95 | } | |
96 | ||
97 | # Linefeed. | |
98 | proc _ctl_0x0a {} { | |
730af663 SM |
99 | _log_cur "Line feed" { |
100 | variable _cur_row | |
101 | variable _rows | |
efe1b650 AB |
102 | variable _cols |
103 | variable _chars | |
730af663 SM |
104 | |
105 | incr _cur_row 1 | |
efe1b650 AB |
106 | while {$_cur_row >= $_rows} { |
107 | # Scroll the display contents. We scroll one line at | |
108 | # a time here; as _cur_row was only increased by one, | |
109 | # a single line scroll should be enough to put the | |
110 | # cursor back on the screen. But we wrap the | |
111 | # scrolling inside a while loop just to be on the safe | |
112 | # side. | |
113 | for {set y 0} {$y < [expr $_rows - 1]} {incr y} { | |
114 | set next_y [expr $y + 1] | |
115 | for {set x 0} {$x < $_cols} {incr x} { | |
116 | set _chars($x,$y) $_chars($x,$next_y) | |
117 | } | |
efe1b650 | 118 | } |
e20baea1 TV |
119 | |
120 | incr _cur_row -1 | |
730af663 | 121 | } |
c3786b3a TT |
122 | } |
123 | } | |
124 | ||
125 | # Carriage return. | |
126 | proc _ctl_0x0d {} { | |
730af663 SM |
127 | _log_cur "Carriage return" { |
128 | variable _cur_col | |
129 | ||
130 | set _cur_col 0 | |
131 | } | |
c3786b3a TT |
132 | } |
133 | ||
6571ffc6 SM |
134 | # Insert Character. |
135 | # | |
136 | # https://vt100.net/docs/vt510-rm/ICH.html | |
3d235706 TT |
137 | proc _csi_@ {args} { |
138 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
139 | |
140 | _log_cur "Insert Character ($n)" { | |
141 | variable _cur_col | |
142 | variable _cur_row | |
e5f7752a | 143 | variable _cols |
730af663 SM |
144 | variable _chars |
145 | ||
e5f7752a SM |
146 | # Move characters right of the cursor right by N positions, |
147 | # starting with the rightmost one. | |
148 | for {set in_col [expr $_cols - $n - 1]} {$in_col >= $_cur_col} {incr in_col -1} { | |
149 | set out_col [expr $in_col + $n] | |
150 | set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) | |
730af663 | 151 | } |
e5f7752a SM |
152 | |
153 | # Write N blank spaces starting from the cursor. | |
154 | _clear_in_line $_cur_col [expr $_cur_col + $n] $_cur_row | |
3d235706 TT |
155 | } |
156 | } | |
157 | ||
c3786b3a | 158 | # Cursor Up. |
6571ffc6 SM |
159 | # |
160 | # https://vt100.net/docs/vt510-rm/CUU.html | |
c3786b3a | 161 | proc _csi_A {args} { |
c3786b3a | 162 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
163 | |
164 | _log_cur "Cursor Up ($arg)" { | |
165 | variable _cur_row | |
166 | ||
167 | set _cur_row [expr {max ($_cur_row - $arg, 0)}] | |
168 | } | |
c3786b3a TT |
169 | } |
170 | ||
171 | # Cursor Down. | |
6571ffc6 SM |
172 | # |
173 | # https://vt100.net/docs/vt510-rm/CUD.html | |
c3786b3a | 174 | proc _csi_B {args} { |
c3786b3a | 175 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
176 | |
177 | _log_cur "Cursor Down ($arg)" { | |
178 | variable _cur_row | |
179 | variable _rows | |
180 | ||
e5f7752a | 181 | set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] |
730af663 | 182 | } |
c3786b3a TT |
183 | } |
184 | ||
185 | # Cursor Forward. | |
6571ffc6 SM |
186 | # |
187 | # https://vt100.net/docs/vt510-rm/CUF.html | |
c3786b3a | 188 | proc _csi_C {args} { |
c3786b3a | 189 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
190 | |
191 | _log_cur "Cursor Forward ($arg)" { | |
192 | variable _cur_col | |
193 | variable _cols | |
194 | ||
e5f7752a | 195 | set _cur_col [expr {min ($_cur_col + $arg, $_cols - 1)}] |
730af663 | 196 | } |
c3786b3a TT |
197 | } |
198 | ||
6571ffc6 SM |
199 | # Cursor Backward. |
200 | # | |
201 | # https://vt100.net/docs/vt510-rm/CUB.html | |
c3786b3a | 202 | proc _csi_D {args} { |
c3786b3a | 203 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
204 | |
205 | _log_cur "Cursor Backward ($arg)" { | |
206 | variable _cur_col | |
207 | ||
208 | set _cur_col [expr {max ($_cur_col - $arg, 0)}] | |
209 | } | |
c3786b3a TT |
210 | } |
211 | ||
212 | # Cursor Next Line. | |
6571ffc6 SM |
213 | # |
214 | # https://vt100.net/docs/vt510-rm/CNL.html | |
c3786b3a | 215 | proc _csi_E {args} { |
c3786b3a | 216 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
217 | |
218 | _log_cur "Cursor Next Line ($arg)" { | |
219 | variable _cur_col | |
220 | variable _cur_row | |
221 | variable _rows | |
222 | ||
223 | set _cur_col 0 | |
e5f7752a | 224 | set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] |
730af663 | 225 | } |
c3786b3a TT |
226 | } |
227 | ||
228 | # Cursor Previous Line. | |
6571ffc6 SM |
229 | # |
230 | # https://vt100.net/docs/vt510-rm/CPL.html | |
c3786b3a | 231 | proc _csi_F {args} { |
c3786b3a | 232 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
233 | |
234 | _log_cur "Cursor Previous Line ($arg)" { | |
235 | variable _cur_col | |
236 | variable _cur_row | |
237 | variable _rows | |
238 | ||
239 | set _cur_col 0 | |
240 | set _cur_row [expr {max ($_cur_row - $arg, 0)}] | |
241 | } | |
c3786b3a TT |
242 | } |
243 | ||
244 | # Cursor Horizontal Absolute. | |
6571ffc6 SM |
245 | # |
246 | # https://vt100.net/docs/vt510-rm/CHA.html | |
c3786b3a | 247 | proc _csi_G {args} { |
c3786b3a | 248 | set arg [_default [lindex $args 0] 1] |
730af663 SM |
249 | |
250 | _log_cur "Cursor Horizontal Absolute ($arg)" { | |
251 | variable _cur_col | |
252 | variable _cols | |
253 | ||
254 | set _cur_col [expr {min ($arg - 1, $_cols)}] | |
255 | } | |
c3786b3a TT |
256 | } |
257 | ||
6571ffc6 SM |
258 | # Cursor Position. |
259 | # | |
260 | # https://vt100.net/docs/vt510-rm/CUP.html | |
c3786b3a | 261 | proc _csi_H {args} { |
730af663 SM |
262 | set row [_default [lindex $args 0] 1] |
263 | set col [_default [lindex $args 1] 1] | |
264 | ||
265 | _log_cur "Cursor Position ($row, $col)" { | |
266 | variable _cur_col | |
267 | variable _cur_row | |
268 | ||
269 | set _cur_row [expr {$row - 1}] | |
270 | set _cur_col [expr {$col - 1}] | |
271 | } | |
c3786b3a TT |
272 | } |
273 | ||
6571ffc6 SM |
274 | # Cursor Horizontal Forward Tabulation. |
275 | # | |
276 | # https://vt100.net/docs/vt510-rm/CHT.html | |
c3786b3a TT |
277 | proc _csi_I {args} { |
278 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
279 | |
280 | _log_cur "Cursor Horizontal Forward Tabulation ($n)" { | |
281 | variable _cur_col | |
282 | variable _cols | |
283 | ||
284 | incr _cur_col [expr {$n * 8 - $_cur_col % 8}] | |
285 | if {$_cur_col >= $_cols} { | |
286 | set _cur_col [expr {$_cols - 1}] | |
287 | } | |
c3786b3a TT |
288 | } |
289 | } | |
290 | ||
6571ffc6 SM |
291 | # Erase in Display. |
292 | # | |
293 | # https://vt100.net/docs/vt510-rm/ED.html | |
c3786b3a | 294 | proc _csi_J {args} { |
c3786b3a | 295 | set arg [_default [lindex $args 0] 0] |
730af663 SM |
296 | |
297 | _log_cur "Erase in Display ($arg)" { | |
298 | variable _cur_col | |
299 | variable _cur_row | |
300 | variable _rows | |
301 | variable _cols | |
302 | ||
303 | if {$arg == 0} { | |
e5f7752a | 304 | # Cursor (inclusive) to end of display. |
730af663 SM |
305 | _clear_in_line $_cur_col $_cols $_cur_row |
306 | _clear_lines [expr {$_cur_row + 1}] $_rows | |
307 | } elseif {$arg == 1} { | |
e5f7752a SM |
308 | # Beginning of display to cursor (inclusive). |
309 | _clear_lines 0 $_cur_row | |
310 | _clear_in_line 0 [expr $_cur_col + 1] $_cur_row | |
730af663 | 311 | } elseif {$arg == 2} { |
e5f7752a | 312 | # Entire display. |
730af663 SM |
313 | _clear_lines 0 $_rows |
314 | } | |
c3786b3a TT |
315 | } |
316 | } | |
317 | ||
6571ffc6 SM |
318 | # Erase in Line. |
319 | # | |
320 | # https://vt100.net/docs/vt510-rm/EL.html | |
c3786b3a | 321 | proc _csi_K {args} { |
c3786b3a | 322 | set arg [_default [lindex $args 0] 0] |
730af663 SM |
323 | |
324 | _log_cur "Erase in Line ($arg)" { | |
325 | variable _cur_col | |
326 | variable _cur_row | |
327 | variable _cols | |
328 | ||
329 | if {$arg == 0} { | |
e5f7752a | 330 | # Cursor (inclusive) to end of line. |
730af663 SM |
331 | _clear_in_line $_cur_col $_cols $_cur_row |
332 | } elseif {$arg == 1} { | |
e5f7752a SM |
333 | # Beginning of line to cursor (inclusive). |
334 | _clear_in_line 0 [expr $_cur_col + 1] $_cur_row | |
730af663 | 335 | } elseif {$arg == 2} { |
e5f7752a | 336 | # Entire line. |
730af663 SM |
337 | _clear_in_line 0 $_cols $_cur_row |
338 | } | |
c3786b3a TT |
339 | } |
340 | } | |
341 | ||
fd46a69e AB |
342 | # Insert Line |
343 | # | |
344 | # https://vt100.net/docs/vt510-rm/IL.html | |
345 | proc _csi_L {args} { | |
346 | set arg [_default [lindex $args 0] 1] | |
347 | ||
348 | _log_cur "Insert Line ($arg)" { | |
349 | variable _cur_col | |
350 | variable _cur_row | |
351 | variable _rows | |
352 | variable _cols | |
353 | variable _chars | |
354 | ||
355 | set y [expr $_rows - 2] | |
356 | set next_y [expr $y + $arg] | |
357 | while {$y >= $_cur_row} { | |
358 | for {set x 0} {$x < $_cols} {incr x} { | |
359 | set _chars($x,$next_y) $_chars($x,$y) | |
360 | } | |
361 | incr y -1 | |
362 | incr next_y -1 | |
363 | } | |
364 | ||
365 | _clear_lines $_cur_row [expr $_cur_row + $arg] | |
366 | } | |
367 | } | |
368 | ||
6571ffc6 SM |
369 | # Delete line. |
370 | # | |
371 | # https://vt100.net/docs/vt510-rm/DL.html | |
c3786b3a | 372 | proc _csi_M {args} { |
c3786b3a | 373 | set count [_default [lindex $args 0] 1] |
730af663 SM |
374 | |
375 | _log_cur "Delete line ($count)" { | |
376 | variable _cur_row | |
377 | variable _rows | |
378 | variable _cols | |
379 | variable _chars | |
380 | ||
381 | set y $_cur_row | |
5fb97639 AB |
382 | set next_y [expr {$y + $count}] |
383 | while {$next_y < $_rows} { | |
730af663 SM |
384 | for {set x 0} {$x < $_cols} {incr x} { |
385 | set _chars($x,$y) $_chars($x,$next_y) | |
386 | } | |
387 | incr y | |
388 | incr next_y | |
c3786b3a | 389 | } |
5fb97639 | 390 | _clear_lines $y $_rows |
c3786b3a | 391 | } |
c3786b3a TT |
392 | } |
393 | ||
7820b634 SM |
394 | # Delete Character. |
395 | # | |
396 | # https://vt100.net/docs/vt510-rm/DCH.html | |
397 | proc _csi_P {args} { | |
398 | set count [_default [lindex $args 0] 1] | |
399 | ||
400 | _log_cur "Delete character ($count)" { | |
401 | variable _cur_row | |
402 | variable _cur_col | |
403 | variable _chars | |
404 | variable _cols | |
405 | ||
406 | # Move all characters right of the cursor N positions left. | |
407 | set out_col [expr $_cur_col] | |
408 | set in_col [expr $_cur_col + $count] | |
409 | ||
410 | while {$in_col < $_cols} { | |
411 | set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) | |
412 | incr in_col | |
413 | incr out_col | |
414 | } | |
415 | ||
416 | # Clear the rest of the line. | |
417 | _clear_in_line $out_col $_cols $_cur_row | |
418 | } | |
419 | } | |
420 | ||
fd46a69e AB |
421 | # Pan Down |
422 | # | |
423 | # https://vt100.net/docs/vt510-rm/SU.html | |
424 | proc _csi_S {args} { | |
425 | set count [_default [lindex $args 0] 1] | |
426 | ||
427 | _log_cur "Pan Down ($count)" { | |
428 | variable _cur_col | |
429 | variable _cur_row | |
430 | variable _cols | |
431 | variable _rows | |
432 | variable _chars | |
433 | ||
434 | # The following code is written without consideration for | |
435 | # the scroll margins. At this time this comment was | |
436 | # written the tuiterm library doesn't support the scroll | |
437 | # margins. If/when that changes, then the following will | |
438 | # need to be updated. | |
439 | ||
440 | set dy 0 | |
441 | set y $count | |
442 | ||
443 | while {$y < $_rows} { | |
444 | for {set x 0} {$x < $_cols} {incr x} { | |
445 | set _chars($x,$dy) $_chars($x,$y) | |
446 | } | |
447 | incr y 1 | |
448 | incr dy 1 | |
449 | } | |
450 | ||
451 | _clear_lines $dy $_rows | |
452 | } | |
453 | } | |
454 | ||
455 | # Pan Up | |
456 | # | |
457 | # https://vt100.net/docs/vt510-rm/SD.html | |
458 | proc _csi_T {args} { | |
459 | set count [_default [lindex $args 0] 1] | |
460 | ||
461 | _log_cur "Pan Up ($count)" { | |
462 | variable _cur_col | |
463 | variable _cur_row | |
464 | variable _cols | |
465 | variable _rows | |
466 | variable _chars | |
467 | ||
468 | # The following code is written without consideration for | |
469 | # the scroll margins. At this time this comment was | |
470 | # written the tuiterm library doesn't support the scroll | |
471 | # margins. If/when that changes, then the following will | |
472 | # need to be updated. | |
473 | ||
474 | set y [expr $_rows - $count] | |
475 | set dy $_rows | |
476 | ||
477 | while {$dy >= $count} { | |
478 | for {set x 0} {$x < $_cols} {incr x} { | |
479 | set _chars($x,$dy) $_chars($x,$y) | |
480 | } | |
481 | incr y -1 | |
482 | incr dy -1 | |
483 | } | |
484 | ||
485 | _clear_lines 0 $count | |
486 | } | |
487 | } | |
488 | ||
c3786b3a | 489 | # Erase chars. |
6571ffc6 SM |
490 | # |
491 | # https://vt100.net/docs/vt510-rm/ECH.html | |
c3786b3a TT |
492 | proc _csi_X {args} { |
493 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
494 | |
495 | _log_cur "Erase chars ($n)" { | |
496 | # Erase characters but don't move cursor. | |
497 | variable _cur_col | |
498 | variable _cur_row | |
499 | variable _attrs | |
500 | variable _chars | |
501 | ||
502 | set lattr [array get _attrs] | |
503 | set x $_cur_col | |
504 | for {set i 0} {$i < $n} {incr i} { | |
505 | set _chars($x,$_cur_row) [list " " $lattr] | |
506 | incr x | |
507 | } | |
3d235706 | 508 | } |
c3786b3a TT |
509 | } |
510 | ||
6571ffc6 SM |
511 | # Cursor Backward Tabulation. |
512 | # | |
513 | # https://vt100.net/docs/vt510-rm/CBT.html | |
398fdd60 TT |
514 | proc _csi_Z {args} { |
515 | set n [_default [lindex $args 0] 1] | |
730af663 SM |
516 | |
517 | _log_cur "Cursor Backward Tabulation ($n)" { | |
518 | variable _cur_col | |
519 | ||
520 | set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}] | |
521 | } | |
398fdd60 TT |
522 | } |
523 | ||
c3786b3a | 524 | # Repeat. |
6571ffc6 SM |
525 | # |
526 | # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`) | |
c3786b3a | 527 | proc _csi_b {args} { |
c3786b3a | 528 | set n [_default [lindex $args 0] 1] |
730af663 SM |
529 | |
530 | _log_cur "Repeat ($n)" { | |
531 | variable _last_char | |
532 | ||
533 | _insert [string repeat $_last_char $n] | |
534 | } | |
c3786b3a TT |
535 | } |
536 | ||
6571ffc6 SM |
537 | # Vertical Line Position Absolute. |
538 | # | |
539 | # https://vt100.net/docs/vt510-rm/VPA.html | |
c3786b3a | 540 | proc _csi_d {args} { |
730af663 SM |
541 | set row [_default [lindex $args 0] 1] |
542 | ||
543 | _log_cur "Vertical Line Position Absolute ($row)" { | |
544 | variable _cur_row | |
e5f7752a | 545 | variable _rows |
730af663 | 546 | |
e5f7752a | 547 | set _cur_row [expr min ($row - 1, $_rows - 1)] |
730af663 | 548 | } |
c3786b3a TT |
549 | } |
550 | ||
a01399ff TV |
551 | # Reset the attributes in attributes array UPVAR_NAME to the default values. |
552 | proc _reset_attrs { upvar_name } { | |
553 | upvar $upvar_name var | |
554 | array set var { | |
555 | intensity normal | |
556 | fg default | |
557 | bg default | |
558 | underline 0 | |
559 | reverse 0 | |
52141e2d TV |
560 | invisible 0 |
561 | blinking 0 | |
a01399ff TV |
562 | } |
563 | } | |
564 | ||
a3b86780 TV |
565 | # Translate the color numbers as used in proc _csi_m to a name. |
566 | proc _color_attr { n } { | |
567 | switch -exact -- $n { | |
568 | 0 { | |
569 | return black | |
570 | } | |
571 | 1 { | |
572 | return red | |
573 | } | |
574 | 2 { | |
575 | return green | |
576 | } | |
577 | 3 { | |
578 | return yellow | |
579 | } | |
580 | 4 { | |
581 | return blue | |
582 | } | |
583 | 5 { | |
584 | return magenta | |
585 | } | |
586 | 6 { | |
587 | return cyan | |
588 | } | |
589 | 7 { | |
590 | return white | |
591 | } | |
592 | default { error "unsupported color number: $n" } | |
593 | } | |
594 | } | |
595 | ||
c3786b3a | 596 | # Select Graphic Rendition. |
6571ffc6 SM |
597 | # |
598 | # https://vt100.net/docs/vt510-rm/SGR.html | |
c3786b3a | 599 | proc _csi_m {args} { |
730af663 | 600 | _log_cur "Select Graphic Rendition ([join $args {, }])" { |
92240b19 TV |
601 | variable _attrs |
602 | ||
603 | foreach item $args { | |
604 | switch -exact -- $item { | |
605 | "" - 0 { | |
a01399ff | 606 | _reset_attrs _attrs |
92240b19 TV |
607 | } |
608 | 1 { | |
609 | set _attrs(intensity) bold | |
610 | } | |
611 | 2 { | |
612 | set _attrs(intensity) dim | |
613 | } | |
614 | 4 { | |
615 | set _attrs(underline) 1 | |
616 | } | |
52141e2d TV |
617 | 5 { |
618 | set _attrs(blinking) 1 | |
619 | } | |
92240b19 TV |
620 | 7 { |
621 | set _attrs(reverse) 1 | |
622 | } | |
52141e2d TV |
623 | 8 { |
624 | set _attrs(invisible) 1 | |
625 | } | |
92240b19 TV |
626 | 22 { |
627 | set _attrs(intensity) normal | |
628 | } | |
629 | 24 { | |
630 | set _attrs(underline) 0 | |
631 | } | |
52141e2d TV |
632 | 25 { |
633 | set _attrs(blinking) 0 | |
634 | } | |
92240b19 | 635 | 27 { |
7f05c98b | 636 | set _attrs(reverse) 0 |
92240b19 | 637 | } |
52141e2d TV |
638 | 28 { |
639 | set _attrs(invisible) 0 | |
640 | } | |
92240b19 | 641 | 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { |
a3b86780 | 642 | set _attrs(fg) [_color_attr [expr $item - 30]] |
92240b19 TV |
643 | } |
644 | 39 { | |
645 | set _attrs(fg) default | |
646 | } | |
647 | 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { | |
a3b86780 | 648 | set _attrs(bg) [_color_attr [expr $item - 40]] |
92240b19 TV |
649 | } |
650 | 49 { | |
651 | set _attrs(bg) default | |
652 | } | |
653 | } | |
654 | } | |
c3786b3a TT |
655 | } |
656 | } | |
657 | ||
658 | # Insert string at the cursor location. | |
659 | proc _insert {str} { | |
730af663 SM |
660 | _log_cur "Inserted string '$str'" { |
661 | _log "Inserting string '$str'" | |
662 | ||
663 | variable _cur_col | |
664 | variable _cur_row | |
665 | variable _rows | |
666 | variable _cols | |
667 | variable _attrs | |
668 | variable _chars | |
669 | set lattr [array get _attrs] | |
670 | foreach char [split $str {}] { | |
92240b19 | 671 | _log_cur " Inserted char '$char'" { |
730af663 SM |
672 | set _chars($_cur_col,$_cur_row) [list $char $lattr] |
673 | incr _cur_col | |
674 | if {$_cur_col >= $_cols} { | |
675 | set _cur_col 0 | |
676 | incr _cur_row | |
677 | if {$_cur_row >= $_rows} { | |
678 | error "FIXME scroll" | |
679 | } | |
680 | } | |
c3786b3a TT |
681 | } |
682 | } | |
683 | } | |
684 | } | |
685 | ||
e5f7752a SM |
686 | # Move the cursor to the (0-based) COL and ROW positions. |
687 | proc _move_cursor { col row } { | |
688 | variable _cols | |
689 | variable _rows | |
690 | variable _cur_col | |
691 | variable _cur_row | |
692 | ||
693 | if { $col < 0 || $col >= $_cols } { | |
694 | error "_move_cursor: invalid col value: $col" | |
695 | } | |
696 | ||
697 | if { $row < 0 || $row >= $_rows } { | |
698 | error "_move_cursor: invalid row value: $row" | |
699 | } | |
700 | ||
701 | ||
702 | set _cur_col $col | |
703 | set _cur_row $row | |
704 | } | |
705 | ||
c3786b3a TT |
706 | # Initialize. |
707 | proc _setup {rows cols} { | |
708 | global stty_init | |
709 | set stty_init "rows $rows columns $cols" | |
710 | ||
711 | variable _rows | |
712 | variable _cols | |
c3e96aa7 SM |
713 | variable _cur_col |
714 | variable _cur_row | |
c3786b3a | 715 | variable _attrs |
45e42163 | 716 | variable _resize_count |
c3786b3a TT |
717 | |
718 | set _rows $rows | |
719 | set _cols $cols | |
c3e96aa7 SM |
720 | set _cur_col 0 |
721 | set _cur_row 0 | |
45e42163 | 722 | set _resize_count 0 |
a01399ff | 723 | _reset_attrs _attrs |
c3786b3a TT |
724 | |
725 | _clear_lines 0 $_rows | |
726 | } | |
727 | ||
4a43e243 TV |
728 | # Accept some output from gdb and update the screen. |
729 | # Return 1 if successful, or 0 if a timeout occurred. | |
730 | proc accept_gdb_output { } { | |
731 | global expect_out | |
732 | gdb_expect { | |
733 | -re "^\[\x07\x08\x0a\x0d\]" { | |
734 | scan $expect_out(0,string) %c val | |
735 | set hexval [format "%02x" $val] | |
736 | _log "wait_for: _ctl_0x${hexval}" | |
737 | _ctl_0x${hexval} | |
738 | } | |
739 | -re "^\x1b(\[0-9a-zA-Z\])" { | |
740 | _log "wait_for: unsupported escape" | |
741 | error "unsupported escape" | |
742 | } | |
743 | -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" { | |
744 | set cmd $expect_out(2,string) | |
745 | set params [split $expect_out(1,string) ";"] | |
746 | _log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>" | |
747 | eval _csi_$cmd $params | |
748 | } | |
749 | -re "^\[^\x07\x08\x0a\x0d\x1b\]+" { | |
750 | _insert $expect_out(0,string) | |
751 | variable _last_char | |
752 | set _last_char [string index $expect_out(0,string) end] | |
753 | } | |
754 | ||
755 | timeout { | |
756 | # Assume a timeout means we somehow missed the | |
757 | # expected result, and carry on. | |
0d00a5f9 TV |
758 | warning "timeout in accept_gdb_output" |
759 | dump_screen | |
4a43e243 TV |
760 | return 0 |
761 | } | |
762 | } | |
763 | ||
764 | return 1 | |
765 | } | |
766 | ||
c2feffd8 TV |
767 | # Print arg using "verbose -log" if DEBUG_TUI_MATCHING == 1. |
768 | proc debug_tui_matching { arg } { | |
769 | set debug 0 | |
770 | if { [info exists ::DEBUG_TUI_MATCHING] } { | |
771 | set debug $::DEBUG_TUI_MATCHING | |
772 | } | |
773 | ||
774 | if { ! $debug } { | |
775 | return | |
776 | } | |
777 | ||
778 | verbose -log "$arg" | |
779 | } | |
780 | ||
9ae6bf64 TT |
781 | # Accept some output from gdb and update the screen. WAIT_FOR is |
782 | # a regexp matching the line to wait for. Return 0 on timeout, 1 | |
783 | # on success. | |
784 | proc wait_for {wait_for} { | |
45e42163 | 785 | global gdb_prompt |
c3e96aa7 SM |
786 | variable _cur_col |
787 | variable _cur_row | |
45e42163 | 788 | |
c2feffd8 | 789 | set fn "wait_for" |
92240b19 | 790 | |
3e543c18 | 791 | set prompt_wait_for "(^|\\|)$gdb_prompt \$" |
c9966f7a TV |
792 | if { $wait_for == "" } { |
793 | set wait_for $prompt_wait_for | |
794 | } | |
795 | ||
c2feffd8 | 796 | debug_tui_matching "$fn: regexp: '$wait_for'" |
45e42163 TT |
797 | |
798 | while 1 { | |
4a43e243 TV |
799 | if { [accept_gdb_output] == 0 } { |
800 | return 0 | |
c3786b3a | 801 | } |
45e42163 TT |
802 | |
803 | # If the cursor appears just after the prompt, return. It | |
804 | # isn't reliable to check this only after an insertion, | |
805 | # because curses may make "unusual" redrawing decisions. | |
806 | if {$wait_for == "$prompt_wait_for"} { | |
c3e96aa7 | 807 | set prev [get_line $_cur_row $_cur_col] |
45e42163 | 808 | } else { |
c3e96aa7 | 809 | set prev [get_line $_cur_row] |
45e42163 TT |
810 | } |
811 | if {[regexp -- $wait_for $prev]} { | |
c2feffd8 | 812 | debug_tui_matching "$fn: match: '$prev'" |
45e42163 TT |
813 | if {$wait_for == "$prompt_wait_for"} { |
814 | break | |
c3786b3a | 815 | } |
45e42163 | 816 | set wait_for $prompt_wait_for |
c2feffd8 TV |
817 | debug_tui_matching "$fn: regexp prompt: '$wait_for'" |
818 | } else { | |
819 | debug_tui_matching "$fn: mismatch: '$prev'" | |
c3786b3a TT |
820 | } |
821 | } | |
9ae6bf64 TT |
822 | |
823 | return 1 | |
c3786b3a TT |
824 | } |
825 | ||
4a43e243 TV |
826 | # Accept some output from gdb and update the screen. Wait for the screen |
827 | # region X/Y/WIDTH/HEIGTH to matches REGEXP. Return 0 on timeout, 1 on | |
828 | # success. | |
829 | proc wait_for_region_contents {x y width height regexp} { | |
830 | while 1 { | |
831 | if { [accept_gdb_output] == 0 } { | |
832 | return 0 | |
833 | } | |
834 | ||
835 | if { [check_region_contents_p $x $y $width $height $regexp] } { | |
836 | break | |
837 | } | |
838 | } | |
839 | ||
840 | return 1 | |
841 | } | |
842 | ||
c2a0fca0 TV |
843 | # Setup the terminal with dimensions ROWSxCOLS, TERM=ansi, and execute |
844 | # BODY. | |
845 | proc with_tuiterm {rows cols body} { | |
c3786b3a | 846 | global env stty_init |
4ebfd53d | 847 | save_vars {env(TERM) env(NO_COLOR) stty_init} { |
c3786b3a | 848 | setenv TERM ansi |
4ebfd53d | 849 | setenv NO_COLOR "" |
c3786b3a | 850 | _setup $rows $cols |
618ba278 | 851 | |
c2a0fca0 TV |
852 | uplevel $body |
853 | } | |
854 | } | |
618ba278 | 855 | |
c2a0fca0 TV |
856 | # Like ::clean_restart, but ensures that gdb starts in an |
857 | # environment where the TUI can work. ROWS and COLS are the size | |
858 | # of the terminal. EXECUTABLE, if given, is passed to | |
859 | # clean_restart. | |
860 | proc clean_restart {rows cols {executable {}}} { | |
861 | with_tuiterm $rows $cols { | |
862 | save_vars { ::GDBFLAGS } { | |
863 | # Make GDB not print the directory names. Use this setting to | |
864 | # remove the differences in test runs due to varying directory | |
865 | # names. | |
866 | append ::GDBFLAGS " -ex \"set filename-display basename\"" | |
867 | ||
868 | if {$executable == ""} { | |
869 | ::clean_restart | |
870 | } else { | |
871 | ::clean_restart $executable | |
872 | } | |
2b1d00c2 | 873 | } |
c2a0fca0 | 874 | |
cf2ad3e6 | 875 | ::gdb_test_no_output "set pagination off" |
c3786b3a TT |
876 | } |
877 | } | |
878 | ||
9f889c48 TV |
879 | # Generate prompt on TUIterm. |
880 | proc gen_prompt {} { | |
881 | # Generate a prompt. | |
882 | send_gdb "echo\n" | |
883 | ||
884 | # Drain the output before the prompt. | |
885 | gdb_expect { | |
886 | -re "echo\r\n" { | |
887 | } | |
888 | } | |
889 | ||
890 | # Interpret prompt using TUIterm. | |
891 | wait_for "" | |
892 | } | |
893 | ||
b40aa28f AB |
894 | # Setup ready for starting the tui, but don't actually start it. |
895 | # Returns 1 on success, 0 if TUI tests should be skipped. | |
896 | proc prepare_for_tui {} { | |
72f160d0 TV |
897 | if { [is_remote host] } { |
898 | # In clean_restart, we're using "setenv TERM ansi", which has | |
899 | # effect on build. If we have [is_remote host] == 0, so | |
900 | # build == host, then it also has effect on host. But for | |
901 | # [is_remote host] == 1, it has no effect on host. | |
902 | return 0 | |
903 | } | |
904 | ||
b5075fb6 | 905 | if {![allow_tui_tests]} { |
c3786b3a TT |
906 | return 0 |
907 | } | |
908 | ||
909 | gdb_test_no_output "set tui border-kind ascii" | |
45e42163 | 910 | gdb_test_no_output "maint set tui-resize-message on" |
b40aa28f AB |
911 | return 1 |
912 | } | |
913 | ||
914 | # Start the TUI. Returns 1 on success, 0 if TUI tests should be | |
915 | # skipped. | |
916 | proc enter_tui {} { | |
917 | if {![prepare_for_tui]} { | |
918 | return 0 | |
919 | } | |
920 | ||
301b21e0 | 921 | command_no_prompt_prefix "tui enable" |
c3786b3a TT |
922 | return 1 |
923 | } | |
924 | ||
925 | # Send the command CMD to gdb, then wait for a gdb prompt to be | |
926 | # seen in the TUI. CMD should not end with a newline -- that will | |
927 | # be supplied by this function. | |
928 | proc command {cmd} { | |
301b21e0 TV |
929 | global gdb_prompt |
930 | send_gdb "$cmd\n" | |
931 | set str [string_to_regexp $cmd] | |
3e543c18 | 932 | set str "(^|\\|)$gdb_prompt $str" |
301b21e0 TV |
933 | wait_for $str |
934 | } | |
935 | ||
30711c89 TV |
936 | # As proc command, but don't wait for an initial prompt. This is used for |
937 | # initial terminal commands, where there's no prompt yet. | |
301b21e0 | 938 | proc command_no_prompt_prefix {cmd} { |
9f889c48 TV |
939 | gen_prompt |
940 | command $cmd | |
c3786b3a TT |
941 | } |
942 | ||
5a8f5960 TV |
943 | # Apply the attribute list in ATTRS to attributes array UPVAR_NAME. |
944 | # Return a string annotating the changed attributes. | |
945 | proc apply_attrs { upvar_name attrs } { | |
946 | set res "" | |
947 | upvar $upvar_name var | |
948 | foreach { attr val } $attrs { | |
949 | if { $var($attr) != $val } { | |
950 | append res "<$attr:$val>" | |
951 | set var($attr) $val | |
952 | } | |
953 | } | |
954 | ||
955 | return $res | |
956 | } | |
957 | ||
958 | # Return the text of screen line N. Lines are 0-based. If C is given, | |
959 | # stop before column C. Columns are also zero-based. If ATTRS, annotate | |
960 | # with attributes. | |
961 | proc get_line_1 {n c attrs} { | |
45e42163 TT |
962 | variable _rows |
963 | # This can happen during resizing, if the cursor seems to | |
964 | # temporarily be off-screen. | |
965 | if {$n >= $_rows} { | |
966 | return "" | |
967 | } | |
968 | ||
c3786b3a TT |
969 | set result "" |
970 | variable _cols | |
971 | variable _chars | |
972 | set c [_default $c $_cols] | |
973 | set x 0 | |
5a8f5960 TV |
974 | if { $attrs } { |
975 | _reset_attrs line_attrs | |
976 | } | |
c3786b3a | 977 | while {$x < $c} { |
5a8f5960 TV |
978 | if { $attrs } { |
979 | set char_attrs [lindex $_chars($x,$n) 1] | |
980 | append result [apply_attrs line_attrs $char_attrs] | |
981 | } | |
c3786b3a TT |
982 | append result [lindex $_chars($x,$n) 0] |
983 | incr x | |
984 | } | |
5a8f5960 TV |
985 | if { $attrs } { |
986 | _reset_attrs zero_attrs | |
987 | set char_attrs [array get zero_attrs] | |
988 | append result [apply_attrs line_attrs $char_attrs] | |
989 | } | |
c3786b3a TT |
990 | return $result |
991 | } | |
992 | ||
5a8f5960 TV |
993 | # Return the text of screen line N, without attributes. Lines are |
994 | # 0-based. If C is given, stop before column C. Columns are also | |
995 | # zero-based. | |
996 | proc get_line {n {c ""} } { | |
997 | return [get_line_1 $n $c 0] | |
998 | } | |
999 | ||
1000 | # As get_line, but annotate with attributes. | |
1001 | proc get_line_with_attrs {n {c ""}} { | |
1002 | return [get_line_1 $n $c 1] | |
1003 | } | |
1004 | ||
c3786b3a TT |
1005 | # Get just the character at (X, Y). |
1006 | proc get_char {x y} { | |
1007 | variable _chars | |
1008 | return [lindex $_chars($x,$y) 0] | |
1009 | } | |
1010 | ||
1011 | # Get the entire screen as a string. | |
1012 | proc get_all_lines {} { | |
1013 | variable _rows | |
1014 | variable _cols | |
1015 | variable _chars | |
1016 | ||
1017 | set result "" | |
1018 | for {set y 0} {$y < $_rows} {incr y} { | |
1019 | for {set x 0} {$x < $_cols} {incr x} { | |
1020 | append result [lindex $_chars($x,$y) 0] | |
1021 | } | |
1022 | append result "\n" | |
1023 | } | |
1024 | ||
1025 | return $result | |
1026 | } | |
1027 | ||
1028 | # Get the text just before the cursor. | |
1029 | proc get_current_line {} { | |
c3e96aa7 SM |
1030 | variable _cur_col |
1031 | variable _cur_row | |
1032 | return [get_line $_cur_row $_cur_col] | |
c3786b3a TT |
1033 | } |
1034 | ||
1035 | # Helper function for check_box. Returns empty string if the box | |
1036 | # is found, description of why not otherwise. | |
1037 | proc _check_box {x y width height} { | |
1038 | set x2 [expr {$x + $width - 1}] | |
1039 | set y2 [expr {$y + $height - 1}] | |
1040 | ||
d0a3c757 SM |
1041 | verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height" |
1042 | ||
1043 | set c [get_char $x $y] | |
1044 | if {$c != "+"} { | |
1045 | return "ul corner is $c, not +" | |
c3786b3a | 1046 | } |
d0a3c757 SM |
1047 | |
1048 | set c [get_char $x $y2] | |
1049 | if {$c != "+"} { | |
1050 | return "ll corner is $c, not +" | |
c3786b3a | 1051 | } |
d0a3c757 SM |
1052 | |
1053 | set c [get_char $x2 $y] | |
1054 | if {$c != "+"} { | |
1055 | return "ur corner is $c, not +" | |
c3786b3a | 1056 | } |
d0a3c757 SM |
1057 | |
1058 | set c [get_char $x2 $y2] | |
1059 | if {$c != "+"} { | |
1060 | return "lr corner is $c, not +" | |
c3786b3a TT |
1061 | } |
1062 | ||
9a6d629c AB |
1063 | # Note we do not check the full horizonal borders of the box. |
1064 | # The top will contain a title, and the bottom may as well, if | |
1065 | # it is overlapped by some other border. However, at most a | |
1066 | # title should appear as '+-VERY LONG TITLE-+', so we can | |
1067 | # check for the '+-' on the left, and '-+' on the right. | |
d0a3c757 SM |
1068 | set c [get_char [expr {$x + 1}] $y] |
1069 | if {$c != "-"} { | |
1070 | return "ul title padding is $c, not -" | |
9a6d629c AB |
1071 | } |
1072 | ||
d0a3c757 SM |
1073 | set c [get_char [expr {$x2 - 1}] $y] |
1074 | if {$c != "-"} { | |
1075 | return "ul title padding is $c, not -" | |
9a6d629c AB |
1076 | } |
1077 | ||
1078 | # Now check the vertical borders. | |
c3786b3a | 1079 | for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} { |
d0a3c757 SM |
1080 | set c [get_char $x $i] |
1081 | if {$c != "|"} { | |
1082 | return "left side $i is $c, not |" | |
c3786b3a | 1083 | } |
d0a3c757 SM |
1084 | |
1085 | set c [get_char $x2 $i] | |
1086 | if {$c != "|"} { | |
1087 | return "right side $i is $c, not |" | |
c3786b3a TT |
1088 | } |
1089 | } | |
1090 | ||
1091 | return "" | |
1092 | } | |
1093 | ||
1094 | # Check for a box at the given coordinates. | |
1095 | proc check_box {test_name x y width height} { | |
1457d766 | 1096 | dump_box $x $y $width $height |
c3786b3a TT |
1097 | set why [_check_box $x $y $width $height] |
1098 | if {$why == ""} { | |
1099 | pass $test_name | |
1100 | } else { | |
c3786b3a TT |
1101 | fail "$test_name ($why)" |
1102 | } | |
1103 | } | |
1104 | ||
d1a912db TV |
1105 | # Wait until a box appears at the given coordinates. |
1106 | proc wait_for_box {test_name x y width height} { | |
1107 | while 1 { | |
1108 | if { [accept_gdb_output] == 0 } { | |
1109 | return 0 | |
1110 | } | |
1111 | ||
1112 | set why [_check_box $x $y $width $height] | |
1113 | if {$why == ""} { | |
1114 | pass $test_name | |
1115 | break | |
1116 | } | |
1117 | } | |
1118 | } | |
1119 | ||
c3786b3a TT |
1120 | # Check whether the text contents of the terminal match the |
1121 | # regular expression. Note that text styling is not considered. | |
1122 | proc check_contents {test_name regexp} { | |
1457d766 | 1123 | dump_screen |
c3786b3a | 1124 | set contents [get_all_lines] |
1457d766 | 1125 | gdb_assert {[regexp -- $regexp $contents]} $test_name |
c3786b3a TT |
1126 | } |
1127 | ||
68b25a74 TV |
1128 | # As check_contents, but check that the text contents of the terminal does |
1129 | # not match the regular expression. | |
1130 | proc check_contents_not {test_name regexp} { | |
1131 | dump_screen | |
1132 | set contents [get_all_lines] | |
1133 | gdb_assert {![regexp -- $regexp $contents]} $test_name | |
1134 | } | |
1135 | ||
58d82c2c TV |
1136 | # Get the region of the screen described by X, Y, WIDTH, |
1137 | # and HEIGHT, and separate the lines using SEP. | |
1138 | proc get_region { x y width height sep } { | |
5fb97639 AB |
1139 | variable _chars |
1140 | ||
58d82c2c TV |
1141 | # Grab the contents of the box, join each line together |
1142 | # using $sep. | |
5fb97639 AB |
1143 | set result "" |
1144 | for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} { | |
1145 | if {$yy > $y} { | |
1146 | # Add the end of line sequence only if this isn't the | |
1147 | # first line. | |
58d82c2c | 1148 | append result $sep |
5fb97639 AB |
1149 | } |
1150 | for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} { | |
1151 | append result [lindex $_chars($xx,$yy) 0] | |
1152 | } | |
1153 | } | |
58d82c2c TV |
1154 | return $result |
1155 | } | |
1156 | ||
1157 | # Check that the region of the screen described by X, Y, WIDTH, | |
1158 | # and HEIGHT match REGEXP. This is like check_contents except | |
1159 | # only part of the screen is checked. This can be used to check | |
1160 | # the contents within a box (though check_box_contents is a better | |
4a43e243 TV |
1161 | # choice for boxes with a border). Return 1 if check succeeded. |
1162 | proc check_region_contents_p { x y width height regexp } { | |
58d82c2c | 1163 | variable _chars |
1457d766 | 1164 | dump_box $x $y $width $height |
5fb97639 | 1165 | |
58d82c2c TV |
1166 | # Now grab the contents of the box, join each line together |
1167 | # with a '\r\n' sequence and match against REGEXP. | |
1168 | set result [get_region $x $y $width $height "\r\n"] | |
4a43e243 TV |
1169 | return [regexp -- $regexp $result] |
1170 | } | |
1171 | ||
1172 | # Check that the region of the screen described by X, Y, WIDTH, | |
1173 | # and HEIGHT match REGEXP. As check_region_contents_p, but produce | |
1174 | # a pass/fail message. | |
1175 | proc check_region_contents { test_name x y width height regexp } { | |
1176 | set ok [check_region_contents_p $x $y $width $height $regexp] | |
1177 | gdb_assert {$ok} $test_name | |
5fb97639 AB |
1178 | } |
1179 | ||
3804da7e AB |
1180 | # Check the contents of a box on the screen. This is a little |
1181 | # like check_contents, but doens't check the whole screen | |
1182 | # contents, only the contents of a single box. This procedure | |
1183 | # includes (effectively) a call to check_box to ensure there is a | |
1184 | # box where expected, if there is then the contents of the box are | |
1185 | # matched against REGEXP. | |
1186 | proc check_box_contents {test_name x y width height regexp} { | |
1187 | variable _chars | |
1188 | ||
1457d766 | 1189 | dump_box $x $y $width $height |
3804da7e AB |
1190 | set why [_check_box $x $y $width $height] |
1191 | if {$why != ""} { | |
3804da7e AB |
1192 | fail "$test_name (box check: $why)" |
1193 | return | |
1194 | } | |
1195 | ||
5fb97639 AB |
1196 | check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \ |
1197 | [expr {$width - 2}] [expr {$height - 2}] $regexp | |
3804da7e AB |
1198 | } |
1199 | ||
c3786b3a | 1200 | # A debugging function to dump the current screen, with line |
5a8f5960 TV |
1201 | # numbers. If ATTRS, annotate with attributes. |
1202 | proc dump_screen { {attrs 0} } { | |
c3786b3a | 1203 | variable _rows |
45e42163 | 1204 | variable _cols |
e5f7752a SM |
1205 | variable _cur_row |
1206 | variable _cur_col | |
1207 | ||
1208 | verbose -log "Screen Dump (size $_cols columns x $_rows rows, cursor at column $_cur_col, row $_cur_row):" | |
1209 | ||
c3786b3a TT |
1210 | for {set y 0} {$y < $_rows} {incr y} { |
1211 | set fmt [format %5d $y] | |
5a8f5960 | 1212 | verbose -log "$fmt [get_line_1 $y "" $attrs]" |
c3786b3a TT |
1213 | } |
1214 | } | |
ded631d5 | 1215 | |
5a8f5960 TV |
1216 | # As dump_screen, but with attributes annotation. |
1217 | proc dump_screen_with_attrs {} { | |
1218 | return [dump_screen 1] | |
1219 | } | |
1220 | ||
58d82c2c TV |
1221 | # A debugging function to dump a box from the current screen, with line |
1222 | # numbers. | |
1223 | proc dump_box { x y width height } { | |
1224 | verbose -log "Box Dump ($width x $height) @ ($x, $y):" | |
1225 | set region [get_region $x $y $width $height "\n"] | |
1226 | set lines [split $region "\n"] | |
1227 | set nr $y | |
1228 | foreach line $lines { | |
1229 | set fmt [format %5d $nr] | |
1230 | verbose -log "$fmt $line" | |
1231 | incr nr | |
1232 | } | |
1233 | } | |
1234 | ||
ded631d5 | 1235 | # Resize the terminal. |
45e42163 | 1236 | proc _do_resize {rows cols} { |
ded631d5 TT |
1237 | variable _chars |
1238 | variable _rows | |
1239 | variable _cols | |
1240 | ||
1241 | set old_rows [expr {min ($_rows, $rows)}] | |
1242 | set old_cols [expr {min ($_cols, $cols)}] | |
1243 | ||
1244 | # Copy locally. | |
1245 | array set local_chars [array get _chars] | |
1246 | unset _chars | |
1247 | ||
1248 | set _rows $rows | |
1249 | set _cols $cols | |
1250 | _clear_lines 0 $_rows | |
1251 | ||
1252 | for {set x 0} {$x < $old_cols} {incr x} { | |
1253 | for {set y 0} {$y < $old_rows} {incr y} { | |
1254 | set _chars($x,$y) $local_chars($x,$y) | |
1255 | } | |
1256 | } | |
45e42163 TT |
1257 | } |
1258 | ||
deb1ba4e | 1259 | proc resize {rows cols {wait_for_msg 1}} { |
45e42163 TT |
1260 | variable _rows |
1261 | variable _cols | |
1262 | variable _resize_count | |
ded631d5 | 1263 | |
45e42163 TT |
1264 | # expect handles each argument to stty separately. This means |
1265 | # that gdb will see SIGWINCH twice. Rather than rely on this | |
1266 | # behavior (which, after all, could be changed), we make it | |
1267 | # explicit here. This also simplifies waiting for the redraw. | |
1268 | _do_resize $rows $_cols | |
9edb1e01 | 1269 | stty rows $_rows < $::gdb_tty_name |
deb1ba4e TV |
1270 | if { $wait_for_msg } { |
1271 | wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" | |
1272 | } | |
45e42163 | 1273 | incr _resize_count |
45e42163 | 1274 | _do_resize $_rows $cols |
deb1ba4e TV |
1275 | stty columns $_cols < $::gdb_tty_name |
1276 | if { $wait_for_msg } { | |
1277 | wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" | |
1278 | } | |
45e42163 | 1279 | incr _resize_count |
ded631d5 | 1280 | } |
c3786b3a | 1281 | } |