xorblink.pl revision a5ae21e4 
1#!/usr/bin/env perl
2# $XTermId: xorblink.pl,v 1.15 2017/12/24 21:03:54 tom Exp $
3# walk through the different states of cursor-blinking, with annotation
4#
5# Manual:
6#        +bc     turn off text cursor blinking.  This overrides the cursorBlink
7#                resource.
8#
9#        -bc     turn on text cursor blinking.  This overrides the cursorBlink
10#                resource.
11#
12#        cursorBlink (class CursorBlink)
13#                Specifies whether to make the cursor blink.  The default is
14#                "false".
15#
16#                Xterm-dev uses two variables to determine whether the cursor
17#                blinks.  One is set by this resource.  The other is set by
18#                control sequences (private mode 12 and DECSCUSR).  Xterm-dev
19#                tests the XOR of the two variables.
20#
21#               Enable Blinking Cursor (resource cursorblink)
22#                      Enable (or disable) the blinking-cursor feature.  This
23#                      corresponds to the -bc option and the cursorBlink
24#                      resource.  There is also an escape sequence (see Xterm-
25#                      dev Control Sequences).  The menu entry and the escape
26#                      sequence states are XOR'd: if both are enabled, the
27#                      cursor will not blink, if only one is enabled, the cursor
28#                      will blink.
29#
30#        set-cursorblink(on/off/toggle)
31#                This action sets, unsets or toggles the cursorBlink resource.
32#                It is also invoked from the cursorblink entry in vtMenu.
33#
34# Control sequences:
35#
36# CSI ? Pm h
37#           DEC Private Mode Set (DECSET).
38#             Ps = 1 2  -> Start Blinking Cursor (att610).
39#
40# CSI ? Pm l
41#           DEC Private Mode Reset (DECRST).
42#             Ps = 1 2  -> Stop Blinking Cursor (att610).
43#
44# CSI Ps SP q
45#           Set cursor style (DECSCUSR, VT520).
46#             Ps = 0  -> blinking block.
47#             Ps = 1  -> blinking block (default).
48#             Ps = 2  -> steady block.
49#             Ps = 3  -> blinking underline.
50#             Ps = 4  -> steady underline.
51#             Ps = 5  -> blinking bar (xterm).
52#             Ps = 6  -> steady bar (xterm).
53#
54use strict;
55
56use Term::ReadKey;
57
58use IO::Handle;
59STDERR->autoflush(1);
60STDOUT->autoflush(1);
61
62our %DECSET = (
63    "\e[?12h", "Start Blinking Cursor (AT&T 610)",
64    "\e[?12l", "Stop Blinking Cursor (AT&T 610)"
65);
66
67our %DECSCUSR = (
68    "\e[0 q",
69    "blinking block",
70    "\e[1 q",
71    "blinking block (default)",
72    "\e[2 q",
73    "steady block",
74    "\e[3 q",
75    "blinking underline",
76    "\e[4 q",
77    "steady underline",
78    "\e[5 q",
79    "blinking bar (xterm)",
80    "\e[6 q",
81    "steady bar (xterm)"
82);
83
84sub show($$) {
85    my $seq = shift;
86    my $txt = shift;
87    printf "%s -> %s\n", &visible($seq), $txt;
88}
89
90sub get_reply($$) {
91    my $seq = shift;
92    my $end = shift;
93    printf STDERR "%s", $seq;
94    my $key;
95    my $result = "";
96    $key = ReadKey(0);
97    $result .= $key;
98    if ( $key eq "\e" ) {
99
100        while (1) {
101            $key = ReadKey(100);
102            $result .= $key;
103            next if ( length($result) < length($end) );
104            last if ( substr( $result, -length($end) ) eq $end );
105        }
106    }
107    return $result;
108}
109
110sub mode_value($) {
111    my $value = shift;
112    if ( $value eq 1 ) {
113        $value = "set";
114    }
115    elsif ( $value eq 2 ) {
116        $value = "reset";
117    }
118    elsif ( $value eq 3 ) {
119        $value = "*set";
120    }
121    elsif ( $value eq 4 ) {
122        $value = "*reset";
123    }
124    else {
125        $value = &visible( "?" . $value );
126    }
127    return $value;
128}
129
130sub DECRQM($) {
131    my $mode     = shift;
132    my $sequence = sprintf( "\e[?%d\$p", $mode );
133    my $reply    = &get_reply( $sequence, "y" );
134    if ( $reply =~ /^\e\[\?$mode;\d+\$y$/ ) {
135        $reply =~ s/^\e\[\?$mode;(\d+)\$y$/$1/;
136    }
137    return &mode_value($reply);
138}
139
140sub DECRQSS($) {
141    my $request  = shift;
142    my $ending   = "\e\\";
143    my $sequence = sprintf( "\eP\$q%s$ending", $request );
144    my $reply    = &get_reply( $sequence, $ending );
145
146    # xterm responds with
147    # DCS 1 $ r Pt ST for valid requests,
148    # DCS 0 $ r Pt ST for invalid requests.
149    #if ( $reply =~ /^\eP1\$r.*$ending$/ ) {
150    if ( $reply =~ /^\eP1\$r\d+ q\e\\$/ ) {
151        $reply =~ s/^\eP1\$r(\d+) q\e\\$/$1/;
152    }
153    return &visible($reply);
154}
155
156sub get_key() {
157    my $key;
158    do {
159        $key = ReadKey(0);
160        if ( $key eq "\e" ) {
161            while ( ReadKey(10) !~ /[@-~]/ ) {
162                #
163            }
164        }
165    } while ( $key eq "\e" );
166    return $key;
167}
168
169sub visible($) {
170    my $txt = shift;
171    $txt =~ s/\e/\\e/g;
172    $txt =~ s/\a/\\a/g;
173    return $txt;
174}
175
176sub test($$) {
177    my $set = shift;
178    my $msg = shift;
179
180    ReadMode 'raw';
181
182    printf STDERR "%s\t[", &visible($set);
183
184    # save the cursor position
185    printf STDERR "\e7";
186
187    # send the escape sequence
188    printf STDERR "%s", $set;
189
190    # print the description
191    printf STDERR "X] ";
192
193    printf STDERR " [C=%s,",  &DECRQSS(" q");
194    printf STDERR "B=%s,",    &DECRQM(12);
195    printf STDERR "M=%s,%s]", &DECRQM(13), &DECRQM(14);
196    printf STDERR " %s",      $msg;
197    printf STDERR "\e[0J";
198
199    # restore the cursor position
200    printf STDERR "\e8";
201
202    # wait for any key
203    my $key = &get_key;
204    ReadMode 'restore';
205
206    # print newline
207    printf STDERR "\n";
208
209    # A backspace response makes the current line reprint (to test menus)
210    return ( $key ne "\b" and $key ne "\177" ) ? 1 : 0;
211}
212
213if ( -t STDOUT ) {
214    printf "Legend:\n";
215    printf "  C = cursor shape (1,2 block, 3,4 underline, 5,6 left-bar)\n";
216    printf "  B = escape-sequence blink\n";
217    printf "  M = menu blink and XOR mode\n";
218    printf "\n";
219    printf "An asterisk means the mode is always set or reset.\n";
220    printf "Press any key to proceed; press backspace to reprint line.\n";
221    printf "\n";
222    my @DECSET   = sort keys %DECSET;
223    my @DECSCUSR = sort keys %DECSCUSR;
224
225    for ( my $h = 0 ; $h <= $#DECSET ; ++$h ) {
226        $h-- unless &test( $DECSET[$h], $DECSET{ $DECSET[$h] } );
227    }
228    for my $l ( 0 .. $#DECSCUSR ) {
229        $l-- unless &test( $DECSCUSR[$l], $DECSCUSR{ $DECSCUSR[$l] } );
230    }
231}
232else {
233    printf "DECSET (AT&T 610 blinking cursor):\n";
234    for my $key ( sort keys %DECSET ) {
235        &show( $key, $DECSET{$key} );
236    }
237
238    printf "DECSCUSR:\n";
239    for my $key ( sort keys %DECSCUSR ) {
240        &show( $key, $DECSCUSR{$key} );
241    }
242}
2431;
244