"Fossies" - the Fresh Open Source Software Archive

Member "xterm-379/vttests/query-status.pl" (11 Nov 2021, 5762 Bytes) of package /linux/misc/xterm-379.tgz:

    1 #!/usr/bin/env perl
    2 # $XTermId: query-status.pl,v 1.10 2021/11/11 21:31:48 tom Exp $
    3 # -----------------------------------------------------------------------------
    4 # this file is part of xterm
    5 #
    6 # Copyright 2017-2019,2021 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 status features of xterm using DECRQSS.
   35 #
   36 # TODO: use Term::ReadKey rather than system/stty
   37 
   38 use strict;
   39 use warnings;
   40 
   41 use Getopt::Std;
   42 use IO::Handle;
   43 
   44 our ( $opt_a, $opt_c, $opt_d, $opt_8 );
   45 
   46 $Getopt::Std::STANDARD_HELP_VERSION = 1;
   47 &getopts('acd8') || die(
   48     "Usage: $0 [options] [suffixes]\n
   49 Options:\n
   50   -a      test ANSI colors with SGR controls
   51   -c      test cursor appearance with DECSCUSR controls
   52   -d      test direct colors with SGR controls
   53   -8      use 8-bit controls
   54 
   55 Options which use C1 controls may not work with UTF-8.
   56 "
   57 );
   58 
   59 our $ST  = $opt_8 ? "\x9c" : "\x1b\\";
   60 our $CSI = $opt_8 ? "\x9a" : "\x1b[";
   61 
   62 our %suffixes;
   63 $suffixes{DECSCA}   = '"q';
   64 $suffixes{DECSCL}   = '"p';
   65 $suffixes{DECSTBM}  = 'r';
   66 $suffixes{DECSLRM}  = 's';
   67 $suffixes{SGR}      = 'm';
   68 $suffixes{DECSCUSR} = ' q';
   69 
   70 sub get_reply($) {
   71     open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
   72     autoflush TTY 1;
   73     my $old = `stty -g`;
   74     system "stty raw -echo min 0 time 5";
   75 
   76     print TTY @_;
   77     my $reply = <TTY>;
   78     close TTY;
   79     system "stty $old";
   80     if ( defined $reply ) {
   81         die("^C received\n") if ( "$reply" eq "\003" );
   82     }
   83     return $reply;
   84 }
   85 
   86 sub visible($) {
   87     my $reply = $_[0];
   88     my $n;
   89     my $result = "";
   90     for ( $n = 0 ; $n < length($reply) ; ) {
   91         my $c = substr( $reply, $n, 1 );
   92         if ( $c =~ /[[:print:]]/ ) {
   93             $result .= $c;
   94         }
   95         else {
   96             my $k = ord substr( $reply, $n, 1 );
   97             if ( ord $k == 0x1b ) {
   98                 $result .= "\\E";
   99             }
  100             elsif ( $k == 0x7f ) {
  101                 $result .= "^?";
  102             }
  103             elsif ( $k == 32 ) {
  104                 $result .= "\\s";
  105             }
  106             elsif ( $k < 32 ) {
  107                 $result .= sprintf( "^%c", $k + 64 );
  108             }
  109             elsif ( $k > 128 ) {
  110                 $result .= sprintf( "\\%03o", $k );
  111             }
  112             else {
  113                 $result .= chr($k);
  114             }
  115         }
  116         $n += 1;
  117     }
  118 
  119     return $result;
  120 }
  121 
  122 sub query_one($) {
  123     my $name = shift;
  124 
  125     return unless $suffixes{$name};
  126 
  127     my $suffix = $suffixes{$name};
  128     my $prefix = $opt_8 ? "\x90" : "\x1bP";
  129     my $st     = $opt_8 ? "\x9c" : qr/\x1b\\/;
  130     my $DCS    = qr/${prefix}/;
  131     my $match  = qr/${DCS}.*${st}/;
  132     my $reply  = get_reply( $prefix . '$q' . $suffix . $ST );
  133 
  134     printf "%-10s query{%s}%*s", $name,    #
  135       &visible($suffix),                   #
  136       4 - length($suffix), " ";
  137 
  138     if ( defined $reply ) {
  139         printf "%2d ", length($reply);
  140         if ( $reply =~ /${match}/ ) {
  141 
  142             $reply =~ s/^${DCS}//;
  143             $reply =~ s/^;//;
  144             $reply =~ s/${st}$//;
  145         }
  146         else {
  147             printf "? ";
  148         }
  149 
  150         printf "{%s}", visible($reply);
  151     }
  152     printf "\n";
  153 }
  154 
  155 sub ansi_color($) {
  156     my $color = shift;
  157     return $color;
  158 }
  159 
  160 sub direct_color($) {
  161     my $color  = shift;
  162     my $result = "8:2:";
  163     $result .= ( $color & 4 ) ? ":255" : ":0";
  164     $result .= ( $color & 2 ) ? ":255" : ":0";
  165     $result .= ( $color & 1 ) ? ":255" : ":0";
  166     return $result;
  167 }
  168 
  169 sub default_colors() {
  170     return "39;49";
  171 }
  172 
  173 printf "\x1b G" if ($opt_8);
  174 
  175 if ( $#ARGV >= 0 ) {
  176     while ( $#ARGV >= 0 ) {
  177         &query_one( shift @ARGV );
  178     }
  179 }
  180 elsif ($opt_a) {
  181     for my $fg ( 0 .. 7 ) {
  182         printf "%s3%sm", $CSI, &ansi_color($fg);
  183         for my $bg ( 0 .. 7 ) {
  184             printf "%s4%sm", $CSI, &ansi_color($bg);
  185             &query_one("SGR");
  186         }
  187     }
  188     printf "%s%sm", $CSI, &default_colors;
  189 }
  190 elsif ($opt_c) {
  191     for my $c ( 0 .. 6 ) {
  192         printf "%s%d q", $CSI, $c;
  193         &query_one("DECSCUSR");
  194     }
  195     printf "%s q", $CSI;
  196 }
  197 elsif ($opt_d) {
  198     for my $fg ( 0 .. 7 ) {
  199         printf "%s3%sm", $CSI, &direct_color($fg);
  200         for my $bg ( 0 .. 7 ) {
  201             printf "%s4%sm", $CSI, &direct_color($bg);
  202             &query_one("SGR");
  203         }
  204     }
  205     printf "%s39;49m", $CSI;
  206 }
  207 else {
  208     for my $key ( sort keys %suffixes ) {
  209         &query_one($key);
  210     }
  211 }
  212 
  213 printf "\x1b F" if ($opt_8);