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
36use strict;
37use warnings;
38
39use Getopt::Std;
40use IO::Handle;
41
42our (
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
47our @query_params;
48our @query_result;
49
50$Getopt::Std::STANDARD_HELP_VERSION = 1;
51&getopts('abcefikmqt:x:X') || die(
52    "Usage: $0 [options]\n
53Options:\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
69if (
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
81sub 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
92sub 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
108sub 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
119sub modify_tcap($) {
120    my $name  = $_[0];
121    my $param = &hexified($name);
122    &no_reply( "\x1bP+p" . $param . "\x1b\\" );
123}
124
125sub begin_query() {
126    @query_params = ();
127}
128
129sub add_param($) {
130    $query_params[ $#query_params + 1 ] = &hexified( $_[0] );
131}
132
133sub 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
198sub 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
209sub 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" );
225if ( defined($opt_t) ) {
226    printf "Setting TERM=%s\n", $opt_t;
227    &modify_tcap($opt_t);
228}
229
230# See xtermcapKeycode()
231if ( 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
243if ( 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
264if ( 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
330if ( 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
337if ( 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
351if ( defined($opt_x) ) {
352    &query_extended($opt_x);
353}
354
355if ( 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
3741;
375