xenocara/app/xterm/vttests/xtra-scroll.pl

540 lines
14 KiB
Perl
Raw Normal View History

#!/usr/bin/env perl
# $XTermId: xtra-scroll.pl,v 1.12 2021/09/03 18:34:50 tom Exp $
# -----------------------------------------------------------------------------
# this file is part of xterm
#
# Copyright 2021 by Thomas E. Dickey
#
# All Rights Reserved
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the name(s) of the above copyright
# holders shall not be used in advertising or otherwise to promote the
# sale, use or other dealings in this Software without prior written
# authorization.
# -----------------------------------------------------------------------------
# Interactively test screen-updates which can exercise the cdXtraScroll and
# tiXtraScroll features.
use strict;
use warnings;
use Getopt::Std;
use Term::ReadKey;
use I18N::Langinfo qw(langinfo CODESET);
$! = 1;
our $target = "";
our $encoding = lc( langinfo( CODESET() ) );
our ($opt_8);
our $dirty = 1; # nonzero if the screen should be painted
our $mode_margin = 0; # nonzero if left/right margin mode enabled
our $mode_origin = 0; # nonzero if origin-mode in effect
our $mode_screen = 0; # nonzero if using alternate screen
our $pos_x = 0; # current cursor-Y, absolute
our $pos_y = 0; # current cursor-X, absolute
our $term_high; # terminal's height
our $term_wide; # terminal's width
our $CSI = "\x1b[";
our $crlf = "\r\n";
our $text_sample = "THE QUICK BROWN FOX JUMPED OVER THE LAZY DOG ";
our $text_filler = "";
our %margins;
sub raw() {
ReadMode 'ultra-raw', 'STDIN'; # allow single-character inputs
}
sub cooked() {
ReadMode 'normal';
}
sub utf8_sample() {
my $text = "";
for my $n ( 0 .. length($text_sample) ) {
my $chr = substr( $text_sample, $n, 1 );
if ( $chr eq " " ) {
$chr = " ";
}
elsif ( ord($chr) < 32 ) {
# leave control characters as-is
}
else {
$chr = chr( 0xff00 + ord($chr) - 32 );
}
$text .= $chr;
}
return $text;
}
sub next_x($) {
my $value = shift;
if ($mode_margin) {
$value = $margins{R} if ( $value < $margins{R} );
$value = $margins{L} if ( $value > $margins{L} );
}
else {
$value = $value % $term_wide;
}
return $value;
}
sub next_y($) {
my $value = shift;
if ($mode_origin) {
$value = $margins{B} if ( $value < $margins{T} );
$value = $margins{T} if ( $value > $margins{B} );
}
else {
$value = $value % $term_high;
}
return $value;
}
sub move() {
my $y = $pos_y;
if ($mode_origin) {
my $min_y = ( $margins{T} >= 0 ) ? $margins{T} : 0;
my $two_y = $min_y + 1; # scrolling region is at least 2 lines
my $max_y = ( $margins{B} >= $two_y ) ? $margins{B} : $two_y;
$y = $max_y if ( $y > $max_y );
$y -= $min_y; # convert to relative ordinate
}
$y = 0 if ( $y < 0 );
printf STDERR "%s%d;%dH", $CSI, 1 + $y, 1 + $pos_x;
}
sub home() {
printf STDERR "%sH", $CSI;
$pos_x = 0;
$pos_y = 0;
&move;
}
sub erase_display($) {
my $mode = shift;
printf STDERR "%s%sJ", $CSI, $mode;
}
sub erase_line($) {
my $mode = shift;
printf STDERR "%s%sK", $CSI, $mode;
}
sub toggle($) {
my $value = shift;
return ( $value == 0 ) ? 1 : 0;
}
################################################################################
sub set_margin_mode($) {
my $mode = shift;
printf STDERR "%s?69%s", $CSI, ( $mode == 0 ) ? "l" : "h";
$mode_margin = $mode;
}
################################################################################
sub set_origin_mode($) {
my $mode = shift;
printf STDERR "%s?6%s", $CSI, ( $mode == 0 ) ? "l" : "h";
$mode_origin = $mode;
}
################################################################################
sub set_screen_mode($) {
my $mode = shift;
printf STDERR "%s?1049%s", $CSI, ( $mode == 0 ) ? "l" : "h";
$mode_screen = $mode;
}
################################################################################
sub do_tb_margins($$) {
my $param_T = "";
my $param_B = "";
$param_T = sprintf( "%d", 1 + $margins{T} ) if ( $margins{T} >= 0 );
$param_B = sprintf( "%d", 1 + $margins{B} )
if ( $margins{B} > $margins{T} );
printf STDERR "%s%s;%sr", $CSI, $param_T, $param_B;
&move;
}
sub undo_tb_margins() {
&do_tb_margins( -1, -1 );
}
sub redo_tb_margins() {
&do_tb_margins( $margins{T}, $margins{B} );
}
sub set_tb_margins($$) {
my $reset = ( not defined $margins{T} or not defined $margins{B} ) ? 1 : 0;
my $old_T = 1;
my $old_B = $term_high;
$old_T = $margins{T} if ( defined $margins{T} );
$old_B = $margins{B} if ( defined $margins{B} );
$margins{T} = shift;
$margins{B} = shift;
if ( $reset == 0 ) {
$reset = 1 if ( $old_T != $margins{T} );
$reset = 1 if ( $old_B != $margins{B} );
}
&redo_tb_margins if ( $reset == 1 );
}
################################################################################
sub do_lr_margins($$) {
my $param_L = "";
my $param_R = "";
$param_L = sprintf( "%d", 1 + $margins{L} ) if ( $margins{L} >= 0 );
$param_R = sprintf( "%d", 1 + $margins{R} )
if ( $margins{R} > $margins{T} );
printf STDERR "%s%s;%ss", $CSI, $param_L, $param_R;
&move;
}
sub undo_lr_margins() {
&do_lr_margins( -1, -1 );
}
sub redo_lr_margins() {
&do_lr_margins( $margins{L}, $margins{R} );
}
sub set_lr_margins($$) {
my $reset = ( not defined $margins{L} or not defined $margins{R} ) ? 1 : 0;
my $old_L = 1;
my $old_R = $term_high;
$old_L = $margins{L} if ( defined $margins{L} );
$old_R = $margins{R} if ( defined $margins{R} );
$margins{L} = shift;
$margins{R} = shift;
if ( $reset == 0 ) {
$reset = 1 if ( $old_L != $margins{L} );
$reset = 1 if ( $old_R != $margins{R} );
}
&redo_lr_margins if ( $reset == 1 );
}
################################################################################
sub has_tb_margins() {
my $result = 0;
$result = 1 if ( $margins{T} != 1 );
$result = 1 if ( $margins{B} != $term_high );
return $result;
}
sub repaint($) {
my $erase = shift;
my $save_x = $pos_x;
my $save_y = $pos_y;
$dirty = 0;
if ($erase) {
&home;
&erase_display(2);
}
if ( $text_filler ne "" ) {
if ( $mode_origin and &has_tb_margins ) {
my @rows = split /$crlf/, $text_filler;
for my $row ( 0 .. $#rows ) {
next unless ( $row >= $margins{T} );
next unless ( $row <= $margins{B} );
printf STDERR "%s$crlf", $rows[$row];
}
}
else {
printf STDERR "%s$crlf", $text_filler;
}
}
else {
my $cells = 0;
my $limit = $term_high * $term_wide;
while ( $cells < $limit ) {
my $sample = ( $encoding eq "utf-8" ) ? &utf8_sample : $text_sample;
printf STDERR "%s", $sample;
$cells += length($sample);
}
}
$pos_x = $save_x;
$pos_y = $save_y;
&move;
}
sub initialize() {
if ( $encoding eq "utf-8" ) {
binmode( STDOUT, ":utf8" );
binmode( STDERR, ":utf8" );
}
if ($opt_8) {
if ( $encoding eq "utf-8" ) {
undef $opt_8;
printf "...ignoring -8 option since locale uses %s\n", $encoding;
}
else {
printf STDERR "\x1b G";
$CSI = "\x9b";
}
}
&raw;
my @term_size = GetTerminalSize( \*STDERR );
$term_wide = 80;
$term_wide = $term_size[0] if ( $#term_size >= 0 );
$term_wide = 80 if ( $term_wide <= 0 );
$term_high = 24;
$term_high = $term_size[1] if ( $#term_size >= 1 );
$term_high = 24 if ( $term_high <= 0 );
&set_margin_mode(0);
&set_origin_mode(0);
&set_screen_mode(0);
&set_tb_margins( -1, -1 );
&set_lr_margins( 1, $term_wide );
&home;
&erase_display("2");
}
sub cleanup() {
&cooked;
printf STDERR "\x1b F" if ($opt_8);
&set_margin_mode(0);
&set_origin_mode(0);
&set_screen_mode(0);
&undo_tb_margins;
$pos_x = 1;
$pos_y = $term_high - 2;
&move;
&erase_display("");
}
sub beep() {
printf STDERR "\a";
}
sub main::HELP_MESSAGE() {
printf STDERR <<EOF
Usage: $0 [options] [datafile]
Options:
-8 use 8-bit controls
EOF
;
exit 1;
}
$Getopt::Std::STANDARD_HELP_VERSION = 1;
&getopts('8') || &main::HELP_MESSAGE;
$#ARGV <= 0 || &main::HELP_MESSAGE;
# provide for reading file containing text to repaint
if ( $#ARGV == 0 ) {
if ( open( FP, $ARGV[0] ) ) {
my @lines = <FP>;
chomp @lines;
close FP;
$text_filler = join( $crlf, @lines );
}
}
printf "encoding $encoding\n";
&initialize();
while (1) {
my $cmd;
printf "\r\nCommand (? for help):" if ( $dirty != 0 );
$cmd = ReadKey 0;
if ( not $cmd ) {
sleep 1;
}
elsif ( $cmd eq "?" ) {
$dirty = 1;
&home;
&erase_display(2);
printf $crlf
. "General:"
. $crlf
. " ? (help),"
. " q (quit)"
. $crlf
. "Clear:"
. $crlf
. " C (entire screen),"
. " c (screen-below),"
. " E (entire line),"
. " e (line-right)"
. $crlf . "Fill:"
. $crlf
. " @ (margin-box),"
. " # (prompt-char)"
. $crlf
. "Move cursor:\r\n"
. " h,j,k,l (vi-like),"
. " H (to home)."
. $crlf
. "Set margin using current position:"
. $crlf
. " T (top),"
. " B (bottom),"
. " L (left),"
. " R (right)"
. $crlf
. "Reset modes"
. $crlf
. " M (margins)"
. $crlf
. "Toggle modes"
. $crlf
. " A (alternate-screen),"
. " O (origin-mode)"
. " | (left/right-mode)"
. $crlf
. "Print sample:"
. " form-feed (repaint)";
}
elsif ( $cmd eq "\033" ) {
# try to ignore special-keys
my $count = 0;
while (1) {
$cmd = ReadKey 0;
$count++;
next if ( $count == 1 and $cmd eq "O" );
next unless ( $cmd =~ /^[A-~]$/ );
$cmd = ReadKey 0;
last;
}
}
elsif ( $cmd eq "q" ) {
last;
}
elsif ( index( "CcEe@#hjklHMTBLRAO|\f", $cmd ) >= 0 ) {
my $was_dirty = $dirty;
&repaint(1) if ( $dirty != 0 );
if ( $cmd eq "C" ) {
&home;
&erase_display("2");
}
elsif ( $cmd eq "c" ) {
&erase_display("");
}
elsif ( $cmd eq "E" ) {
&erase_line("2");
}
elsif ( $cmd eq "e" ) {
&erase_line("");
}
elsif ( $cmd eq "@" ) {
# FIXME
}
elsif ( $cmd eq "#" ) {
$text_sample = ReadKey 0;
if ( $text_filler ne "" ) {
my $save_filler = $text_filler;
$text_filler =~ s/[^\d\s]/$text_sample/g;
&repaint(0);
$text_filler = $save_filler;
}
else {
&repaint(0);
}
}
elsif ( $cmd eq "h" ) {
$pos_x = &next_x( $pos_x - 1 );
&move;
}
elsif ( $cmd eq "j" ) {
$pos_y = &next_y( $pos_y + 1 );
&move;
}
elsif ( $cmd eq "k" ) {
$pos_y = &next_y( $pos_y - 1 );
&move;
}
elsif ( $cmd eq "l" ) {
$pos_x = &next_x( $pos_x + 1 );
&move;
}
elsif ( $cmd eq "H" ) {
&home;
}
elsif ( $cmd eq "M" ) {
&set_tb_margins( -1, -1 );
&set_lr_margins( -1, -1 );
&repaint(0);
}
elsif ( $cmd eq "T" ) {
&set_tb_margins( $pos_y, $margins{B} );
}
elsif ( $cmd eq "B" ) {
&set_tb_margins( $margins{T}, $pos_y );
}
elsif ( $cmd eq "L" ) {
&set_lr_margins( $pos_x, $margins{R} );
}
elsif ( $cmd eq "R" ) {
&set_lr_margins( $margins{L}, $pos_x );
}
elsif ( $cmd eq "A" ) {
&set_screen_mode( &toggle($mode_screen) );
&repaint(1);
}
elsif ( $cmd eq "O" ) {
&set_origin_mode( &toggle($mode_origin) );
}
elsif ( $cmd eq "|" ) {
&set_margin_mode( &toggle($mode_margin) );
}
elsif ( $cmd eq "\f" ) {
&repaint(1) unless ($was_dirty);
}
else {
&beep;
$dirty = 2;
}
}
else {
&beep;
}
}
&cleanup;
printf " ...quit\r\n";
1;