"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/halves.pl" (17 Nov 2022, 6006 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 "halves.pl" see the
Fossies "Dox" file reference documentation and the last
Fossies "Diffs" side-by-side code changes report:
375_vs_376.
1 #!/usr/bin/env perl
2 # $XTermId: halves.pl,v 1.11 2022/11/17 00:45:00 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2007,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 # Draw a grid of characters (optionally double-width) and modify it using
35 # overstrike, insert- and delete-characters to see if the double-width
36 # characters are completely cleared when "partly" modified.
37 use strict;
38 use warnings;
39
40 use Getopt::Std;
41
42 our ( $opt_c, $opt_n, $opt_r, $opt_w );
43 our ( $lineno, $test_string, $term_width );
44
45 # returns the number of columns in the screen
46 sub screen_width() {
47 open( FP, "resize -u |" ) or exit $!;
48 my (@input) = <FP>;
49 chomp @input;
50 close(FP);
51 my $result = 80;
52 for my $n ( 0 .. $#input ) {
53 if ( $input[$n] =~ /^COLUMNS=/ ) {
54 $result = $input[$n];
55 $result =~ s/^[^=]*=//;
56 $result =~ s/;.*//;
57 last;
58 }
59 }
60 return $result;
61 }
62
63 sub set_color($) {
64 my $code = $_[0];
65 if ( defined($opt_c) ) {
66 if ( $code == 3 ) {
67 printf "\x1b[1;33;42m"; # yellow-on-green
68 }
69 elsif ( $code == 2 ) {
70 printf "\x1b[0;31;45m"; # red-on-magenta
71 }
72 elsif ( $code == 1 ) {
73 printf "\x1b[0;36;44m"; # cyan-on-blue
74 }
75 else {
76 printf "\x1b[0;39;49m";
77 }
78 }
79 }
80
81 # returns a string of two-column characters given an ASCII alpha/numeric string
82 sub double_cells($) {
83 my $value = $_[0];
84 $value =~ s/ / /g;
85 pack(
86 "U*",
87 map {
88 ( $_ <= 32 || $_ > 127 ) # if non-ASCII character...
89 ? 32 # ...just show a blank
90 : ( 0xff00 + ( $_ - 32 ) ) # map to "Fullwidth Form"
91 } unpack( "C*", $value )
92 ); # unpack unsigned-char characters
93 }
94
95 sub move_to($) {
96 printf "\x1b[%dG", $_[0] + 1;
97 }
98
99 sub delete_char() {
100 set_color(2);
101 printf "\x1b[%dP", 1;
102 set_color(1);
103 }
104
105 sub insert_once($) {
106 set_color(2);
107 printf "\x1b[%d@", length( $_[0] );
108 write_chars( $_[0] );
109 }
110
111 sub insert_mode($) {
112 set_color(2);
113 printf "\x1b[%dP", length( $_[0] );
114 printf "\x1b[4h";
115 write_chars( $_[0] );
116 printf "\x1b[4l";
117 }
118
119 sub write_chars($) {
120 set_color(3);
121 printf "%s", $_[0];
122 set_color(1);
123 }
124
125 # vary the starting point of each line, to make a more interesting pattern
126 sub starts_of($) {
127 my $value = $_[0];
128 if ( defined($opt_w) ) {
129
130 # 0,1,1,2,2,3,3,...
131 $value = ( ( $value + 1 ) / 2 ) % length($test_string);
132 }
133 else {
134 $value %= length($test_string);
135 }
136 return $value;
137 }
138
139 # write the text for the given line-number
140 sub testit($) {
141 my $number = $_[0];
142 my $length = $term_width;
143 if ( defined($opt_n) ) {
144 printf "%5d ", $number % 99999;
145 $length -= 6;
146 }
147
148 # if we're printing double-column characters, we have half as much
149 # space effectively - but don't forget the remainder, so we can push
150 # the characters by single-columns.
151 if ( defined($opt_c) ) {
152 set_color(1);
153 printf "\x1b[K";
154 }
155 my $starts = starts_of($number);
156 if ( defined($opt_w) ) {
157 printf " ", if ( ( $number % 2 ) != 0 );
158 $length = ( $length - ( ($number) % 2 ) ) / 2;
159 }
160 my $string = substr( $test_string, $starts );
161 while ( length($string) < $length ) {
162 $string = $string . $test_string;
163 }
164 $string = substr( $string, 0, $length );
165 if ( defined($opt_w) ) {
166 $string = double_cells($string);
167 }
168 printf "%s", $string;
169
170 # now - within the line - modify it
171 move_to( ( 4 * $term_width ) / 5 );
172 insert_mode("XX");
173 move_to( ( 3 * $term_width ) / 5 );
174 delete_char();
175 move_to( ( 2 * $term_width ) / 5 );
176 insert_once('~');
177 move_to( ( 1 * $term_width ) / 5 );
178 write_chars('~');
179 move_to(0);
180 set_color(0);
181 printf "\n";
182 }
183
184 sub main::HELP_MESSAGE() {
185 printf STDERR <<EOF
186 Usage: $0 [options]
187
188 Options:
189
190 -c use color
191 -n write line-numbers
192 -r repeat indefinitely
193 -w write wide-characters
194 EOF
195 ;
196 exit;
197 }
198
199 &getopts('cnrw') || die();
200
201 $term_width = screen_width();
202
203 $test_string =
204 "0123456789 abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ";
205
206 binmode( STDOUT, ":utf8" );
207 if ( defined($opt_r) ) {
208 for ( $lineno = 0 ; ; ++$lineno ) {
209 testit($lineno);
210 }
211 }
212 else {
213 for ( $lineno = 0 ; $lineno < 24 ; ++$lineno ) {
214 testit($lineno);
215 }
216 }
217
218 exit;