"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/xtra-scroll.pl" (3 Sep 2021, 14099 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 "xtra-scroll.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: xtra-scroll.pl,v 1.12 2021/09/03 18:34:50 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2021 by Thomas E. Dickey
7 #
8 # All Rights Reserved
9 #
10 # Permission is hereby granted, free of charge, to any person obtaining a
11 # copy of this software and associated documentation files (the
12 # "Software"), to deal in the Software without restriction, including
13 # without limitation the rights to use, copy, modify, merge, publish,
14 # distribute, sublicense, and/or sell copies of the Software, and to
15 # permit persons to whom the Software is furnished to do so, subject to
16 # the following conditions:
17 #
18 # The above copyright notice and this permission notice shall be included
19 # in all copies or substantial portions of the Software.
20 #
21 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
22 # OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24 # IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
25 # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26 # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27 # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
28 #
29 # Except as contained in this notice, the name(s) of the above copyright
30 # holders shall not be used in advertising or otherwise to promote the
31 # sale, use or other dealings in this Software without prior written
32 # authorization.
33 # -----------------------------------------------------------------------------
34 # Interactively test screen-updates which can exercise the cdXtraScroll and
35 # tiXtraScroll features.
36
37 use strict;
38 use warnings;
39
40 use Getopt::Std;
41 use Term::ReadKey;
42 use I18N::Langinfo qw(langinfo CODESET);
43
44 $! = 1;
45
46 our $target = "";
47
48 our $encoding = lc( langinfo( CODESET() ) );
49 our ($opt_8);
50
51 our $dirty = 1; # nonzero if the screen should be painted
52 our $mode_margin = 0; # nonzero if left/right margin mode enabled
53 our $mode_origin = 0; # nonzero if origin-mode in effect
54 our $mode_screen = 0; # nonzero if using alternate screen
55 our $pos_x = 0; # current cursor-Y, absolute
56 our $pos_y = 0; # current cursor-X, absolute
57 our $term_high; # terminal's height
58 our $term_wide; # terminal's width
59 our $CSI = "\x1b[";
60 our $crlf = "\r\n";
61 our $text_sample = "THE QUICK BROWN FOX JUMPED OVER THE LAZY DOG ";
62 our $text_filler = "";
63 our %margins;
64
65 sub raw() {
66 ReadMode 'ultra-raw', 'STDIN'; # allow single-character inputs
67 }
68
69 sub cooked() {
70 ReadMode 'normal';
71 }
72
73 sub utf8_sample() {
74 my $text = "";
75 for my $n ( 0 .. length($text_sample) ) {
76 my $chr = substr( $text_sample, $n, 1 );
77 if ( $chr eq " " ) {
78 $chr = " ";
79 }
80 elsif ( ord($chr) < 32 ) {
81
82 # leave control characters as-is
83 }
84 else {
85 $chr = chr( 0xff00 + ord($chr) - 32 );
86 }
87 $text .= $chr;
88 }
89 return $text;
90 }
91
92 sub next_x($) {
93 my $value = shift;
94 if ($mode_margin) {
95 $value = $margins{R} if ( $value < $margins{R} );
96 $value = $margins{L} if ( $value > $margins{L} );
97 }
98 else {
99 $value = $value % $term_wide;
100 }
101 return $value;
102 }
103
104 sub next_y($) {
105 my $value = shift;
106 if ($mode_origin) {
107 $value = $margins{B} if ( $value < $margins{T} );
108 $value = $margins{T} if ( $value > $margins{B} );
109 }
110 else {
111 $value = $value % $term_high;
112 }
113 return $value;
114 }
115
116 sub move() {
117 my $y = $pos_y;
118 if ($mode_origin) {
119 my $min_y = ( $margins{T} >= 0 ) ? $margins{T} : 0;
120 my $two_y = $min_y + 1; # scrolling region is at least 2 lines
121 my $max_y = ( $margins{B} >= $two_y ) ? $margins{B} : $two_y;
122 $y = $max_y if ( $y > $max_y );
123 $y -= $min_y; # convert to relative ordinate
124 }
125 $y = 0 if ( $y < 0 );
126 printf STDERR "%s%d;%dH", $CSI, 1 + $y, 1 + $pos_x;
127 }
128
129 sub home() {
130 printf STDERR "%sH", $CSI;
131 $pos_x = 0;
132 $pos_y = 0;
133 &move;
134 }
135
136 sub erase_display($) {
137 my $mode = shift;
138 printf STDERR "%s%sJ", $CSI, $mode;
139 }
140
141 sub erase_line($) {
142 my $mode = shift;
143 printf STDERR "%s%sK", $CSI, $mode;
144 }
145
146 sub toggle($) {
147 my $value = shift;
148 return ( $value == 0 ) ? 1 : 0;
149 }
150
151 ################################################################################
152
153 sub set_margin_mode($) {
154 my $mode = shift;
155 printf STDERR "%s?69%s", $CSI, ( $mode == 0 ) ? "l" : "h";
156 $mode_margin = $mode;
157 }
158
159 ################################################################################
160
161 sub set_origin_mode($) {
162 my $mode = shift;
163 printf STDERR "%s?6%s", $CSI, ( $mode == 0 ) ? "l" : "h";
164 $mode_origin = $mode;
165 }
166
167 ################################################################################
168
169 sub set_screen_mode($) {
170 my $mode = shift;
171 printf STDERR "%s?1049%s", $CSI, ( $mode == 0 ) ? "l" : "h";
172 $mode_screen = $mode;
173 }
174
175 ################################################################################
176
177 sub do_tb_margins($$) {
178 my $param_T = "";
179 my $param_B = "";
180 $param_T = sprintf( "%d", 1 + $margins{T} ) if ( $margins{T} >= 0 );
181 $param_B = sprintf( "%d", 1 + $margins{B} )
182 if ( $margins{B} > $margins{T} );
183 printf STDERR "%s%s;%sr", $CSI, $param_T, $param_B;
184 &move;
185 }
186
187 sub undo_tb_margins() {
188 &do_tb_margins( -1, -1 );
189 }
190
191 sub redo_tb_margins() {
192 &do_tb_margins( $margins{T}, $margins{B} );
193 }
194
195 sub set_tb_margins($$) {
196 my $reset = ( not defined $margins{T} or not defined $margins{B} ) ? 1 : 0;
197 my $old_T = 1;
198 my $old_B = $term_high;
199 $old_T = $margins{T} if ( defined $margins{T} );
200 $old_B = $margins{B} if ( defined $margins{B} );
201 $margins{T} = shift;
202 $margins{B} = shift;
203 if ( $reset == 0 ) {
204 $reset = 1 if ( $old_T != $margins{T} );
205 $reset = 1 if ( $old_B != $margins{B} );
206 }
207 &redo_tb_margins if ( $reset == 1 );
208 }
209
210 ################################################################################
211
212 sub do_lr_margins($$) {
213 my $param_L = "";
214 my $param_R = "";
215 $param_L = sprintf( "%d", 1 + $margins{L} ) if ( $margins{L} >= 0 );
216 $param_R = sprintf( "%d", 1 + $margins{R} )
217 if ( $margins{R} > $margins{T} );
218 printf STDERR "%s%s;%ss", $CSI, $param_L, $param_R;
219 &move;
220 }
221
222 sub undo_lr_margins() {
223 &do_lr_margins( -1, -1 );
224 }
225
226 sub redo_lr_margins() {
227 &do_lr_margins( $margins{L}, $margins{R} );
228 }
229
230 sub set_lr_margins($$) {
231 my $reset = ( not defined $margins{L} or not defined $margins{R} ) ? 1 : 0;
232 my $old_L = 1;
233 my $old_R = $term_high;
234 $old_L = $margins{L} if ( defined $margins{L} );
235 $old_R = $margins{R} if ( defined $margins{R} );
236 $margins{L} = shift;
237 $margins{R} = shift;
238 if ( $reset == 0 ) {
239 $reset = 1 if ( $old_L != $margins{L} );
240 $reset = 1 if ( $old_R != $margins{R} );
241 }
242 &redo_lr_margins if ( $reset == 1 );
243 }
244
245 ################################################################################
246
247 sub has_tb_margins() {
248 my $result = 0;
249 $result = 1 if ( $margins{T} != 1 );
250 $result = 1 if ( $margins{B} != $term_high );
251 return $result;
252 }
253
254 sub repaint($) {
255 my $erase = shift;
256 my $save_x = $pos_x;
257 my $save_y = $pos_y;
258 $dirty = 0;
259 if ($erase) {
260 &home;
261 &erase_display(2);
262 }
263 if ( $text_filler ne "" ) {
264 if ( $mode_origin and &has_tb_margins ) {
265 my @rows = split /$crlf/, $text_filler;
266 for my $row ( 0 .. $#rows ) {
267 next unless ( $row >= $margins{T} );
268 next unless ( $row <= $margins{B} );
269 printf STDERR "%s$crlf", $rows[$row];
270 }
271 }
272 else {
273 printf STDERR "%s$crlf", $text_filler;
274 }
275 }
276 else {
277 my $cells = 0;
278 my $limit = $term_high * $term_wide;
279 while ( $cells < $limit ) {
280 my $sample = ( $encoding eq "utf-8" ) ? &utf8_sample : $text_sample;
281 printf STDERR "%s", $sample;
282 $cells += length($sample);
283 }
284 }
285 $pos_x = $save_x;
286 $pos_y = $save_y;
287 &move;
288 }
289
290 sub initialize() {
291 if ( $encoding eq "utf-8" ) {
292 binmode( STDOUT, ":utf8" );
293 binmode( STDERR, ":utf8" );
294 }
295 if ($opt_8) {
296 if ( $encoding eq "utf-8" ) {
297 undef $opt_8;
298 printf "...ignoring -8 option since locale uses %s\n", $encoding;
299 }
300 else {
301 printf STDERR "\x1b G";
302 $CSI = "\x9b";
303 }
304 }
305
306 &raw;
307
308 my @term_size = GetTerminalSize( \*STDERR );
309 $term_wide = 80;
310 $term_wide = $term_size[0] if ( $#term_size >= 0 );
311 $term_wide = 80 if ( $term_wide <= 0 );
312 $term_high = 24;
313 $term_high = $term_size[1] if ( $#term_size >= 1 );
314 $term_high = 24 if ( $term_high <= 0 );
315
316 &set_margin_mode(0);
317 &set_origin_mode(0);
318 &set_screen_mode(0);
319
320 &set_tb_margins( -1, -1 );
321 &set_lr_margins( 1, $term_wide );
322
323 &home;
324 &erase_display("2");
325 }
326
327 sub cleanup() {
328 &cooked;
329
330 printf STDERR "\x1b F" if ($opt_8);
331
332 &set_margin_mode(0);
333 &set_origin_mode(0);
334 &set_screen_mode(0);
335
336 &undo_tb_margins;
337
338 $pos_x = 1;
339 $pos_y = $term_high - 2;
340 &move;
341 &erase_display("");
342 }
343
344 sub beep() {
345 printf STDERR "\a";
346 }
347
348 sub main::HELP_MESSAGE() {
349 printf STDERR <<EOF
350 Usage: $0 [options] [datafile]
351 Options:
352 -8 use 8-bit controls
353 EOF
354 ;
355 exit 1;
356 }
357
358 $Getopt::Std::STANDARD_HELP_VERSION = 1;
359 &getopts('8') || &main::HELP_MESSAGE;
360 $#ARGV <= 0 || &main::HELP_MESSAGE;
361
362 # provide for reading file containing text to repaint
363 if ( $#ARGV == 0 ) {
364 if ( open( FP, $ARGV[0] ) ) {
365 my @lines = <FP>;
366 chomp @lines;
367 close FP;
368 $text_filler = join( $crlf, @lines );
369 }
370 }
371
372 printf "encoding $encoding\n";
373
374 &initialize();
375
376 while (1) {
377 my $cmd;
378
379 printf "\r\nCommand (? for help):" if ( $dirty != 0 );
380 $cmd = ReadKey 0;
381 if ( not $cmd ) {
382 sleep 1;
383 }
384 elsif ( $cmd eq "?" ) {
385 $dirty = 1;
386 &home;
387 &erase_display(2);
388 printf $crlf
389 . "General:"
390 . $crlf
391 . " ? (help),"
392 . " q (quit)"
393 . $crlf
394 . "Clear:"
395 . $crlf
396 . " C (entire screen),"
397 . " c (screen-below),"
398 . " E (entire line),"
399 . " e (line-right)"
400 . $crlf . "Fill:"
401 . $crlf
402 . " @ (margin-box),"
403 . " # (prompt-char)"
404 . $crlf
405 . "Move cursor:\r\n"
406 . " h,j,k,l (vi-like),"
407 . " H (to home)."
408 . $crlf
409 . "Set margin using current position:"
410 . $crlf
411 . " T (top),"
412 . " B (bottom),"
413 . " L (left),"
414 . " R (right)"
415 . $crlf
416 . "Reset modes"
417 . $crlf
418 . " M (margins)"
419 . $crlf
420 . "Toggle modes"
421 . $crlf
422 . " A (alternate-screen),"
423 . " O (origin-mode)"
424 . " | (left/right-mode)"
425 . $crlf
426 . "Print sample:"
427 . " form-feed (repaint)";
428 }
429 elsif ( $cmd eq "\033" ) {
430
431 # try to ignore special-keys
432 my $count = 0;
433 while (1) {
434 $cmd = ReadKey 0;
435 $count++;
436 next if ( $count == 1 and $cmd eq "O" );
437 next unless ( $cmd =~ /^[A-~]$/ );
438 $cmd = ReadKey 0;
439 last;
440 }
441 }
442 elsif ( $cmd eq "q" ) {
443 last;
444 }
445 elsif ( index( "CcEe@#hjklHMTBLRAO|\f", $cmd ) >= 0 ) {
446 my $was_dirty = $dirty;
447 &repaint(1) if ( $dirty != 0 );
448 if ( $cmd eq "C" ) {
449 &home;
450 &erase_display("2");
451 }
452 elsif ( $cmd eq "c" ) {
453 &erase_display("");
454 }
455 elsif ( $cmd eq "E" ) {
456 &erase_line("2");
457 }
458 elsif ( $cmd eq "e" ) {
459 &erase_line("");
460 }
461 elsif ( $cmd eq "@" ) {
462
463 # FIXME
464 }
465 elsif ( $cmd eq "#" ) {
466 $text_sample = ReadKey 0;
467 if ( $text_filler ne "" ) {
468 my $save_filler = $text_filler;
469 $text_filler =~ s/[^\d\s]/$text_sample/g;
470 &repaint(0);
471 $text_filler = $save_filler;
472 }
473 else {
474 &repaint(0);
475 }
476 }
477 elsif ( $cmd eq "h" ) {
478 $pos_x = &next_x( $pos_x - 1 );
479 &move;
480 }
481 elsif ( $cmd eq "j" ) {
482 $pos_y = &next_y( $pos_y + 1 );
483 &move;
484 }
485 elsif ( $cmd eq "k" ) {
486 $pos_y = &next_y( $pos_y - 1 );
487 &move;
488 }
489 elsif ( $cmd eq "l" ) {
490 $pos_x = &next_x( $pos_x + 1 );
491 &move;
492 }
493 elsif ( $cmd eq "H" ) {
494 &home;
495 }
496 elsif ( $cmd eq "M" ) {
497 &set_tb_margins( -1, -1 );
498 &set_lr_margins( -1, -1 );
499 &repaint(0);
500 }
501 elsif ( $cmd eq "T" ) {
502 &set_tb_margins( $pos_y, $margins{B} );
503 }
504 elsif ( $cmd eq "B" ) {
505 &set_tb_margins( $margins{T}, $pos_y );
506 }
507 elsif ( $cmd eq "L" ) {
508 &set_lr_margins( $pos_x, $margins{R} );
509 }
510 elsif ( $cmd eq "R" ) {
511 &set_lr_margins( $margins{L}, $pos_x );
512 }
513 elsif ( $cmd eq "A" ) {
514 &set_screen_mode( &toggle($mode_screen) );
515 &repaint(1);
516 }
517 elsif ( $cmd eq "O" ) {
518 &set_origin_mode( &toggle($mode_origin) );
519 }
520 elsif ( $cmd eq "|" ) {
521 &set_margin_mode( &toggle($mode_margin) );
522 }
523 elsif ( $cmd eq "\f" ) {
524 &repaint(1) unless ($was_dirty);
525 }
526 else {
527 &beep;
528 $dirty = 2;
529 }
530 }
531 else {
532 &beep;
533 }
534 }
535
536 &cleanup;
537 printf " ...quit\r\n";
538
539 1;