Home | History | Annotate | Line # | Download | only in vttests 
      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;
    375