"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/query-color.pl" (13 Dec 2020, 8329 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 "query-color.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: query-color.pl,v 1.26 2020/12/13 18:17:40 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2012-2019,2020 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 # Test the color-query features of xterm using OSC 4 or OSC 5.
35
36 use strict;
37 use warnings;
38
39 use Getopt::Std;
40 use IO::Handle;
41
42 our ( $opt_4, $opt_a, $opt_n, $opt_q, $opt_r, $opt_s, $opt_t );
43
44 $Getopt::Std::STANDARD_HELP_VERSION = 1;
45 &getopts('4an:qrst') || die(
46 "Usage: $0 [options] [color1[-color2]]\n
47 Options:\n
48 -4 use OSC 4 for special colors rather than OSC 5
49 -a query all \"ANSI\" colors
50 -n NUM assume terminal supports NUM \"ANSI\" colors rather than 256
51 -q quicker results by merging queries
52 -r show reported color in #rrggbb format
53 -s use ^G rather than ST
54 -t show actual color
55 "
56 );
57
58 our $ST = $opt_s ? "\007" : "\x1b\\";
59 our $num_ansi_colors = $opt_n ? $opt_n : 256;
60
61 our $last_op = -1;
62 our $this_op = -1;
63
64 our @query_params;
65
66 sub get_reply($) {
67 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
68 autoflush TTY 1;
69 my $old = `stty -g`;
70 system "stty raw -echo min 0 time 5";
71
72 print TTY @_;
73 my $reply = <TTY>;
74 close TTY;
75 system "stty $old";
76 if ( defined $reply ) {
77 die("^C received\n") if ( "$reply" eq "\003" );
78 }
79 return $reply;
80 }
81
82 sub visible($) {
83 my $reply = $_[0];
84 my $n;
85 my $result = "";
86 for ( $n = 0 ; $n < length($reply) ; ) {
87 my $c = substr( $reply, $n, 1 );
88 if ( $c =~ /[[:print:]]/ ) {
89 $result .= $c;
90 }
91 else {
92 my $k = ord substr( $reply, $n, 1 );
93 if ( ord $k == 0x1b ) {
94 $result .= "\\E";
95 }
96 elsif ( $k == 0x7f ) {
97 $result .= "^?";
98 }
99 elsif ( $k == 32 ) {
100 $result .= "\\s";
101 }
102 elsif ( $k < 32 ) {
103 $result .= sprintf( "^%c", $k + 64 );
104 }
105 elsif ( $k > 128 ) {
106 $result .= sprintf( "\\%03o", $k );
107 }
108 else {
109 $result .= chr($k);
110 }
111 }
112 $n += 1;
113 }
114
115 return $result;
116 }
117
118 sub special2code($) {
119 my $param = shift;
120 $param = 0 if ( $param =~ /^bold$/i );
121 $param = 1 if ( $param =~ /^underline$/i );
122 $param = 2 if ( $param =~ /^blink$/i );
123 $param = 3 if ( $param =~ /^reverse$/i );
124 $param = 4 if ( $param =~ /^italic$/i );
125 return $param;
126 }
127
128 sub code2special($) {
129 my $param = shift;
130 my $result;
131 $result = "bold" if ( $param == 0 );
132 $result = "underline" if ( $param == 1 );
133 $result = "blink" if ( $param == 2 );
134 $result = "reverse" if ( $param == 3 );
135 $result = "italic" if ( $param == 4 );
136 return $result;
137 }
138
139 sub begin_query() {
140 @query_params = ();
141 }
142
143 sub add_param($) {
144 $query_params[ $#query_params + 1 ] = $_[0];
145 }
146
147 sub show_reply($) {
148 my $reply = shift;
149 my $shown = sprintf "data={%s}", &visible($reply);
150 my $limit = 30;
151 if ( $reply =~ /^\d+;rgb:.*/ ) {
152 my $color = $reply;
153 $color =~ s/^\d+;rgb://;
154 if ( $color =~ /^[[:xdigit:]]{4}(\/[[:xdigit:]]{4}){2}/ ) {
155 $color =~ s/..$//;
156 $color =~ s/..\///g;
157 if ($opt_r) {
158 $shown = sprintf "#%s", $color;
159 $limit = 7;
160 }
161 }
162 printf "%s", $shown;
163 if ( $opt_4 or ( $this_op == 5 ) ) {
164 my $num = $reply;
165 my $max = $opt_4 ? $num_ansi_colors : 0;
166 $num =~ s/;.*//;
167 if ( $num >= $max ) {
168 my $name = &code2special( $num - $max );
169 printf " %s", $name if ($name);
170 }
171 }
172 if ($opt_t) {
173 my $num = $reply;
174 $num =~ s/;.*//;
175 printf "%*s", $limit - length($shown), " ";
176 if ( $num < 8 ) {
177 printf "\x1b[%dm", 40 + $num;
178 }
179 elsif ( $num < 16 ) {
180 printf "\x1b[%dm", 100 + $num - 8;
181 }
182 elsif ( $num < $num_ansi_colors ) {
183 printf "\x1b[48;5;%dm", $num;
184 }
185 else {
186 }
187 printf " ";
188 printf "\x1b[K";
189 printf "\x1b[m";
190 }
191 }
192 else {
193 printf "%s", $shown;
194 }
195 }
196
197 sub finish_query() {
198 my $query;
199 my $reply;
200 my $n;
201 my $st = $opt_s ? qr/\007/ : qr/\x1b\\/;
202 my $osc = qr/\x1b]$this_op/;
203 my $match = qr/^(${osc}.*${st})+$/;
204
205 my $params = sprintf "%s;?;", ( join( ";?;", @query_params ) );
206 $query = "\x1b]$this_op;" . $params . $ST;
207 $reply = &get_reply($query);
208
209 if ($opt_q) {
210 printf "query %s\n", &visible($query);
211 }
212 else {
213 printf "query %s%*s ", &visible($query),
214 15 - length( &visible($query) ),
215 " ";
216 }
217
218 if ( defined $reply ) {
219 printf "reply len=%2d ", length($reply);
220 if ( $reply =~ /${match}/ ) {
221 my @chunks = split /${st}${osc}/, $reply;
222 printf "\n" if ( $#chunks > 0 );
223 for my $c ( 0 .. $#chunks ) {
224 $chunks[$c] =~ s/^${osc}// if ( $c == 0 );
225 $chunks[$c] =~ s/${st}$// if ( $c == $#chunks );
226 $chunks[$c] =~ s/^;//;
227 printf "%3d: ", $c if ( $#chunks > 0 );
228 &show_reply( $chunks[$c] );
229 printf "\n" if ( $c < $#chunks );
230 }
231 }
232 else {
233 printf "? ";
234 &show_reply($reply);
235 }
236 }
237 printf "\n";
238 }
239
240 sub query_color($) {
241 my $param = shift;
242 my $op = 4;
243
244 if ( $param !~ /^\d+$/ ) {
245 $param = &special2code($param);
246 if ( $param !~ /^\d+$/ ) {
247 printf STDERR "? not a color name or code: $param\n";
248 return;
249 }
250 if ($opt_4) {
251 $param += $num_ansi_colors;
252 }
253 else {
254 $op = 5;
255 }
256 }
257 $this_op = $op; # FIXME handle mixed OSC 4/5
258
259 &begin_query unless $opt_q;
260 &add_param($param);
261 &finish_query unless $opt_q;
262 }
263
264 sub query_colors($$) {
265 my $lo = shift;
266 my $hi = shift;
267 if ( $lo =~ /^\d+$/ ) {
268 my $n;
269 for ( $n = $lo ; $n <= $hi ; ++$n ) {
270 &query_color($n);
271 }
272 }
273 else {
274 &query_color($lo);
275 &query_color($hi) unless ( $hi eq $lo );
276 }
277 }
278
279 &begin_query if ($opt_q);
280
281 if ( $#ARGV >= 0 ) {
282 while ( $#ARGV >= 0 ) {
283 if ( $ARGV[0] =~ /-/ ) {
284 my @args = split /-/, $ARGV[0];
285 &query_colors( $args[0], $args[1] );
286 }
287 else {
288 &query_colors( $ARGV[0], $ARGV[0] );
289 }
290 shift @ARGV;
291 }
292 }
293 else {
294 &query_colors( 0, $opt_a ? $num_ansi_colors : 7 );
295 }
296
297 &finish_query if ($opt_q);
298
299 1;