1#!/usr/bin/env perl
2# $XTermId: lrmm-scroll.pl,v 1.14 2022/10/10 17:07:48 tom Exp $
3# -----------------------------------------------------------------------------
4# Copyright 2019,2022 by Thomas E. Dickey
5#
6#                         All Rights Reserved
7#
8# Permission is hereby granted, free of charge, to any person obtaining a
9# copy of this software and associated documentation files (the
10# "Software"), to deal in the Software without restriction, including
11# without limitation the rights to use, copy, modify, merge, publish,
12# distribute, sublicense, and/or sell copies of the Software, and to
13# permit persons to whom the Software is furnished to do so, subject to
14# the following conditions:
15#
16# The above copyright notice and this permission notice shall be included
17# in all copies or substantial portions of the Software.
18#
19# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
20# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
22# IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
23# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
24# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
25# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
26#
27# Except as contained in this notice, the name(s) of the above copyright
28# holders shall not be used in advertising or otherwise to promote the
29# sale, use or other dealings in this Software without prior written
30# authorization.
31# -----------------------------------------------------------------------------
32# Tests scroll left/right feature in xterm, optionally using margins.  This
33# applies only to the visible screen (saved-lines are unaffected).
34#
35
36use warnings;
37use strict;
38use diagnostics;
39
40use Term::ReadKey;
41use Getopt::Std;
42
43# do this so output from successive calls to this script won't get in the
44# wrong order:
45use IO::Handle;
46STDERR->autoflush(1);
47STDOUT->autoflush(1);
48
49our ( $opt_8, $opt_c, $opt_l, $opt_o, $opt_r, $opt_s, $opt_w, $opt_x );
50our ( $margins, $test_state, $test_string, $test_width );
51our ( $term_height, $term_width );
52
53our $CSI = "\033[";
54
55our @resize;
56
57sub read_resize($) {
58    my $field  = shift;
59    my $result = shift;
60    if ( $#resize < 0 ) {
61        open( FP, "resize -u |" ) or exit $!;
62        @resize = <FP>;
63        chomp @resize;
64        close(FP);
65    }
66    for my $n ( 0 .. $#resize ) {
67        if ( $resize[$n] =~ /^$field=/ ) {
68            $result = $resize[$n];
69            $result =~ s/^[^=]*=//;
70            $result =~ s/;.*//;
71            last;
72        }
73    }
74    return $result;
75}
76
77# returns the number of rows in the screen
78sub screen_height() {
79    return &read_resize( "LINES", 24 );
80}
81
82# returns the number of columns in the screen
83sub screen_width() {
84    return &read_resize( "COLUMNS", 80 );
85}
86
87sub set_color($) {
88    my $code = shift;
89    if ( defined($opt_c) ) {
90        if ( $code == 3 ) {
91            printf "%s1;33;42m", $CSI;    # yellow-on-green
92        }
93        elsif ( $code == 2 ) {
94            printf "%s0;31;45m", $CSI;    # red-on-magenta
95        }
96        elsif ( $code == 1 ) {
97            printf "%s0;36;44m", $CSI;    # cyan-on-blue
98        }
99        else {
100            printf "%s0;39;49m", $CSI;
101        }
102    }
103}
104
105# returns a string of two-column characters given an ASCII alpha/numeric string
106sub double_cells($) {
107    my $value = $_[0];
108    $value =~ s/ /  /g;
109    pack(
110        "U*",
111        map {
112            ( $_ <= 32 || $_ > 127 )    # if non-ASCII character...
113              ? 32                      # ...just show a blank
114              : ( 0xff00 + ( $_ - 32 ) )    # map to "Fullwidth Form"
115        } unpack( "C*", $value )
116    );                                      # unpack unsigned-char characters
117}
118
119sub clear_screen() {
120    &upper_left;
121    printf "%sJ", $CSI;
122}
123
124sub clr_to_eol() {
125    printf "%sK", $CSI;
126}
127
128sub lower_left() {
129    printf "%s%dH", $CSI, $term_height;
130}
131
132sub upper_left() {
133    printf "%sH", $CSI;
134}
135
136sub move_to($) {
137    my $value = shift;
138    $value += ( $opt_l - 1 ) if ( $margins and not $opt_o );
139    printf "%s%dG", $CSI, $value + 1;
140}
141
142sub bak_scroll($) {
143    my $value = shift;
144
145    if ($value) {
146        printf "%s%dS", $CSI, $value;
147    }
148    else {
149        printf "%sS", $CSI;
150    }
151}
152
153sub delete_char() {
154    &set_color(2);
155    printf "%s%dP", $CSI, 1;
156    &set_color(1);
157}
158
159sub insert_once($) {
160    my $value = shift;
161    &set_color(2);
162    printf "%s%d@", $CSI, length($value);
163    &write_chars($value);
164}
165
166sub insert_mode($) {
167    my $value = shift;
168    &set_color(2);
169    printf "%s%dP", $CSI, length($value);
170    printf "%s4h", $CSI;
171    &write_chars($value);
172    printf "%s4l", $CSI;
173}
174
175sub write_chars($) {
176    &set_color(3);
177    printf "%s", $_[0];
178    &set_color(1);
179}
180
181# vary the starting point of each line, to make a more interesting pattern
182sub starts_of($) {
183    my $value = shift;
184    if ( defined($opt_w) ) {
185
186        # 0,1,1,2,2,3,3,...
187        $value = ( ( $value + 1 ) / 2 ) % length($test_string);
188    }
189    else {
190        $value %= length($test_string);
191    }
192    return $value;
193}
194
195# write the text for the given line-number
196sub show_line($) {
197    my $number = shift;
198    my $length = $test_width;
199
200    # use delete-lines to "pull" the screen up, like scrolling.
201    select( undef, undef, undef, 0.05 ) if ($opt_s);
202    &lower_left;
203    &bak_scroll(1);
204
205    # if we're printing double-column characters, we have half as much
206    # space effectively - but don't forget the remainder, so we can push
207    # the characters by single-columns.
208    if ( defined($opt_c) ) {
209        &set_color(1);
210        printf "%s%dX", $CSI, $length if ($margins);
211        &clr_to_eol unless ($margins);
212    }
213    my $starts = &starts_of($number);
214    if ( defined($opt_w) ) {
215        printf " ", if ( ( $number % 2 ) != 0 );
216        $length = ( $length - ( ($number) % 2 ) ) / 2;
217    }
218    my $string = substr( $test_string, $starts );
219    while ( length($string) < $length ) {
220        $string = $string . $test_string;
221    }
222    $string = substr( $string, 0, $length );
223    if ( defined($opt_w) ) {
224        $string = &double_cells($string);
225    }
226    printf "%s", $string;
227
228    # now - within the line - modify it
229    if ($opt_x) {
230        &move_to( ( 4 * $test_width ) / 5 );
231        &insert_mode("XX");
232        &move_to( ( 3 * $test_width ) / 5 );
233        &delete_char;
234        &move_to( ( 2 * $test_width ) / 5 );
235        &insert_once('~');
236        &move_to( ( 1 * $test_width ) / 5 );
237        &write_chars('~');
238        &move_to(0);
239    }
240    &set_color(0);
241}
242
243sub show_pattern() {
244    &set_color(0);
245    &clear_screen;
246    for ( my $lineno = 0 ; $lineno < $term_height ; ++$lineno ) {
247        &show_line($lineno);
248    }
249}
250
251sub scroll_left($) {
252    my $value = shift;
253    printf "%s%d @", $CSI, $value;
254}
255
256sub scroll_right($) {
257    my $value = shift;
258    printf "%s%d A", $CSI, $value;
259}
260
261sub show_help() {
262    &finish_test;
263    &clear_screen;
264    printf <<EOF;
265Key assignments:\r
266\r
267?            shows this screen\r
268l, backspace scrolls left\r
269r, space     scrolls right\r
270^L           resets the scrolling\r
271q            quits the demo\r
272\r
273Press any key to continue...\r
274EOF
275    my $key = ReadKey 0;
276    &start_test;
277    &show_pattern;
278}
279
280sub start_test() {
281    &clear_screen;
282
283    printf "\x1b G" if ($opt_8);
284    if ($margins) {
285        printf "%s?6h", $CSI if ($opt_o);
286        printf "%s?69h", $CSI;
287        printf "%s%d;%ds", $CSI, $opt_l, $opt_r;
288    }
289}
290
291sub finish_test() {
292    printf "%s?6;69l", $CSI if ($margins);
293    printf "\x1b F" if ($opt_8);
294
295    &lower_left;
296    &clr_to_eol;
297}
298
299sub do_test() {
300    $test_state %= $test_width;
301
302    my $key = ReadKey 0;
303
304    &show_pattern;
305    &move_to( 0, $test_state );
306
307    my $result = 1;
308    if ( $key eq "q" or $key eq "\033" ) {
309        $result = 0;
310    }
311    elsif ( $key eq " " or $key eq "l" ) {
312        &set_color(1);
313        &scroll_left( ++$test_state );
314    }
315    elsif ( $key eq "\b" or $key eq "r" ) {
316        &set_color(1);
317        &scroll_right( ++$test_state );
318    }
319    elsif ( $key eq "?" ) {
320        &show_help;
321    }
322    elsif ( $key eq "\f" ) {
323        $test_state = 0;
324    }
325    return $result;
326}
327
328sub testit() {
329    ReadMode 'ultra-raw';
330    $test_state = 0;
331    &show_pattern;
332    do {
333    } while (&do_test);
334    ReadMode 'restore';
335    &set_color(0);
336}
337
338sub main::HELP_MESSAGE() {
339    printf STDERR <<EOF
340Usage: $0 [options]
341
342Options:
343
344-8     use 8-bit C1 controls
345-c     use color
346-l COL specify left margin
347-r COL specify right margin
348-o     enable origin-mode with margins
349-s     slow down test-setup
350-w     write wide-characters
351-x     modify test-string with inserted/deleted cells
352EOF
353      ;
354    exit 1;
355}
356
357$Getopt::Std::STANDARD_HELP_VERSION = 1;
358&getopts('8cl:or:swx') || &main::HELP_MESSAGE;
359
360$term_height = &screen_height;
361$term_width  = &screen_width;
362
363&main::HELP_MESSAGE if ( $opt_8 and $opt_w );
364$CSI     = "\x9b" if ($opt_8);
365$margins = 1      if ( $opt_l or $opt_r );
366$opt_l   = 1      if ( $margins and not $opt_l );
367$opt_r = $term_width if ( $margins and not $opt_l );
368
369$test_width = $term_width;
370$test_width = ( $opt_r - $opt_l + 1 ) if ($margins);
371
372$test_string =
373  "0123456789 abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ";
374
375binmode( STDOUT, ":utf8" ) unless ($opt_8);
376
377&start_test;
378&testit;
379&finish_test;
380
3811;
382