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
37use strict;
38use warnings;
39
40use Getopt::Std;
41use Term::ReadKey;
42use I18N::Langinfo qw(langinfo CODESET);
43
44$! = 1;
45
46our $target = "";
47
48our $encoding = lc( langinfo( CODESET() ) );
49our ($opt_8);
50
51our $dirty       = 1;    # nonzero if the screen should be painted
52our $mode_margin = 0;    # nonzero if left/right margin mode enabled
53our $mode_origin = 0;    # nonzero if origin-mode in effect
54our $mode_screen = 0;    # nonzero if using alternate screen
55our $pos_x       = 0;    # current cursor-Y, absolute
56our $pos_y       = 0;    # current cursor-X, absolute
57our $term_high;          # terminal's height
58our $term_wide;          # terminal's width
59our $CSI         = "\x1b[";
60our $crlf        = "\r\n";
61our $text_sample = "THE QUICK BROWN FOX JUMPED OVER THE LAZY DOG ";
62our $text_filler = "";
63our %margins;
64
65sub raw() {
66    ReadMode 'ultra-raw', 'STDIN';    # allow single-character inputs
67}
68
69sub cooked() {
70    ReadMode 'normal';
71}
72
73sub 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
92sub 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
104sub 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
116sub 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
129sub home() {
130    printf STDERR "%sH", $CSI;
131    $pos_x = 0;
132    $pos_y = 0;
133    &move;
134}
135
136sub erase_display($) {
137    my $mode = shift;
138    printf STDERR "%s%sJ", $CSI, $mode;
139}
140
141sub erase_line($) {
142    my $mode = shift;
143    printf STDERR "%s%sK", $CSI, $mode;
144}
145
146sub toggle($) {
147    my $value = shift;
148    return ( $value == 0 ) ? 1 : 0;
149}
150
151################################################################################
152
153sub 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
161sub 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
169sub 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
177sub 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
187sub undo_tb_margins() {
188    &do_tb_margins( -1, -1 );
189}
190
191sub redo_tb_margins() {
192    &do_tb_margins( $margins{T}, $margins{B} );
193}
194
195sub 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
212sub 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
222sub undo_lr_margins() {
223    &do_lr_margins( -1, -1 );
224}
225
226sub redo_lr_margins() {
227    &do_lr_margins( $margins{L}, $margins{R} );
228}
229
230sub 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
247sub 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
254sub 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
290sub 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
327sub 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
344sub beep() {
345    printf STDERR "\a";
346}
347
348sub main::HELP_MESSAGE() {
349    printf STDERR <<EOF
350Usage: $0 [options] [datafile]
351Options:
352  -8      use 8-bit controls
353EOF
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
363if ( $#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
372printf "encoding $encoding\n";
373
374&initialize();
375
376while (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;
537printf " ...quit\r\n";
538
5391;
540