query-status.pl revision f2e35a3a 
1#!/usr/bin/env perl
2# $XTermId: query-status.pl,v 1.7 2019/05/19 08:57:41 tom Exp $
3# -----------------------------------------------------------------------------
4# this file is part of xterm
5#
6# Copyright 2017-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 status features of xterm using DECRQSS.
35#
36# TODO: use Term::ReadKey rather than system/stty
37
38use strict;
39use warnings;
40
41use Getopt::Std;
42use IO::Handle;
43
44our ($opt_8);
45
46$Getopt::Std::STANDARD_HELP_VERSION = 1;
47&getopts('8') || die(
48    "Usage: $0 [options]\n
49Options:\n
50  -8      use 8-bit controls
51
52Options which use C1 controls may not work with UTF-8.
53"
54);
55
56our $ST = $opt_8 ? "\x9c" : "\x1b\\";
57
58our %suffixes;
59$suffixes{DECSCA}   = '"q';
60$suffixes{DECSCL}   = '"p';
61$suffixes{DECSTBM}  = 'r';
62$suffixes{DECSLRM}  = 's';
63$suffixes{SGR}      = 'm';
64$suffixes{DECSCUSR} = ' q';
65
66sub get_reply($) {
67    open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
68    autoflush TTY 1;
69    my $old = `stty -g`;
70    system "stty raw -echo min 0 time 5";
71
72    print TTY @_;
73    my $reply = <TTY>;
74    close TTY;
75    system "stty $old";
76    if ( defined $reply ) {
77        die("^C received\n") if ( "$reply" eq "\003" );
78    }
79    return $reply;
80}
81
82sub visible($) {
83    my $reply = $_[0];
84    my $n;
85    my $result = "";
86    for ( $n = 0 ; $n < length($reply) ; ) {
87        my $c = substr( $reply, $n, 1 );
88        if ( $c =~ /[[:print:]]/ ) {
89            $result .= $c;
90        }
91        else {
92            my $k = ord substr( $reply, $n, 1 );
93            if ( ord $k == 0x1b ) {
94                $result .= "\\E";
95            }
96            elsif ( $k == 0x7f ) {
97                $result .= "^?";
98            }
99            elsif ( $k == 32 ) {
100                $result .= "\\s";
101            }
102            elsif ( $k < 32 ) {
103                $result .= sprintf( "^%c", $k + 64 );
104            }
105            elsif ( $k > 128 ) {
106                $result .= sprintf( "\\%03o", $k );
107            }
108            else {
109                $result .= chr($k);
110            }
111        }
112        $n += 1;
113    }
114
115    return $result;
116}
117
118sub query_one($) {
119    my $name   = shift;
120    my $suffix = $suffixes{$name};
121    my $prefix = $opt_8 ? "\x90" : "\x1bP";
122    my $reply;
123    my $n;
124    my $st    = $opt_8 ? "\x9c" : qr/\x1b\\/;
125    my $DCS   = qr/${prefix}/;
126    my $match = qr/${DCS}.*${st}/;
127
128    $reply = get_reply( $prefix . '$q' . $suffix . $ST );
129
130    printf "%-10s query{%s}%*s", $name,    #
131      &visible($suffix),                   #
132      4 - length($suffix), " ";
133
134    if ( defined $reply ) {
135        printf "%2d ", length($reply);
136        if ( $reply =~ /${match}/ ) {
137
138            $reply =~ s/^${DCS}//;
139            $reply =~ s/^;//;
140            $reply =~ s/${st}$//;
141        }
142        else {
143            printf "? ";
144        }
145
146        printf "{%s}", visible($reply);
147    }
148    printf "\n";
149}
150
151printf "\x1b G" if ($opt_8);
152
153if ( $#ARGV >= 0 ) {
154    while ( $#ARGV >= 0 ) {
155        &query_one( shift @ARGV );
156    }
157}
158else {
159    for my $key ( sort keys %suffixes ) {
160        &query_one($key);
161    }
162}
163
164printf "\x1b F" if ($opt_8);
165