"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/scroll.pl" (10 Oct 2022, 7315 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 "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: scroll.pl,v 1.4 2022/10/10 17:02:54 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2009,2022 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 # Tests insert/delete-line feature in xterm. This applies only to the
35 # visible screen (saved-lines are unaffected).
36 #
37 # TODO:
38 # add option to wrap the test-pattern
39 # use scrolling-margins to help fill-in a chunk
40 use strict;
41 use warnings;
42
43 use Getopt::Std;
44
45 # do this so output from successive calls to this script won't get in the
46 # wrong order:
47 use IO::Handle;
48 STDERR->autoflush(1);
49 STDOUT->autoflush(1);
50
51 our ( $opt_c, $opt_n, $opt_r, $opt_w );
52 our ( $lineno, $test_string, $term_height, $term_width, $max_scroll );
53
54 our @resize;
55
56 sub read_resize($) {
57 my $field = shift;
58 my $result = shift;
59 if ( $#resize < 0 ) {
60 open( FP, "resize -u |" ) or exit $!;
61 @resize = <FP>;
62 chomp @resize;
63 close(FP);
64 }
65 for my $n ( 0 .. $#resize ) {
66 if ( $resize[$n] =~ /^$field=/ ) {
67 $result = $resize[$n];
68 $result =~ s/^[^=]*=//;
69 $result =~ s/;.*//;
70 last;
71 }
72 }
73 return $result;
74 }
75
76 # returns the number of rows in the screen
77 sub screen_height() {
78 return &read_resize( "LINES", 24 );
79 }
80
81 # returns the number of columns in the screen
82 sub screen_width() {
83 return &read_resize( "COLUMNS", 80 );
84 }
85
86 sub set_color($) {
87 my $code = $_[0];
88 if ( defined($opt_c) ) {
89 if ( $code == 3 ) {
90 printf "\x1b[1;33;42m"; # yellow-on-green
91 }
92 elsif ( $code == 2 ) {
93 printf "\x1b[0;31;45m"; # red-on-magenta
94 }
95 elsif ( $code == 1 ) {
96 printf "\x1b[0;36;44m"; # cyan-on-blue
97 }
98 else {
99 printf "\x1b[0;39;49m";
100 }
101 }
102 }
103
104 # returns a string of two-column characters given an ASCII alpha/numeric string
105 sub double_cells($) {
106 my $value = $_[0];
107 $value =~ s/ / /g;
108 pack(
109 "U*",
110 map {
111 ( $_ <= 32 || $_ > 127 ) # if non-ASCII character...
112 ? 32 # ...just show a blank
113 : ( 0xff00 + ( $_ - 32 ) ) # map to "Fullwidth Form"
114 } unpack( "C*", $value )
115 ); # unpack unsigned-char characters
116 }
117
118 sub clear_screen() {
119 upper_left();
120 printf "\x1b[J";
121 }
122
123 sub clr_to_eol() {
124 printf "\x1b[K";
125 }
126
127 sub lower_left() {
128 printf "\x1b[%dH", $term_height;
129 }
130
131 sub upper_left() {
132 printf "\x1b[H";
133 }
134
135 sub move_to($) {
136 printf "\x1b[%dG", $_[0] + 1;
137 }
138
139 sub bak_scroll($) {
140
141 #lower_left;
142 if ( $_[0] ) {
143 printf "\x1b[%dS", $_[0];
144 }
145 else {
146 printf "\x1b[S";
147 }
148 }
149
150 sub fwd_scroll($) {
151 if ( $_[0] ) {
152 printf "\x1b[%dT", $_[0];
153 }
154 else {
155 printf "\x1b[T";
156 }
157 }
158
159 sub delete_char() {
160 set_color(2);
161 printf "\x1b[%dP", 1;
162 set_color(1);
163 }
164
165 sub insert_once($) {
166 my $data = shift;
167 set_color(2);
168 printf "\x1b[%d@%s", length($data), $data;
169 write_chars($data);
170 }
171
172 sub insert_mode($) {
173 set_color(2);
174 printf "\x1b[%dP", length( $_[0] );
175 printf "\x1b[4h";
176 write_chars( $_[0] );
177 printf "\x1b[4l";
178 }
179
180 sub write_chars($) {
181 set_color(3);
182 printf "%s", $_[0];
183 set_color(1);
184 }
185
186 # vary the starting point of each line, to make a more interesting pattern
187 sub starts_of($) {
188 my $value = $_[0];
189 if ( defined($opt_w) ) {
190
191 # 0,1,1,2,2,3,3,...
192 $value = ( ( $value + 1 ) / 2 ) % length($test_string);
193 }
194 else {
195 $value %= length($test_string);
196 }
197 return $value;
198 }
199
200 # write the text for the given line-number
201 sub testit($) {
202 my $number = $_[0];
203 my $length = $term_width;
204
205 # use delete-lines to "pull" the screen up, like scrolling.
206 select( undef, undef, undef, 0.1 );
207 if ( ( ( $number / $max_scroll ) % 2 ) != 0 ) {
208 lower_left;
209 fwd_scroll(1);
210 }
211 else {
212 lower_left;
213 bak_scroll(1);
214 }
215 if ( defined($opt_n) ) {
216 printf "%5d ", $number % 99999;
217 $length -= 6;
218 }
219
220 # if we're printing double-column characters, we have half as much
221 # space effectively - but don't forget the remainder, so we can push
222 # the characters by single-columns.
223 if ( defined($opt_c) ) {
224 set_color(1);
225 clr_to_eol();
226 }
227 my $starts = starts_of($number);
228 if ( defined($opt_w) ) {
229 printf " ", if ( ( $number % 2 ) != 0 );
230 $length = ( $length - ( ($number) % 2 ) ) / 2;
231 }
232 my $string = substr( $test_string, $starts );
233 while ( length($string) < $length ) {
234 $string = $string . $test_string;
235 }
236 $string = substr( $string, 0, $length );
237 if ( defined($opt_w) ) {
238 $string = double_cells($string);
239 }
240 printf "%s", $string;
241
242 # now - within the line - modify it
243 move_to( ( 4 * $term_width ) / 5 );
244 insert_mode("XX");
245 move_to( ( 3 * $term_width ) / 5 );
246 delete_char();
247 move_to( ( 2 * $term_width ) / 5 );
248 insert_once('~');
249 move_to( ( 1 * $term_width ) / 5 );
250 write_chars('~');
251 move_to(0);
252 set_color(0);
253 }
254
255 sub main::HELP_MESSAGE() {
256 printf STDERR <<EOF
257 Usage: $0 [options]
258
259 Options:
260
261 -c use color
262 -n write line-numbers
263 -r repeat indefinitely
264 -w write wide-characters
265 EOF
266 ;
267 exit;
268 }
269
270 &getopts('cnrw') || die();
271
272 $term_height = screen_height();
273 $term_width = screen_width();
274 $max_scroll = $term_height * 2;
275
276 $test_string =
277 "0123456789 abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ";
278
279 binmode( STDOUT, ":utf8" );
280 clear_screen();
281 if ( defined($opt_r) ) {
282 for ( $lineno = 0 ; ; ++$lineno ) {
283 testit($lineno);
284 }
285 }
286 else {
287 for ( $lineno = 0 ; $lineno < $max_scroll * 2 ; ++$lineno ) {
288 testit($lineno);
289 }
290 }
291 lower_left();
292 clr_to_eol();
293
294 exit;