"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/tcapquery.pl" (29 Apr 2019, 10465 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 "tcapquery.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: tcapquery.pl,v 1.29 2019/04/29 23:27:57 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2004-2018,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 tcap-query option of xterm.
35
36 use strict;
37 use warnings;
38
39 use Getopt::Std;
40 use IO::Handle;
41
42 our (
43 $opt_a, $opt_b, $opt_c, $opt_e, $opt_f, $opt_i,
44 $opt_k, $opt_m, $opt_q, $opt_t, $opt_x, $opt_X
45 );
46
47 our @query_params;
48 our @query_result;
49
50 $Getopt::Std::STANDARD_HELP_VERSION = 1;
51 &getopts('abcefikmqt:x:X') || die(
52 "Usage: $0 [options]\n
53 Options:\n
54 -a (same as -c -e -f -k -m)
55 -b use both terminfo and termcap (default is termcap)
56 -c cursor-keys
57 -e editing keypad-keys
58 -f function-keys
59 -i use terminfo rather than termcap names
60 -k numeric keypad-keys
61 -m miscellaneous (none of -c, -e, -f, -k)
62 -q quicker results by merging queries
63 -t NAME use given NAME for \$TERM, set that in xterm's tcap keyboard
64 -x KEY extended cursor/editing key (terminfo only)
65 -X test all extended cursor- and/or editing-keys (terminfo)
66 "
67 );
68
69 if (
70 not( defined($opt_c)
71 or defined($opt_e)
72 or defined($opt_f)
73 or defined($opt_k)
74 or defined($opt_m)
75 or defined($opt_x) )
76 )
77 {
78 $opt_a = 1;
79 }
80
81 sub no_reply($) {
82 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
83 autoflush TTY 1;
84 my $old = `stty -g`;
85 system "stty raw -echo min 0 time 5";
86
87 print TTY @_;
88 close TTY;
89 system "stty $old";
90 }
91
92 sub get_reply($) {
93 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
94 autoflush TTY 1;
95 my $old = `stty -g`;
96 system "stty raw -echo min 0 time 5";
97
98 print TTY @_;
99 my $reply = <TTY>;
100 close TTY;
101 system "stty $old";
102 if ( defined $reply ) {
103 die("^C received\n") if ( "$reply" eq "\003" );
104 }
105 return $reply;
106 }
107
108 sub hexified($) {
109 my $value = $_[0];
110 my $result = "";
111 my $n;
112
113 for ( $n = 0 ; $n < length($value) ; ++$n ) {
114 $result .= sprintf( "%02X", ord substr( $value, $n, 1 ) );
115 }
116 return $result;
117 }
118
119 sub modify_tcap($) {
120 my $name = $_[0];
121 my $param = &hexified($name);
122 &no_reply( "\x1bP+p" . $param . "\x1b\\" );
123 }
124
125 sub begin_query() {
126 @query_params = ();
127 }
128
129 sub add_param($) {
130 $query_params[ $#query_params + 1 ] = &hexified( $_[0] );
131 }
132
133 sub finish_query() {
134 my $reply = &get_reply( "\x1bP+q" . join( ';', @query_params ) . "\x1b\\" );
135
136 return unless defined $reply;
137 if ( $reply =~ /\x1bP1\+r[[:xdigit:]]+=[[:xdigit:]]*.*/ ) {
138 my $n;
139
140 $reply =~ s/^\x1bP1\+r//;
141 $reply =~ s/\x1b\\//;
142
143 my $result = "";
144 my $count = 0;
145 my $state = 0;
146 my $error = "?";
147 for ( $n = 0 ; $n < length($reply) ; ) {
148 my $c = substr( $reply, $n, 1 );
149
150 if ( $c eq ';' ) {
151 $n += 1;
152 printf "%d%s\t%s\n", $count, $error, $result
153 if ( $result ne "" );
154 $result = "";
155 $state = 0;
156 $error = "?";
157 $count++;
158 }
159 elsif ( $c eq '=' ) {
160 $error = ""
161 if ( $count <= $#query_params
162 and &hexified($result) eq $query_params[$count] );
163 $n += 1;
164 $result .= $c;
165 $state = 1;
166 }
167 elsif ( $c =~ /[[:punct:]]/ ) {
168 $n += 1;
169 $result .= $c;
170 }
171 else {
172 my $k = hex substr( $reply, $n, 2 );
173 if ( $k == 0x1b ) {
174 $result .= "\\E";
175 }
176 elsif ( $k == 0x7f ) {
177 $result .= "^?";
178 }
179 elsif ( $k == 32 ) {
180 $result .= "\\s";
181 }
182 elsif ( $k < 32 ) {
183 $result .= sprintf( "^%c", $k + 64 );
184 }
185 elsif ( $k > 128 ) {
186 $result .= sprintf( "\\%03o", $k );
187 }
188 else {
189 $result .= chr($k);
190 }
191 $n += 2;
192 }
193 }
194 printf "%d%s\t%s\n", $count, $error, $result if ( $result ne "" );
195 }
196 }
197
198 sub query_tcap($$) {
199 my $tcap = shift;
200 my $tinfo = shift;
201
202 &begin_query unless ($opt_q);
203 &add_param($tcap) if ( $opt_b or not $opt_i );
204 &add_param($tinfo) if ( $opt_b or $opt_i );
205 &finish_query unless ($opt_q);
206 }
207
208 # extended-keys are a feature of ncurses 5.0 and later
209 sub query_extended($) {
210 my $name = $_[0];
211 my $n;
212
213 $name = "k" . $name if ( $name !~ /^k/ );
214
215 for ( $n = 2 ; $n <= 7 ; ++$n ) {
216 my $test = $name;
217 $test = $test . $n if ( $n > 2 );
218 &query_tcap( $name, $test );
219 }
220 }
221
222 &begin_query if ($opt_q);
223
224 &query_tcap( "TN", "name" );
225 if ( defined($opt_t) ) {
226 printf "Setting TERM=%s\n", $opt_t;
227 &modify_tcap($opt_t);
228 }
229
230 # See xtermcapKeycode()
231 if ( defined($opt_a) || defined($opt_c) ) {
232 &query_tcap( "ku", "kcuu1" );
233 &query_tcap( "kd", "kcud1" );
234 &query_tcap( "kr", "kcuf1" );
235 &query_tcap( "kl", "kcub1" );
236
237 &query_tcap( "kF", "kind" );
238 &query_tcap( "kR", "kri" );
239 &query_tcap( "%i", "kRIT" );
240 &query_tcap( "#4", "kLFT" );
241 }
242
243 if ( defined($opt_a) || defined($opt_e) ) {
244 &query_tcap( "kD", "kdch1" );
245 &query_tcap( "kI", "kich1" );
246
247 &query_tcap( "kh", "khome" );
248 &query_tcap( "\@7", "kend" );
249 &query_tcap( "#2", "kHOM" );
250 &query_tcap( "*7", "kEND" );
251
252 &query_tcap( "*6", "kslt" );
253 &query_tcap( "#6", "kSLT" );
254 &query_tcap( "\@0", "kfnd" );
255 &query_tcap( "*0", "kFND" );
256
257 &query_tcap( "kN", "knp" );
258 &query_tcap( "kP", "kpp" );
259
260 &query_tcap( "%c", "kNXT" );
261 &query_tcap( "%e", "kPRV" );
262 }
263
264 if ( defined($opt_a) || defined($opt_f) ) {
265 &query_tcap( "k1", "kf1" );
266 &query_tcap( "k2", "kf2" );
267 &query_tcap( "k3", "kf3" );
268 &query_tcap( "k4", "kf4" );
269 &query_tcap( "k5", "kf5" );
270 &query_tcap( "k6", "kf6" );
271 &query_tcap( "k7", "kf7" );
272 &query_tcap( "k8", "kf8" );
273 &query_tcap( "k9", "kf9" );
274 &query_tcap( "k;", "kf10" );
275 &query_tcap( "F1", "kf11" );
276 &query_tcap( "F2", "kf12" );
277 &query_tcap( "F3", "kf13" );
278 &query_tcap( "F4", "kf14" );
279 &query_tcap( "F5", "kf15" );
280 &query_tcap( "F6", "kf16" );
281 &query_tcap( "F7", "kf17" );
282 &query_tcap( "F8", "kf18" );
283 &query_tcap( "F9", "kf19" );
284 &query_tcap( "FA", "kf20" );
285 &query_tcap( "FB", "kf21" );
286 &query_tcap( "FC", "kf22" );
287 &query_tcap( "FD", "kf23" );
288 &query_tcap( "FE", "kf24" );
289 &query_tcap( "FF", "kf25" );
290 &query_tcap( "FG", "kf26" );
291 &query_tcap( "FH", "kf27" );
292 &query_tcap( "FI", "kf28" );
293 &query_tcap( "FJ", "kf29" );
294 &query_tcap( "FK", "kf30" );
295 &query_tcap( "FL", "kf31" );
296 &query_tcap( "FM", "kf32" );
297 &query_tcap( "FN", "kf33" );
298 &query_tcap( "FO", "kf34" );
299 &query_tcap( "FP", "kf35" );
300 &query_tcap( "FQ", "kf36" );
301 &query_tcap( "FR", "kf37" );
302 &query_tcap( "FS", "kf38" );
303 &query_tcap( "FT", "kf39" );
304 &query_tcap( "FU", "kf40" );
305 &query_tcap( "FV", "kf41" );
306 &query_tcap( "FW", "kf42" );
307 &query_tcap( "FX", "kf43" );
308 &query_tcap( "FY", "kf44" );
309 &query_tcap( "FZ", "kf45" );
310 &query_tcap( "Fa", "kf46" );
311 &query_tcap( "Fb", "kf47" );
312 &query_tcap( "Fc", "kf48" );
313 &query_tcap( "Fd", "kf49" );
314 &query_tcap( "Fe", "kf50" );
315 &query_tcap( "Ff", "kf51" );
316 &query_tcap( "Fg", "kf52" );
317 &query_tcap( "Fh", "kf53" );
318 &query_tcap( "Fi", "kf54" );
319 &query_tcap( "Fj", "kf55" );
320 &query_tcap( "Fk", "kf56" );
321 &query_tcap( "Fl", "kf57" );
322 &query_tcap( "Fm", "kf58" );
323 &query_tcap( "Fn", "kf59" );
324 &query_tcap( "Fo", "kf60" );
325 &query_tcap( "Fp", "kf61" );
326 &query_tcap( "Fq", "kf62" );
327 &query_tcap( "Fr", "kf63" );
328 }
329
330 if ( defined($opt_a) || defined($opt_k) ) {
331 &query_tcap( "K1", "ka1" );
332 &query_tcap( "K3", "ka3" );
333 &query_tcap( "K4", "kc1" );
334 &query_tcap( "K5", "kc3" );
335 }
336
337 if ( defined($opt_a) || defined($opt_m) ) {
338 &query_tcap( "kB", "kcbt" );
339 &query_tcap( "kC", "kclr" );
340 &query_tcap( "&8", "kund" );
341
342 &query_tcap( "kb", "kbs" );
343
344 &query_tcap( "%1", "khlp" );
345 &query_tcap( "#1", "kHLP" );
346
347 &query_tcap( "Co", "colors" );
348 &query_tcap( "Co", "RGB" ) if ($opt_i);
349 }
350
351 if ( defined($opt_x) ) {
352 &query_extended($opt_x);
353 }
354
355 if ( defined($opt_X) ) {
356 if ( defined($opt_c) ) {
357 &query_extended("DN");
358 &query_extended("UP");
359 &query_extended("LFT");
360 &query_extended("RIT");
361 }
362 if ( defined($opt_e) ) {
363 &query_extended("DC");
364 &query_extended("END");
365 &query_extended("HOM");
366 &query_extended("IC");
367 &query_extended("NXT");
368 &query_extended("PRV");
369 }
370 }
371
372 &finish_query if ($opt_q);
373
374 1;