query-dynamic.pl revision f2e35a3a 
1#!/usr/bin/env perl
2# $XTermId: query-dynamic.pl,v 1.6 2019/05/19 08:56:11 tom Exp $
3# -----------------------------------------------------------------------------
4# this file is part of xterm
5#
6# Copyright 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 color-query features of xterm for dynamic-colors
35
36use strict;
37use warnings;
38
39use Getopt::Std;
40use IO::Handle;
41
42our ( $opt_q, $opt_s, $opt_8 );
43
44our @query_params;
45
46our @color_names = (
47    "VT100 text foreground color",
48    "VT100 text background color",
49    "text cursor color",
50    "mouse foreground color",
51    "mouse background color",
52    "Tektronix foreground color",
53    "Tektronix background color",
54    "highlight background color",
55    "Tektronix cursor color",
56    "highlight foreground color"
57);
58
59$Getopt::Std::STANDARD_HELP_VERSION = 1;
60&getopts('qs8') || die(
61    "Usage: $0 [options]\n
62Options:\n
63  -q      quicker results by merging queries
64  -s      use ^G rather than ST
65  -8      use 8-bit controls
66"
67);
68
69our $OSC = "\x1b\]";
70$OSC = "\x9d" if ($opt_8);
71our $ST = $opt_8 ? "\x9c" : ( $opt_s ? "\007" : "\x1b\\" );
72
73sub get_reply($) {
74    open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
75    autoflush TTY 1;
76    my $old = `stty -g`;
77    system "stty raw -echo min 0 time 5";
78
79    print TTY @_;
80    my $reply = <TTY>;
81    close TTY;
82    system "stty $old";
83    if ( defined $reply ) {
84        die("^C received\n") if ( "$reply" eq "\003" );
85    }
86    return $reply;
87}
88
89sub visible($) {
90    my $reply = $_[0];
91    my $n;
92    my $result = "";
93    for ( $n = 0 ; $n < length($reply) ; ) {
94        my $c = substr( $reply, $n, 1 );
95        if ( $c =~ /[[:print:]]/ ) {
96            $result .= $c;
97        }
98        else {
99            my $k = ord substr( $reply, $n, 1 );
100            if ( ord $k == 0x1b ) {
101                $result .= "\\E";
102            }
103            elsif ( $k == 0x7f ) {
104                $result .= "^?";
105            }
106            elsif ( $k == 32 ) {
107                $result .= "\\s";
108            }
109            elsif ( $k < 32 ) {
110                $result .= sprintf( "^%c", $k + 64 );
111            }
112            elsif ( $k > 128 ) {
113                $result .= sprintf( "\\%03o", $k );
114            }
115            else {
116                $result .= chr($k);
117            }
118        }
119        $n += 1;
120    }
121
122    return $result;
123}
124
125sub begin_query() {
126    @query_params = ();
127}
128
129sub add_param($) {
130    $query_params[ $#query_params + 1 ] = $_[0];
131}
132
133sub show_reply($) {
134    my $reply = shift;
135    printf "data={%s}", &visible($reply);
136}
137
138sub finish_query($) {
139    return unless (@query_params);
140
141    my $reply;
142    my $n;
143    my $st = $opt_8 ? qr/\x9c/ : ( $opt_s ? qr/\007/ : qr/\x1b\\/ );
144    my $osc = $opt_8 ? qr/\x9d/ : qr/\x1b]/;
145    my $match = qr/${osc}.*${st}/;
146
147    my $params = join( ";", @query_params );
148    $params =~ s/\d+/?/g;
149    $params = sprintf( "%d;%s", $query_params[0], $params );
150    $reply = &get_reply( $OSC . $params . $ST );
151
152    printf "query{%s}", &visible($params);
153
154    if ( defined $reply ) {
155        printf " len=%2d ", length($reply);
156        if ( $reply =~ /${match}/ ) {
157            my @chunks = split /${st}${osc}/, $reply;
158            printf "\n" if ( $#chunks > 0 );
159            for my $c ( 0 .. $#chunks ) {
160                $chunks[$c] =~ s/^${osc}// if ( $c == 0 );
161                $chunks[$c] =~ s/${st}$//  if ( $c == $#chunks );
162                my $param = $chunks[$c];
163                $param =~ s/^(\d+);.*/$1/;
164                $param = -1 unless ( $param =~ /^\d+$/ );
165                $chunks[$c] =~ s/^\d+;//;
166                printf "\t%d: ", $param if ( $#chunks > 0 );
167                &show_reply( $chunks[$c] );
168                printf " %s", $color_names[ $param - 10 ]
169                  if (  ( $param >= 10 )
170                    and ( ( $param - 10 ) <= $#color_names ) );
171                printf "\n" if ( $c < $#chunks );
172            }
173        }
174        else {
175            printf "? ";
176            &show_reply($reply);
177        }
178    }
179    printf "\n";
180}
181
182sub query_color($) {
183    my $param = shift;
184
185    &begin_query unless $opt_q;
186    if ( $#query_params >= 0
187        and ( $param != $query_params[$#query_params] + 1 ) )
188    {
189        &finish_query;
190        &begin_query;
191    }
192    &add_param($param);
193    &finish_query unless $opt_q;
194}
195
196sub query_colors($$) {
197    my $lo = shift;
198    my $hi = shift;
199    my $n;
200    for ( $n = $lo ; $n <= $hi ; ++$n ) {
201        &query_color($n);
202    }
203}
204
205printf "\x1b G" if ($opt_8);
206
207&begin_query if ($opt_q);
208
209if ( $#ARGV >= 0 ) {
210    while ( $#ARGV >= 0 ) {
211        if ( $ARGV[0] =~ /-/ ) {
212            my @args = split /-/, $ARGV[0];
213            &query_colors( $args[0], $args[1] );
214        }
215        else {
216            &query_colors( $ARGV[0], $ARGV[0] );
217        }
218        shift @ARGV;
219    }
220}
221else {
222    &query_colors( 10, 19 );
223}
224
225&finish_query if ($opt_q);
226
227printf "\x1b F" if ($opt_8);
228
2291;
230