File Coverage

blib/lib/Term/Choose/Linux.pm
Criterion Covered Total %
statement 18 169 10.6
branch 0 148 0.0
condition 0 14 0.0
subroutine 7 13 53.8
pod 0 1 0.0
total 25 345 7.2


line stmt bran cond sub pod time code
1             package Term::Choose::Linux;
2              
3 3     3   34 use warnings;
  3         19  
  3         121  
4 3     3   27 use strict;
  3         9  
  3         106  
5 3     3   55 use 5.10.0;
  3         12  
6              
7             our $VERSION = '1.762';
8              
9 3     3   25 use Term::Choose::Constants qw( :all );
  3         17  
  3         1003  
10 3     3   32 use Term::Choose::Screen qw( hide_cursor show_cursor normal );
  3         7  
  3         323  
11              
12              
13             use constant {
14 3         6153 SET_ANY_EVENT_MOUSE_1003 => "\e[?1003h",
15             SET_SGR_EXT_MODE_MOUSE_1006 => "\e[?1006h",
16             UNSET_ANY_EVENT_MOUSE_1003 => "\e[?1003l",
17             UNSET_SGR_EXT_MODE_MOUSE_1006 => "\e[?1006l",
18 3     3   23 };
  3         17  
19              
20              
21             my $Stty = '';
22              
23              
24             sub new {
25 115     115 0 303 return bless {}, $_[0];
26             }
27              
28              
29             sub _getc_wrapper {
30 0     0     my ( $timeout ) = @_;
31 0 0         if ( TERM_READKEY ) {
32 0           return Term::ReadKey::ReadKey( $timeout );
33             }
34             else {
35             # if ( $timeout ) {
36             # my $rin = '';
37             # vec( $rin, fileno( STDIN ), 1 ) = 1;
38             # my $nfount = select( $rin, undef, undef, $timeout );
39             # return if ! $nfount;
40             # }
41 0           return getc();
42             }
43             }
44              
45              
46             sub __get_key_OS {
47 0     0     my ( $self, $mouse ) = @_;
48 0           my $c1 = _getc_wrapper( 0 );
49 0 0         return if ! defined $c1;
50 0 0         if ( $c1 eq "\e" ) {
51 0           my $c2 = _getc_wrapper( 0.10 );
52 0 0         if ( ! defined $c2 ) { return KEY_ESC; } # unused #\e
  0 0          
    0          
53             elsif ( $c2 eq 'O' ) {
54 0           my $c3 = _getc_wrapper( 0 );
55 0 0         if ( $c3 eq 'A' ) { return VK_UP; } #\eOA
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
56 0           elsif ( $c3 eq 'B' ) { return VK_DOWN; } #\eOB
57 0           elsif ( $c3 eq 'C' ) { return VK_RIGHT; } #\eOC
58 0           elsif ( $c3 eq 'D' ) { return VK_LEFT; } #\eOD
59 0           elsif ( $c3 eq 'F' ) { return VK_END; } #\eOF
60 0           elsif ( $c3 eq 'H' ) { return VK_HOME; } #\eOH
61 0           elsif ( $c3 eq 'P' ) { return VK_F1; } #\eOP
62 0           elsif ( $c3 eq 'Q' ) { return VK_F2; } #\eOQ
63 0           elsif ( $c3 eq 'R' ) { return VK_F3; } #\eOR
64 0           elsif ( $c3 eq 'S' ) { return VK_F4; } #\eOS
65 0           elsif ( $c3 eq 'Z' ) { return KEY_BTAB; } #\eOZ
66             }
67             elsif ( $c2 eq '[' ) {
68 0           my $c3 = _getc_wrapper( 0 );
69 0 0 0       if ( $c3 eq 'A' ) { return VK_UP; } #\e[A
  0 0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
70 0           elsif ( $c3 eq 'B' ) { return VK_DOWN; } #\e[B
71 0           elsif ( $c3 eq 'C' ) { return VK_RIGHT; } #\e[C
72 0           elsif ( $c3 eq 'D' ) { return VK_LEFT; } #\e[D
73 0           elsif ( $c3 eq 'F' ) { return VK_END; } #\e[F
74 0           elsif ( $c3 eq 'H' ) { return VK_HOME; } #\e[H
75 0           elsif ( $c3 eq 'Z' ) { return KEY_BTAB; } #\e[Z
76             elsif ( $c3 eq '1' ) {
77 0           my $c4 = _getc_wrapper( 0 );
78 0 0         if ( $c4 eq 'F' ) { return VK_END; } #\e[1F
  0 0          
    0          
    0          
79 0           elsif ( $c4 eq 'H' ) { return VK_HOME; } #\e[1H
80             elsif ( $c4 =~ m/^[1234]$/ ) {
81 0           my $c5 = _getc_wrapper( 0 );
82 0 0         if ( $c5 eq '~' ) {
83 0 0         if ( $c4 eq '1' ) { return VK_F1; } #\e[11~
  0 0          
    0          
    0          
84 0           elsif ( $c4 eq '2' ) { return VK_F2; } #\e[12~
85 0           elsif ( $c4 eq '3' ) { return VK_F3; } #\e[13~
86 0           elsif ( $c4 eq '4' ) { return VK_F4; } #\e[14~
87             }
88             }
89 0           elsif ( $c4 eq '~' ) { return VK_HOME; } #\e[1~
90             }
91             elsif ( $c3 =~ m/^[23456]$/ ) {
92 0           my $c4 = _getc_wrapper( 0 );
93 0 0         if ( $c4 eq '~' ) {
94 0 0         if ( $c3 eq '2' ) { return VK_INSERT; } #\e[2~
  0 0          
    0          
    0          
    0          
95 0           elsif ( $c3 eq '3' ) { return VK_DELETE; } #\e[3~
96 0           elsif ( $c3 eq '4' ) { return VK_END; } #\e[4~ #
97 0           elsif ( $c3 eq '5' ) { return VK_PAGE_UP; } #\e[5~
98 0           elsif ( $c3 eq '6' ) { return VK_PAGE_DOWN; } #\e[6~
99             }
100             }
101             # http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
102             elsif ( $c3 eq 'M' && $mouse ) {
103 0           my $event_type = ord( _getc_wrapper( 0 ) ) - 32;
104 0           my $x = ord( _getc_wrapper( 0 ) ) - 32;
105 0           my $y = ord( _getc_wrapper( 0 ) ) - 32;
106 0           my $button = $self->__mouse_event_to_button( $event_type );
107 0 0         return NEXT_get_key if $button == NEXT_get_key;
108 0           return [ $button, $x, $y ];
109             }
110             elsif ( $c3 eq '<' && $mouse ) { # SGR 1006
111 0           my $event_type = '';
112 0           my $m1;
113 0           while ( ( $m1 = _getc_wrapper( 0 ) ) =~ m/^[0-9]$/ ) {
114 0           $event_type .= $m1;
115             }
116 0 0         return NEXT_get_key if $m1 ne ';';
117 0           my $x = '';
118 0           my $m2;
119 0           while ( ( $m2 = _getc_wrapper( 0 ) ) =~ m/^[0-9]$/ ) {
120 0           $x .= $m2;
121             }
122 0 0         return NEXT_get_key if $m2 ne ';';
123 0           my $y = '';
124 0           my $m3;
125 0           while ( ( $m3 = _getc_wrapper( 0 ) ) =~ m/^[0-9]$/ ) {
126 0           $y .= $m3;
127             }
128 0 0         return NEXT_get_key if $m3 !~ m/^[mM]$/;
129 0 0         my $button_released = $m3 eq 'm' ? 1 : 0;
130 0 0         return NEXT_get_key if $button_released;
131 0           my $button = $self->__mouse_event_to_button( $event_type );
132 0 0         return NEXT_get_key if $button == NEXT_get_key;
133 0           return [ $button, $x, $y ];
134             }
135             }
136             }
137             else {
138 0           return ord $c1;
139             }
140 0           return NEXT_get_key;
141             };
142              
143              
144             sub __mouse_event_to_button {
145 0     0     my ( $self, $event_type ) = @_;
146 0           my $button_drag = ( $event_type & 0x20 ) >> 5;
147 0 0         return NEXT_get_key if $button_drag;
148 0           my $button;
149 0           my $low_2_bits = $event_type & 0x03;
150 0 0         if ( $low_2_bits == 3 ) {
151 0           $button = 0;
152             }
153             else {
154 0 0         if ( $event_type & 0x40 ) {
155 0           $button = $low_2_bits + 4; # 4,5
156             }
157             else {
158 0           $button = $low_2_bits + 1; # 1,2,3
159             }
160             }
161 0           return $button;
162             }
163              
164              
165             sub __set_mode {
166 0     0     my ( $self, $config ) = @_;
167 0 0         if ( $config->{hide_cursor} ) {
168 0           print hide_cursor();
169             }
170 0           my $mode_stty;
171 0 0         if ( ! $config->{mode} ) {
    0          
    0          
172 0           die "No mode!";
173             }
174             elsif ( $config->{mode} eq 'ultra-raw' ) {
175 0           $mode_stty = 'raw';
176             }
177             elsif ( $config->{mode} eq 'cbreak' ) {
178 0           $mode_stty = 'cbreak';
179             }
180             else {
181 0           die "Invalid mode!";
182             }
183 0 0         if ( TERM_READKEY ) {
184 0           Term::ReadKey::ReadMode( $config->{mode} );
185             }
186             else {
187 0           $Stty = qx(stty --save);
188 0           chomp $Stty;
189 0 0         system( "stty -echo $mode_stty" ) == 0 or die $?;
190             }
191 0 0         if ( $config->{mouse} ) {
192 0           my $return = binmode STDIN, ':raw';
193 0 0         if ( $return ) {
194 0           print SET_ANY_EVENT_MOUSE_1003;
195 0           print SET_SGR_EXT_MODE_MOUSE_1006;
196             }
197             else {
198 0           $config->{mouse} = 0;
199 0           warn "binmode STDIN, :raw: $!\nmouse-mode disabled\n";
200             }
201             }
202 0           return $config->{mouse};
203             };
204              
205              
206             sub __reset_mode {
207 0     0     my ( $self, $config ) = @_;
208 0 0         if ( $config->{mouse} ) {
209 0 0         binmode STDIN, ':encoding(UTF-8)' or warn "binmode STDIN, :encoding(UTF-8): $!\n";
210 0           print UNSET_SGR_EXT_MODE_MOUSE_1006;
211 0           print UNSET_ANY_EVENT_MOUSE_1003;
212             }
213 0           print normal();
214 0 0         if ( TERM_READKEY ) {
215 0           Term::ReadKey::ReadMode( 'restore' );
216             }
217             else {
218 0 0         if ( $Stty ) {
219 0 0         system( "stty $Stty" ) == 0 or die $?;
220             }
221             else {
222 0 0         system( "stty sane" ) == 0 or die $?;
223             }
224             }
225 0 0         if ( $config->{hide_cursor} ) {
226 0           print show_cursor();
227             }
228             }
229              
230              
231             sub __get_cursor_row {
232             #my ( $self ) = @_;
233 0     0     my $abs_curs_y;
234 0           print "\e[6n";
235 0           my $c1 = _getc_wrapper( 0 );
236 0 0 0       if ( defined $c1 && $c1 eq "\e" ) {
237 0           my $c2 = _getc_wrapper( 0.10 );
238 0 0 0       if ( defined $c2 && $c2 eq '[' ) {
239 0           my $c3 = _getc_wrapper( 0 );
240 0 0         if ( $c3 =~ m/^[0-9]$/ ) {
241 0           my $c4 = _getc_wrapper( 0 );
242 0 0         if ( $c4 =~ m/^[;0-9]$/ ) {
243 0           my $curs_y = $c3;
244 0           my $ry = $c4;
245 0           while ( $ry =~ m/^[0-9]$/ ) {
246 0           $curs_y .= $ry;
247 0           $ry = _getc_wrapper( 0 );
248             }
249 0 0         if ( $ry eq ';' ) {
250 0           my $curs_x = ''; # unused
251 0           my $rx = _getc_wrapper( 0 );
252 0           while ( $rx =~ m/^[0-9]$/ ) {
253 0           $curs_x .= $rx;
254 0           $rx = _getc_wrapper( 0 );
255             }
256 0 0         if ( $rx eq 'R' ) {
257 0           $abs_curs_y = $curs_y;
258             }
259             }
260             }
261             }
262             }
263             }
264 0   0       return $abs_curs_y || 1;
265             }
266              
267              
268              
269              
270              
271              
272              
273              
274             1;
275              
276             __END__