File Coverage

blib/lib/Devel/REPL/Client/Select.pm
Criterion Covered Total %
statement 19 60 31.6
branch 1 28 3.5
condition 0 6 0.0
subroutine 7 12 58.3
pod 0 4 0.0
total 27 110 24.5


line stmt bran cond sub pod time code
1             package Devel::REPL::Client::Select;
2              
3 1     1   695 use strict;
  1         1  
  1         25  
4 1     1   4 use warnings;
  1         1  
  1         18  
5              
6 1     1   3 use IO::Select;
  1         1  
  1         29  
7 1     1   3 use IO::Socket;
  1         1  
  1         3  
8 1     1   818 use Term::ReadKey;
  1         2992  
  1         64  
9              
10             use constant {
11 1         454 EOT => "\x04",
12 1     1   4 };
  1         1  
13              
14             my $RESTORE_READMODE;
15              
16             END {
17 1 50   1   7 ReadMode 0, \*STDIN if $RESTORE_READMODE;
18             }
19              
20             sub new {
21 0     0 0   my ($class, %args) = @_;
22             my $self = bless {
23             port => $args{port},
24             path => $args{path},
25 0           socket => undef,
26             }, $class;
27              
28 0           return $self;
29             }
30              
31             sub listen {
32 0     0 0   my ($self) = @_;
33              
34 0 0         if ($self->{port}) {
    0          
35             $self->{socket} = IO::Socket::INET->new(
36             Listen => 1,
37             LocalAddr => '127.0.0.1',
38             LocalPort => $self->{port},
39 0           Proto => 'tcp',
40             ReuseAddr => 1,
41             );
42             } elsif ($self->{path}) {
43 0 0         if (-S $self->{path}) {
44 0 0         unlink $self->{path} or die "Unable to unlink stale socket: $!";
45             }
46              
47             $self->{socket} = IO::Socket::UNIX->new(
48             Listen => 1,
49             Local => $self->{path},
50 0           );
51             }
52              
53 0 0         die "Unable to start listening: $!" unless $self->{socket};
54             }
55              
56             sub accept_and_process {
57 0     0 0   my ($self) = @_;
58 0           my $client = $self->{socket}->accept;
59              
60 0           $RESTORE_READMODE = 1;
61 0           ReadMode 3, \*STDIN;
62              
63 0           my $fds = IO::Select->new;
64              
65 0           $fds->add($client, \*STDIN);
66 0           $client->blocking(0);
67              
68 0           for (;;) {
69 0           my ($rd, undef, $err) = IO::Select->select($fds, undef, $fds, 10);
70              
71 0 0 0       if ($err && @$err) {
72 0           die "One of the handles became invalid";
73             }
74              
75 0           for my $hnd (@$rd) {
76 0 0         if ($hnd == $client) {
77 0           _from_to($client, \*STDOUT);
78             }
79 0 0         if ($hnd == \*STDIN) {
80 0           while (defined(my $key = ReadKey -1, \*STDIN)) {
81 0           my $ok = do {
82 0           local $SIG{PIPE} = 'IGNORE';
83 0           syswrite $client, $key;
84             };
85 0 0         die "Error during write: $!" if !defined $ok;
86 0 0         if ($key eq EOT) {
87 0           syswrite *STDOUT, "^D\n";
88 0           return;
89             }
90             }
91             }
92             }
93             }
94             }
95              
96             sub _from_to {
97 0     0     my ($from, $to) = @_;
98 0           my $buff;
99              
100 0           my $count = sysread $from, $buff, 1000;
101 0 0         die "Error during read: $!" if !defined $count;
102 0           my $written = syswrite $to, $buff, $count;
103 0 0 0       die "Error during write: $!" if !defined $written || $written != $count;
104             }
105              
106             sub close {
107 0     0 0   my ($self) = @_;
108              
109 0 0         $self->{socket}->close if $self->{socket};
110             }
111              
112             1;