"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/lrmm-scroll.pl" (10 Oct 2022, 9377 Bytes) of package /linux/misc/xterm-379.tgz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "lrmm-scroll.pl" see the
Fossies "Dox" file reference documentation and the last
Fossies "Diffs" side-by-side code changes report:
373_vs_374.
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
36 use warnings;
37 use strict;
38 use diagnostics;
39
40 use Term::ReadKey;
41 use Getopt::Std;
42
43 # do this so output from successive calls to this script won't get in the
44 # wrong order:
45 use IO::Handle;
46 STDERR->autoflush(1);
47 STDOUT->autoflush(1);
48
49 our ( $opt_8, $opt_c, $opt_l, $opt_o, $opt_r, $opt_s, $opt_w, $opt_x );
50 our ( $margins, $test_state, $test_string, $test_width );
51 our ( $term_height, $term_width );
52
53 our $CSI = "\033[";
54
55 our @resize;
56
57 sub 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
78 sub screen_height() {
79 return &read_resize( "LINES", 24 );
80 }
81
82 # returns the number of columns in the screen
83 sub screen_width() {
84 return &read_resize( "COLUMNS", 80 );
85 }
86
87 sub 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
106 sub 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
119 sub clear_screen() {
120 &upper_left;
121 printf "%sJ", $CSI;
122 }
123
124 sub clr_to_eol() {
125 printf "%sK", $CSI;
126 }
127
128 sub lower_left() {
129 printf "%s%dH", $CSI, $term_height;
130 }
131
132 sub upper_left() {
133 printf "%sH", $CSI;
134 }
135
136 sub 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
142 sub 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
153 sub delete_char() {
154 &set_color(2);
155 printf "%s%dP", $CSI, 1;
156 &set_color(1);
157 }
158
159 sub insert_once($) {
160 my $value = shift;
161 &set_color(2);
162 printf "%s%d@", $CSI, length($value);
163 &write_chars($value);
164 }
165
166 sub 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
175 sub 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
182 sub 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
196 sub 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
243 sub 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
251 sub scroll_left($) {
252 my $value = shift;
253 printf "%s%d @", $CSI, $value;
254 }
255
256 sub scroll_right($) {
257 my $value = shift;
258 printf "%s%d A", $CSI, $value;
259 }
260
261 sub show_help() {
262 &finish_test;
263 &clear_screen;
264 printf <<EOF;
265 Key assignments:\r
266 \r
267 ? shows this screen\r
268 l, backspace scrolls left\r
269 r, space scrolls right\r
270 ^L resets the scrolling\r
271 q quits the demo\r
272 \r
273 Press any key to continue...\r
274 EOF
275 my $key = ReadKey 0;
276 &start_test;
277 &show_pattern;
278 }
279
280 sub 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
291 sub 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
299 sub 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
328 sub 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
338 sub main::HELP_MESSAGE() {
339 printf STDERR <<EOF
340 Usage: $0 [options]
341
342 Options:
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
352 EOF
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
375 binmode( STDOUT, ":utf8" ) unless ($opt_8);
376
377 &start_test;
378 &testit;
379 &finish_test;
380
381 1;