xref: /xsrc/external/mit/xterm/dist/vttests/xtra-scroll.pl

#!/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;