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