"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/query-dynamic.pl" (19 May 2019, 6287 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-dynamic.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: query-dynamic.pl,v 1.6 2019/05/19 08:56:11 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2019 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 for dynamic-colors
35
36 use strict;
37 use warnings;
38
39 use Getopt::Std;
40 use IO::Handle;
41
42 our ( $opt_q, $opt_s, $opt_8 );
43
44 our @query_params;
45
46 our @color_names = (
47 "VT100 text foreground color",
48 "VT100 text background color",
49 "text cursor color",
50 "mouse foreground color",
51 "mouse background color",
52 "Tektronix foreground color",
53 "Tektronix background color",
54 "highlight background color",
55 "Tektronix cursor color",
56 "highlight foreground color"
57 );
58
59 $Getopt::Std::STANDARD_HELP_VERSION = 1;
60 &getopts('qs8') || die(
61 "Usage: $0 [options]\n
62 Options:\n
63 -q quicker results by merging queries
64 -s use ^G rather than ST
65 -8 use 8-bit controls
66 "
67 );
68
69 our $OSC = "\x1b\]";
70 $OSC = "\x9d" if ($opt_8);
71 our $ST = $opt_8 ? "\x9c" : ( $opt_s ? "\007" : "\x1b\\" );
72
73 sub get_reply($) {
74 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
75 autoflush TTY 1;
76 my $old = `stty -g`;
77 system "stty raw -echo min 0 time 5";
78
79 print TTY @_;
80 my $reply = <TTY>;
81 close TTY;
82 system "stty $old";
83 if ( defined $reply ) {
84 die("^C received\n") if ( "$reply" eq "\003" );
85 }
86 return $reply;
87 }
88
89 sub visible($) {
90 my $reply = $_[0];
91 my $n;
92 my $result = "";
93 for ( $n = 0 ; $n < length($reply) ; ) {
94 my $c = substr( $reply, $n, 1 );
95 if ( $c =~ /[[:print:]]/ ) {
96 $result .= $c;
97 }
98 else {
99 my $k = ord substr( $reply, $n, 1 );
100 if ( ord $k == 0x1b ) {
101 $result .= "\\E";
102 }
103 elsif ( $k == 0x7f ) {
104 $result .= "^?";
105 }
106 elsif ( $k == 32 ) {
107 $result .= "\\s";
108 }
109 elsif ( $k < 32 ) {
110 $result .= sprintf( "^%c", $k + 64 );
111 }
112 elsif ( $k > 128 ) {
113 $result .= sprintf( "\\%03o", $k );
114 }
115 else {
116 $result .= chr($k);
117 }
118 }
119 $n += 1;
120 }
121
122 return $result;
123 }
124
125 sub begin_query() {
126 @query_params = ();
127 }
128
129 sub add_param($) {
130 $query_params[ $#query_params + 1 ] = $_[0];
131 }
132
133 sub show_reply($) {
134 my $reply = shift;
135 printf "data={%s}", &visible($reply);
136 }
137
138 sub finish_query($) {
139 return unless (@query_params);
140
141 my $reply;
142 my $n;
143 my $st = $opt_8 ? qr/\x9c/ : ( $opt_s ? qr/\007/ : qr/\x1b\\/ );
144 my $osc = $opt_8 ? qr/\x9d/ : qr/\x1b]/;
145 my $match = qr/${osc}.*${st}/;
146
147 my $params = join( ";", @query_params );
148 $params =~ s/\d+/?/g;
149 $params = sprintf( "%d;%s", $query_params[0], $params );
150 $reply = &get_reply( $OSC . $params . $ST );
151
152 printf "query{%s}", &visible($params);
153
154 if ( defined $reply ) {
155 printf " len=%2d ", length($reply);
156 if ( $reply =~ /${match}/ ) {
157 my @chunks = split /${st}${osc}/, $reply;
158 printf "\n" if ( $#chunks > 0 );
159 for my $c ( 0 .. $#chunks ) {
160 $chunks[$c] =~ s/^${osc}// if ( $c == 0 );
161 $chunks[$c] =~ s/${st}$// if ( $c == $#chunks );
162 my $param = $chunks[$c];
163 $param =~ s/^(\d+);.*/$1/;
164 $param = -1 unless ( $param =~ /^\d+$/ );
165 $chunks[$c] =~ s/^\d+;//;
166 printf "\t%d: ", $param if ( $#chunks > 0 );
167 &show_reply( $chunks[$c] );
168 printf " %s", $color_names[ $param - 10 ]
169 if ( ( $param >= 10 )
170 and ( ( $param - 10 ) <= $#color_names ) );
171 printf "\n" if ( $c < $#chunks );
172 }
173 }
174 else {
175 printf "? ";
176 &show_reply($reply);
177 }
178 }
179 printf "\n";
180 }
181
182 sub query_color($) {
183 my $param = shift;
184
185 &begin_query unless $opt_q;
186 if ( $#query_params >= 0
187 and ( $param != $query_params[$#query_params] + 1 ) )
188 {
189 &finish_query;
190 &begin_query;
191 }
192 &add_param($param);
193 &finish_query unless $opt_q;
194 }
195
196 sub query_colors($$) {
197 my $lo = shift;
198 my $hi = shift;
199 my $n;
200 for ( $n = $lo ; $n <= $hi ; ++$n ) {
201 &query_color($n);
202 }
203 }
204
205 printf "\x1b G" if ($opt_8);
206
207 &begin_query if ($opt_q);
208
209 if ( $#ARGV >= 0 ) {
210 while ( $#ARGV >= 0 ) {
211 if ( $ARGV[0] =~ /-/ ) {
212 my @args = split /-/, $ARGV[0];
213 &query_colors( $args[0], $args[1] );
214 }
215 else {
216 &query_colors( $ARGV[0], $ARGV[0] );
217 }
218 shift @ARGV;
219 }
220 }
221 else {
222 &query_colors( 10, 19 );
223 }
224
225 &finish_query if ($opt_q);
226
227 printf "\x1b F" if ($opt_8);
228
229 1;