lrmm-scroll.pl revision a5ae21e4 
1#!/usr/bin/env perl
2# $XTermId: lrmm-scroll.pl,v 1.12 2019/07/10 08:22:48 tom Exp $
3# -----------------------------------------------------------------------------
4# Copyright 2019 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 outout 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
55# returns the number of rows in the screen
56sub screen_height() {
57    my $data = `resize -u |fgrep LINES=`;
58    $data =~ s/LINES=//;
59    $data =~ s/;//;
60    return $data;
61}
62
63# returns the number of columns in the screen
64sub screen_width() {
65    my $data = `resize -u |fgrep COLUMNS=`;
66    $data =~ s/COLUMNS=//;
67    $data =~ s/;//;
68    return $data;
69}
70
71sub set_color($) {
72    my $code = shift;
73    if ( defined($opt_c) ) {
74        if ( $code == 3 ) {
75            printf "%s1;33;42m", $CSI;    # yellow-on-green
76        }
77        elsif ( $code == 2 ) {
78            printf "%s0;31;45m", $CSI;    # red-on-magenta
79        }
80        elsif ( $code == 1 ) {
81            printf "%s0;36;44m", $CSI;    # cyan-on-blue
82        }
83        else {
84            printf "%s0;39;49m", $CSI;
85        }
86    }
87}
88
89# returns a string of two-column characters given an ASCII alpha/numeric string
90sub double_cells($) {
91    my $value = $_[0];
92    $value =~ s/ /  /g;
93    pack(
94        "U*",
95        map {
96            ( $_ <= 32 || $_ > 127 )    # if non-ASCII character...
97              ? 32                      # ...just show a blank
98              : ( 0xff00 + ( $_ - 32 ) )    # map to "Fullwidth Form"
99        } unpack( "C*", $value )
100    );                                      # unpack unsigned-char characters
101}
102
103sub clear_screen() {
104    &upper_left;
105    printf "%sJ", $CSI;
106}
107
108sub clr_to_eol() {
109    printf "%sK", $CSI;
110}
111
112sub lower_left() {
113    printf "%s%dH", $CSI, $term_height;
114}
115
116sub upper_left() {
117    printf "%sH", $CSI;
118}
119
120sub move_to($) {
121    my $value = shift;
122    $value += ( $opt_l - 1 ) if ( $margins and not $opt_o );
123    printf "%s%dG", $CSI, $value + 1;
124}
125
126sub bak_scroll($) {
127    my $value = shift;
128
129    if ($value) {
130        printf "%s%dS", $CSI, $value;
131    }
132    else {
133        printf "%sS", $CSI;
134    }
135}
136
137sub delete_char() {
138    &set_color(2);
139    printf "%s%dP", $CSI, 1;
140    &set_color(1);
141}
142
143sub insert_once($) {
144    my $value = shift;
145    &set_color(2);
146    printf "%s%d@", $CSI, length($value);
147    &write_chars($value);
148}
149
150sub insert_mode($) {
151    my $value = shift;
152    &set_color(2);
153    printf "%s%dP", $CSI, length($value);
154    printf "%s4h", $CSI;
155    &write_chars($value);
156    printf "%s4l", $CSI;
157}
158
159sub write_chars($) {
160    &set_color(3);
161    printf "%s", $_[0];
162    &set_color(1);
163}
164
165# vary the starting point of each line, to make a more interesting pattern
166sub starts_of($) {
167    my $value = shift;
168    if ( defined($opt_w) ) {
169
170        # 0,1,1,2,2,3,3,...
171        $value = ( ( $value + 1 ) / 2 ) % length($test_string);
172    }
173    else {
174        $value %= length($test_string);
175    }
176    return $value;
177}
178
179# write the text for the given line-number
180sub show_line($) {
181    my $number = shift;
182    my $length = $test_width;
183
184    # use delete-lines to "pull" the screen up, like scrolling.
185    select( undef, undef, undef, 0.05 ) if ($opt_s);
186    &lower_left;
187    &bak_scroll(1);
188
189    # if we're printing double-column characters, we have half as much
190    # space effectively - but don't forget the remainder, so we can push
191    # the characters by single-columns.
192    if ( defined($opt_c) ) {
193        &set_color(1);
194        printf "%s%dX", $CSI, $length if ($margins);
195        &clr_to_eol unless ($margins);
196    }
197    my $starts = &starts_of($number);
198    if ( defined($opt_w) ) {
199        printf " ", if ( ( $number % 2 ) != 0 );
200        $length = ( $length - ( ($number) % 2 ) ) / 2;
201    }
202    my $string = substr( $test_string, $starts );
203    while ( length($string) < $length ) {
204        $string = $string . $test_string;
205    }
206    $string = substr( $string, 0, $length );
207    if ( defined($opt_w) ) {
208        $string = &double_cells($string);
209    }
210    printf "%s", $string;
211
212    # now - within the line - modify it
213    if ($opt_x) {
214        &move_to( ( 4 * $test_width ) / 5 );
215        &insert_mode("XX");
216        &move_to( ( 3 * $test_width ) / 5 );
217        &delete_char;
218        &move_to( ( 2 * $test_width ) / 5 );
219        &insert_once('~');
220        &move_to( ( 1 * $test_width ) / 5 );
221        &write_chars('~');
222        &move_to(0);
223    }
224    &set_color(0);
225}
226
227sub show_pattern() {
228    &set_color(0);
229    &clear_screen;
230    for ( my $lineno = 0 ; $lineno < $term_height ; ++$lineno ) {
231        &show_line($lineno);
232    }
233}
234
235sub scroll_left($) {
236    my $value = shift;
237    printf "%s%d @", $CSI, $value;
238}
239
240sub scroll_right($) {
241    my $value = shift;
242    printf "%s%d A", $CSI, $value;
243}
244
245sub show_help() {
246    &finish_test;
247    &clear_screen;
248    printf <<EOF;
249Key assignments:\r
250\r
251?            shows this screen\r
252l, backspace scrolls left\r
253r, space     scrolls right\r
254^L           resets the scrolling\r
255q            quits the demo\r
256\r
257Press any key to continue...\r
258EOF
259    my $key = ReadKey 0;
260    &start_test;
261    &show_pattern;
262}
263
264sub start_test() {
265    &clear_screen;
266
267    printf "\x1b G" if ($opt_8);
268    if ($margins) {
269        printf "%s?6h", $CSI if ($opt_o);
270        printf "%s?69h", $CSI;
271        printf "%s%d;%ds", $CSI, $opt_l, $opt_r;
272    }
273}
274
275sub finish_test() {
276    printf "%s?6;69l", $CSI if ($margins);
277    printf "\x1b F" if ($opt_8);
278
279    &lower_left;
280    &clr_to_eol;
281}
282
283sub do_test() {
284    $test_state %= $test_width;
285
286    my $key = ReadKey 0;
287
288    &show_pattern;
289    &move_to( 0, $test_state );
290
291    my $result = 1;
292    if ( $key eq "q" or $key eq "\033" ) {
293        $result = 0;
294    }
295    elsif ( $key eq " " or $key eq "l" ) {
296        &set_color(1);
297        &scroll_left( ++$test_state );
298    }
299    elsif ( $key eq "\b" or $key eq "r" ) {
300        &set_color(1);
301        &scroll_right( ++$test_state );
302    }
303    elsif ( $key eq "?" ) {
304        &show_help;
305    }
306    elsif ( $key eq "\f" ) {
307        $test_state = 0;
308    }
309    return $result;
310}
311
312sub testit() {
313    ReadMode 'ultra-raw';
314    $test_state = 0;
315    &show_pattern;
316    do {
317    } while (&do_test);
318    ReadMode 'restore';
319    &set_color(0);
320}
321
322sub main::HELP_MESSAGE() {
323    printf STDERR <<EOF
324Usage: $0 [options]
325
326Options:
327
328-8     use 8-bit C1 controls
329-c     use color
330-l COL specify left margin
331-r COL specify right margin
332-o     enable origin-mode with margins
333-s     slow down test-setup
334-w     write wide-characters
335-x     modify test-string with inserted/deleted cells
336EOF
337      ;
338    exit 1;
339}
340
341$Getopt::Std::STANDARD_HELP_VERSION = 1;
342&getopts('8cl:or:swx') || &main::HELP_MESSAGE;
343
344$term_height = &screen_height;
345$term_width  = &screen_width;
346
347&main::HELP_MESSAGE if ( $opt_8 and $opt_w );
348$CSI     = "\x9b" if ($opt_8);
349$margins = 1      if ( $opt_l or $opt_r );
350$opt_l   = 1      if ( $margins and not $opt_l );
351$opt_r = $term_width if ( $margins and not $opt_l );
352
353$test_width = $term_width;
354$test_width = ( $opt_r - $opt_l + 1 ) if ($margins);
355
356$test_string =
357  "0123456789 abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ";
358
359binmode( STDOUT, ":utf8" ) unless ($opt_8);
360
361&start_test;
362&testit;
363&finish_test;
364
3651;
366