1#!/usr/bin/env perl 2# $XTermId: xtra-scroll.pl,v 1.12 2021/09/03 18:34:50 tom Exp $ 3# ----------------------------------------------------------------------------- 4# this file is part of xterm 5# 6# Copyright 2021 by Thomas E. Dickey 7# 8# All Rights Reserved 9# 10# Permission is hereby granted, free of charge, to any person obtaining a 11# copy of this software and associated documentation files (the 12# "Software"), to deal in the Software without restriction, including 13# without limitation the rights to use, copy, modify, merge, publish, 14# distribute, sublicense, and/or sell copies of the Software, and to 15# permit persons to whom the Software is furnished to do so, subject to 16# the following conditions: 17# 18# The above copyright notice and this permission notice shall be included 19# in all copies or substantial portions of the Software. 20# 21# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 22# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 23# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 24# IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY 25# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 26# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 27# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 28# 29# Except as contained in this notice, the name(s) of the above copyright 30# holders shall not be used in advertising or otherwise to promote the 31# sale, use or other dealings in this Software without prior written 32# authorization. 33# ----------------------------------------------------------------------------- 34# Interactively test screen-updates which can exercise the cdXtraScroll and 35# tiXtraScroll features. 36 37use strict; 38use warnings; 39 40use Getopt::Std; 41use Term::ReadKey; 42use I18N::Langinfo qw(langinfo CODESET); 43 44$! = 1; 45 46our $target = ""; 47 48our $encoding = lc( langinfo( CODESET() ) ); 49our ($opt_8); 50 51our $dirty = 1; # nonzero if the screen should be painted 52our $mode_margin = 0; # nonzero if left/right margin mode enabled 53our $mode_origin = 0; # nonzero if origin-mode in effect 54our $mode_screen = 0; # nonzero if using alternate screen 55our $pos_x = 0; # current cursor-Y, absolute 56our $pos_y = 0; # current cursor-X, absolute 57our $term_high; # terminal's height 58our $term_wide; # terminal's width 59our $CSI = "\x1b["; 60our $crlf = "\r\n"; 61our $text_sample = "THE QUICK BROWN FOX JUMPED OVER THE LAZY DOG "; 62our $text_filler = ""; 63our %margins; 64 65sub raw() { 66 ReadMode 'ultra-raw', 'STDIN'; # allow single-character inputs 67} 68 69sub cooked() { 70 ReadMode 'normal'; 71} 72 73sub utf8_sample() { 74 my $text = ""; 75 for my $n ( 0 .. length($text_sample) ) { 76 my $chr = substr( $text_sample, $n, 1 ); 77 if ( $chr eq " " ) { 78 $chr = " "; 79 } 80 elsif ( ord($chr) < 32 ) { 81 82 # leave control characters as-is 83 } 84 else { 85 $chr = chr( 0xff00 + ord($chr) - 32 ); 86 } 87 $text .= $chr; 88 } 89 return $text; 90} 91 92sub next_x($) { 93 my $value = shift; 94 if ($mode_margin) { 95 $value = $margins{R} if ( $value < $margins{R} ); 96 $value = $margins{L} if ( $value > $margins{L} ); 97 } 98 else { 99 $value = $value % $term_wide; 100 } 101 return $value; 102} 103 104sub next_y($) { 105 my $value = shift; 106 if ($mode_origin) { 107 $value = $margins{B} if ( $value < $margins{T} ); 108 $value = $margins{T} if ( $value > $margins{B} ); 109 } 110 else { 111 $value = $value % $term_high; 112 } 113 return $value; 114} 115 116sub move() { 117 my $y = $pos_y; 118 if ($mode_origin) { 119 my $min_y = ( $margins{T} >= 0 ) ? $margins{T} : 0; 120 my $two_y = $min_y + 1; # scrolling region is at least 2 lines 121 my $max_y = ( $margins{B} >= $two_y ) ? $margins{B} : $two_y; 122 $y = $max_y if ( $y > $max_y ); 123 $y -= $min_y; # convert to relative ordinate 124 } 125 $y = 0 if ( $y < 0 ); 126 printf STDERR "%s%d;%dH", $CSI, 1 + $y, 1 + $pos_x; 127} 128 129sub home() { 130 printf STDERR "%sH", $CSI; 131 $pos_x = 0; 132 $pos_y = 0; 133 &move; 134} 135 136sub erase_display($) { 137 my $mode = shift; 138 printf STDERR "%s%sJ", $CSI, $mode; 139} 140 141sub erase_line($) { 142 my $mode = shift; 143 printf STDERR "%s%sK", $CSI, $mode; 144} 145 146sub toggle($) { 147 my $value = shift; 148 return ( $value == 0 ) ? 1 : 0; 149} 150 151################################################################################ 152 153sub set_margin_mode($) { 154 my $mode = shift; 155 printf STDERR "%s?69%s", $CSI, ( $mode == 0 ) ? "l" : "h"; 156 $mode_margin = $mode; 157} 158 159################################################################################ 160 161sub set_origin_mode($) { 162 my $mode = shift; 163 printf STDERR "%s?6%s", $CSI, ( $mode == 0 ) ? "l" : "h"; 164 $mode_origin = $mode; 165} 166 167################################################################################ 168 169sub set_screen_mode($) { 170 my $mode = shift; 171 printf STDERR "%s?1049%s", $CSI, ( $mode == 0 ) ? "l" : "h"; 172 $mode_screen = $mode; 173} 174 175################################################################################ 176 177sub do_tb_margins($$) { 178 my $param_T = ""; 179 my $param_B = ""; 180 $param_T = sprintf( "%d", 1 + $margins{T} ) if ( $margins{T} >= 0 ); 181 $param_B = sprintf( "%d", 1 + $margins{B} ) 182 if ( $margins{B} > $margins{T} ); 183 printf STDERR "%s%s;%sr", $CSI, $param_T, $param_B; 184 &move; 185} 186 187sub undo_tb_margins() { 188 &do_tb_margins( -1, -1 ); 189} 190 191sub redo_tb_margins() { 192 &do_tb_margins( $margins{T}, $margins{B} ); 193} 194 195sub set_tb_margins($$) { 196 my $reset = ( not defined $margins{T} or not defined $margins{B} ) ? 1 : 0; 197 my $old_T = 1; 198 my $old_B = $term_high; 199 $old_T = $margins{T} if ( defined $margins{T} ); 200 $old_B = $margins{B} if ( defined $margins{B} ); 201 $margins{T} = shift; 202 $margins{B} = shift; 203 if ( $reset == 0 ) { 204 $reset = 1 if ( $old_T != $margins{T} ); 205 $reset = 1 if ( $old_B != $margins{B} ); 206 } 207 &redo_tb_margins if ( $reset == 1 ); 208} 209 210################################################################################ 211 212sub do_lr_margins($$) { 213 my $param_L = ""; 214 my $param_R = ""; 215 $param_L = sprintf( "%d", 1 + $margins{L} ) if ( $margins{L} >= 0 ); 216 $param_R = sprintf( "%d", 1 + $margins{R} ) 217 if ( $margins{R} > $margins{T} ); 218 printf STDERR "%s%s;%ss", $CSI, $param_L, $param_R; 219 &move; 220} 221 222sub undo_lr_margins() { 223 &do_lr_margins( -1, -1 ); 224} 225 226sub redo_lr_margins() { 227 &do_lr_margins( $margins{L}, $margins{R} ); 228} 229 230sub set_lr_margins($$) { 231 my $reset = ( not defined $margins{L} or not defined $margins{R} ) ? 1 : 0; 232 my $old_L = 1; 233 my $old_R = $term_high; 234 $old_L = $margins{L} if ( defined $margins{L} ); 235 $old_R = $margins{R} if ( defined $margins{R} ); 236 $margins{L} = shift; 237 $margins{R} = shift; 238 if ( $reset == 0 ) { 239 $reset = 1 if ( $old_L != $margins{L} ); 240 $reset = 1 if ( $old_R != $margins{R} ); 241 } 242 &redo_lr_margins if ( $reset == 1 ); 243} 244 245################################################################################ 246 247sub has_tb_margins() { 248 my $result = 0; 249 $result = 1 if ( $margins{T} != 1 ); 250 $result = 1 if ( $margins{B} != $term_high ); 251 return $result; 252} 253 254sub repaint($) { 255 my $erase = shift; 256 my $save_x = $pos_x; 257 my $save_y = $pos_y; 258 $dirty = 0; 259 if ($erase) { 260 &home; 261 &erase_display(2); 262 } 263 if ( $text_filler ne "" ) { 264 if ( $mode_origin and &has_tb_margins ) { 265 my @rows = split /$crlf/, $text_filler; 266 for my $row ( 0 .. $#rows ) { 267 next unless ( $row >= $margins{T} ); 268 next unless ( $row <= $margins{B} ); 269 printf STDERR "%s$crlf", $rows[$row]; 270 } 271 } 272 else { 273 printf STDERR "%s$crlf", $text_filler; 274 } 275 } 276 else { 277 my $cells = 0; 278 my $limit = $term_high * $term_wide; 279 while ( $cells < $limit ) { 280 my $sample = ( $encoding eq "utf-8" ) ? &utf8_sample : $text_sample; 281 printf STDERR "%s", $sample; 282 $cells += length($sample); 283 } 284 } 285 $pos_x = $save_x; 286 $pos_y = $save_y; 287 &move; 288} 289 290sub initialize() { 291 if ( $encoding eq "utf-8" ) { 292 binmode( STDOUT, ":utf8" ); 293 binmode( STDERR, ":utf8" ); 294 } 295 if ($opt_8) { 296 if ( $encoding eq "utf-8" ) { 297 undef $opt_8; 298 printf "...ignoring -8 option since locale uses %s\n", $encoding; 299 } 300 else { 301 printf STDERR "\x1b G"; 302 $CSI = "\x9b"; 303 } 304 } 305 306 &raw; 307 308 my @term_size = GetTerminalSize( \*STDERR ); 309 $term_wide = 80; 310 $term_wide = $term_size[0] if ( $#term_size >= 0 ); 311 $term_wide = 80 if ( $term_wide <= 0 ); 312 $term_high = 24; 313 $term_high = $term_size[1] if ( $#term_size >= 1 ); 314 $term_high = 24 if ( $term_high <= 0 ); 315 316 &set_margin_mode(0); 317 &set_origin_mode(0); 318 &set_screen_mode(0); 319 320 &set_tb_margins( -1, -1 ); 321 &set_lr_margins( 1, $term_wide ); 322 323 &home; 324 &erase_display("2"); 325} 326 327sub cleanup() { 328 &cooked; 329 330 printf STDERR "\x1b F" if ($opt_8); 331 332 &set_margin_mode(0); 333 &set_origin_mode(0); 334 &set_screen_mode(0); 335 336 &undo_tb_margins; 337 338 $pos_x = 1; 339 $pos_y = $term_high - 2; 340 &move; 341 &erase_display(""); 342} 343 344sub beep() { 345 printf STDERR "\a"; 346} 347 348sub main::HELP_MESSAGE() { 349 printf STDERR <<EOF 350Usage: $0 [options] [datafile] 351Options: 352 -8 use 8-bit controls 353EOF 354 ; 355 exit 1; 356} 357 358$Getopt::Std::STANDARD_HELP_VERSION = 1; 359&getopts('8') || &main::HELP_MESSAGE; 360$#ARGV <= 0 || &main::HELP_MESSAGE; 361 362# provide for reading file containing text to repaint 363if ( $#ARGV == 0 ) { 364 if ( open( FP, $ARGV[0] ) ) { 365 my @lines = <FP>; 366 chomp @lines; 367 close FP; 368 $text_filler = join( $crlf, @lines ); 369 } 370} 371 372printf "encoding $encoding\n"; 373 374&initialize(); 375 376while (1) { 377 my $cmd; 378 379 printf "\r\nCommand (? for help):" if ( $dirty != 0 ); 380 $cmd = ReadKey 0; 381 if ( not $cmd ) { 382 sleep 1; 383 } 384 elsif ( $cmd eq "?" ) { 385 $dirty = 1; 386 &home; 387 &erase_display(2); 388 printf $crlf 389 . "General:" 390 . $crlf 391 . " ? (help)," 392 . " q (quit)" 393 . $crlf 394 . "Clear:" 395 . $crlf 396 . " C (entire screen)," 397 . " c (screen-below)," 398 . " E (entire line)," 399 . " e (line-right)" 400 . $crlf . "Fill:" 401 . $crlf 402 . " @ (margin-box)," 403 . " # (prompt-char)" 404 . $crlf 405 . "Move cursor:\r\n" 406 . " h,j,k,l (vi-like)," 407 . " H (to home)." 408 . $crlf 409 . "Set margin using current position:" 410 . $crlf 411 . " T (top)," 412 . " B (bottom)," 413 . " L (left)," 414 . " R (right)" 415 . $crlf 416 . "Reset modes" 417 . $crlf 418 . " M (margins)" 419 . $crlf 420 . "Toggle modes" 421 . $crlf 422 . " A (alternate-screen)," 423 . " O (origin-mode)" 424 . " | (left/right-mode)" 425 . $crlf 426 . "Print sample:" 427 . " form-feed (repaint)"; 428 } 429 elsif ( $cmd eq "\033" ) { 430 431 # try to ignore special-keys 432 my $count = 0; 433 while (1) { 434 $cmd = ReadKey 0; 435 $count++; 436 next if ( $count == 1 and $cmd eq "O" ); 437 next unless ( $cmd =~ /^[A-~]$/ ); 438 $cmd = ReadKey 0; 439 last; 440 } 441 } 442 elsif ( $cmd eq "q" ) { 443 last; 444 } 445 elsif ( index( "CcEe@#hjklHMTBLRAO|\f", $cmd ) >= 0 ) { 446 my $was_dirty = $dirty; 447 &repaint(1) if ( $dirty != 0 ); 448 if ( $cmd eq "C" ) { 449 &home; 450 &erase_display("2"); 451 } 452 elsif ( $cmd eq "c" ) { 453 &erase_display(""); 454 } 455 elsif ( $cmd eq "E" ) { 456 &erase_line("2"); 457 } 458 elsif ( $cmd eq "e" ) { 459 &erase_line(""); 460 } 461 elsif ( $cmd eq "@" ) { 462 463 # FIXME 464 } 465 elsif ( $cmd eq "#" ) { 466 $text_sample = ReadKey 0; 467 if ( $text_filler ne "" ) { 468 my $save_filler = $text_filler; 469 $text_filler =~ s/[^\d\s]/$text_sample/g; 470 &repaint(0); 471 $text_filler = $save_filler; 472 } 473 else { 474 &repaint(0); 475 } 476 } 477 elsif ( $cmd eq "h" ) { 478 $pos_x = &next_x( $pos_x - 1 ); 479 &move; 480 } 481 elsif ( $cmd eq "j" ) { 482 $pos_y = &next_y( $pos_y + 1 ); 483 &move; 484 } 485 elsif ( $cmd eq "k" ) { 486 $pos_y = &next_y( $pos_y - 1 ); 487 &move; 488 } 489 elsif ( $cmd eq "l" ) { 490 $pos_x = &next_x( $pos_x + 1 ); 491 &move; 492 } 493 elsif ( $cmd eq "H" ) { 494 &home; 495 } 496 elsif ( $cmd eq "M" ) { 497 &set_tb_margins( -1, -1 ); 498 &set_lr_margins( -1, -1 ); 499 &repaint(0); 500 } 501 elsif ( $cmd eq "T" ) { 502 &set_tb_margins( $pos_y, $margins{B} ); 503 } 504 elsif ( $cmd eq "B" ) { 505 &set_tb_margins( $margins{T}, $pos_y ); 506 } 507 elsif ( $cmd eq "L" ) { 508 &set_lr_margins( $pos_x, $margins{R} ); 509 } 510 elsif ( $cmd eq "R" ) { 511 &set_lr_margins( $margins{L}, $pos_x ); 512 } 513 elsif ( $cmd eq "A" ) { 514 &set_screen_mode( &toggle($mode_screen) ); 515 &repaint(1); 516 } 517 elsif ( $cmd eq "O" ) { 518 &set_origin_mode( &toggle($mode_origin) ); 519 } 520 elsif ( $cmd eq "|" ) { 521 &set_margin_mode( &toggle($mode_margin) ); 522 } 523 elsif ( $cmd eq "\f" ) { 524 &repaint(1) unless ($was_dirty); 525 } 526 else { 527 &beep; 528 $dirty = 2; 529 } 530 } 531 else { 532 &beep; 533 } 534} 535 536&cleanup; 537printf " ...quit\r\n"; 538 5391; 540