"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/query-xres.pl" (6 Oct 2019, 6328 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-xres.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: query-xres.pl,v 1.6 2019/10/06 23:56:18 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 # Report features enabled/disabled via resource-settings
35
36 # TODO: handle 8-bit controls
37
38 use strict;
39 use warnings;
40
41 use Getopt::Std;
42 use IO::Handle;
43
44 our ( $opt_a, $opt_d, $opt_e, $opt_m, $opt_q );
45
46 our @query_params;
47 our @query_result;
48
49 $Getopt::Std::STANDARD_HELP_VERSION = 1;
50 &getopts('acdemq') || die(
51 "Usage: $0 [options]\n
52 Options:\n
53 -a (same as -d -e -m)
54 -d query disabled/disallowed features
55 -e query enabled/allowed features
56 -m query modified keys
57 -q quicker results by merging queries
58 "
59 );
60
61 if (
62 $#ARGV < 0
63 and not( defined($opt_d)
64 or defined($opt_e)
65 or defined($opt_m) )
66 )
67 {
68 $opt_a = 1;
69 }
70
71 sub get_reply($) {
72 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
73 autoflush TTY 1;
74 my $old = `stty -g`;
75 system "stty raw -echo min 0 time 5";
76
77 print TTY @_;
78 my $reply = <TTY>;
79 close TTY;
80 system "stty $old";
81 if ( defined $reply ) {
82 die("^C received\n") if ( "$reply" eq "\003" );
83 }
84 return $reply;
85 }
86
87 sub hexified($) {
88 my $value = $_[0];
89 my $result = "";
90 my $n;
91
92 for ( $n = 0 ; $n < length($value) ; ++$n ) {
93 $result .= sprintf( "%02X", ord substr( $value, $n, 1 ) );
94 }
95 return $result;
96 }
97
98 sub begin_query() {
99 @query_params = ();
100 }
101
102 sub add_param($) {
103 $query_params[ $#query_params + 1 ] = &hexified( $_[0] );
104 }
105
106 sub finish_query() {
107 my $reply = &get_reply( "\x1bP+Q" . join( ';', @query_params ) . "\x1b\\" );
108
109 return unless defined $reply;
110 while ( $reply =~ /\x1bP1\+R[[:xdigit:]]+[=;][[:xdigit:]]*.*\x1b\\/ ) {
111 my $n;
112 my $parse;
113
114 $reply =~ s/^\x1bP1\+R//;
115 $parse = $reply;
116 $reply =~ s/\x1b\\.*$//;
117 $parse = substr( $parse, length($reply) );
118 $parse =~ s/^\x1b\\//;
119
120 my $result = "";
121 my $count = 0;
122 my $state = 0;
123 my $error = "?";
124 for ( $n = 0 ; $n < length($reply) ; ) {
125 my $c = substr( $reply, $n, 1 );
126
127 if ( $c eq ';' ) {
128 $n += 1;
129 printf "%d%s\t%s\n", $count, $error, $result
130 if ( $result ne "" );
131 $result = "";
132 $state = 0;
133 $error = "?";
134 $count++;
135 }
136 elsif ( $c eq '=' ) {
137 $error = ""
138 if ( $count <= $#query_params
139 and &hexified($result) eq $query_params[$count] );
140 $n += 1;
141 $result .= $c;
142 $state = 1;
143 }
144 elsif ( $c =~ /[[:punct:]]/ ) {
145 $n += 1;
146 $result .= $c;
147 }
148 else {
149 my $k = hex substr( $reply, $n, 2 );
150 if ( $k == 0x1b ) {
151 $result .= "\\E";
152 }
153 elsif ( $k == 0x7f ) {
154 $result .= "^?";
155 }
156 elsif ( $k == 32 ) {
157 $result .= "\\s";
158 }
159 elsif ( $k < 32 ) {
160 $result .= sprintf( "^%c", $k + 64 );
161 }
162 elsif ( $k > 128 ) {
163 $result .= sprintf( "\\%03o", $k );
164 }
165 else {
166 $result .= chr($k);
167 }
168 $n += 2;
169 }
170 }
171 printf "%d%s\t%s\n", $count, $error, $result if ( $result ne "" );
172 $reply = $parse;
173 }
174 }
175
176 sub do_query($) {
177 my $name = shift;
178
179 &begin_query unless ($opt_q);
180 &add_param($name);
181 &finish_query unless ($opt_q);
182 }
183
184 &begin_query if ($opt_q);
185
186 while ( $#ARGV >= 0 ) {
187 &do_query( shift @ARGV );
188 }
189
190 if ( defined($opt_a) || defined($opt_d) ) {
191 &do_query("disallowedColorOps");
192 &do_query("disallowedFontOps");
193 &do_query("disallowedMouseOps");
194 &do_query("disallowedPasteControls");
195 &do_query("disallowedTcapOps");
196 &do_query("disallowedWindowOps");
197 }
198
199 if ( defined($opt_a) ) {
200 &do_query("allowSendEvents");
201 &do_query("allowPasteControls");
202 &do_query("allowC1Printable");
203 &do_query("saveLines");
204 }
205
206 if ( defined($opt_a) || defined($opt_e) ) {
207 &do_query("allowColorOps");
208 &do_query("allowFontOps");
209 &do_query("allowMouseOps");
210 &do_query("allowPasteControls");
211 &do_query("allowTcapOps");
212 &do_query("allowTitleOps");
213 &do_query("allowWindowOps");
214 }
215
216 if ( defined($opt_a) || defined($opt_m) ) {
217 &do_query("formatOtherKeys");
218 &do_query("modifyCursorKeys");
219 &do_query("modifyFunctionKeys");
220 &do_query("modifyKeyboard");
221 &do_query("modifyOtherKeys");
222 }
223
224 &finish_query if ($opt_q);
225
226 1;