File Coverage

blib/lib/DBGp/Client/Listener.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package DBGp::Client::Listener;
2              
3 1     1   1210 use strict;
  1         2  
  1         26  
4 1     1   3 use warnings;
  1         2  
  1         22  
5              
6             =head1 NAME
7              
8             DBGp::Client::Listener - wait for incoming DBGp connections
9              
10             =head1 SYNOPSIS
11              
12             $listener = DBGp::Client::Listener->new(
13             port => 9000,
14             );
15             $listener->listen;
16              
17             $connection = $listener->accept;
18              
19             # use the methods in the DBGp::Client::Connection object
20              
21             =head1 DESCRIPTION
22              
23             The main entry point for L: listens for incoming
24             debugger connections and returns a L object.
25              
26             =head1 METHODS
27              
28             =cut
29              
30 1     1   438 use IO::Socket;
  1         18187  
  1         3  
31              
32 1     1   520 use DBGp::Client::Connection;
  0            
  0            
33              
34             =head2 new
35              
36             my $listener = DBGp::Client::Listener->new(%opts);
37              
38             Possible options are C to specify a TCP port, and C to
39             specify the path for an Unix-domain socket.
40              
41             For Unix-domain socket, passing C performs an additional
42             C call before starting to listen for connections.
43              
44             =cut
45              
46             sub new {
47             my ($class, %args) = @_;
48             my $self = bless {
49             port => $args{port},
50             path => $args{path},
51             mode => $args{mode},
52             socket => undef,
53             }, $class;
54              
55             die "Specify either 'port' or 'path'" unless $self->{port} || $self->{path};
56              
57             return $self;
58             }
59              
60             =head2 listen
61              
62             $listener->listen;
63              
64             Starts listening on the endpoint specified to the constructor;
65             Cs if there is an error.
66              
67             =cut
68              
69             sub listen {
70             my ($self) = @_;
71              
72             if ($self->{port}) {
73             $self->{socket} = IO::Socket::INET->new(
74             Listen => 1,
75             LocalAddr => '127.0.0.1',
76             LocalPort => $self->{port},
77             Proto => 'tcp',
78             ReuseAddr => 1,
79             ReusePort => 1,
80             );
81             } elsif ($self->{path}) {
82             if (-S $self->{path}) {
83             unlink $self->{path} or die "Unable to unlink stale socket: $!";
84             }
85              
86             $self->{socket} = IO::Socket::UNIX->new(
87             Local => $self->{path},
88             );
89             if ($self->{socket} && defined $self->{mode}) {
90             chmod $self->{mode}, $self->{path}
91             or $self->{socket} = undef;
92             }
93             if ($self->{socket}) {
94             $self->{socket}->listen(1)
95             or $self->{socket} = undef;
96             }
97             }
98              
99             die "Unable to start listening: $!" unless $self->{socket};
100             }
101              
102             =head2 accept
103              
104             my $connection = $listener->accept;
105              
106             Waits for an incoming debugger connection and returns a
107             fully-initialized L object; it calls
108             L on the connection object to
109             read and parse the initialization message.
110              
111             =cut
112              
113             sub accept {
114             my ($self) = @_;
115             my $sock = $self->{socket}->accept;
116              
117             return undef if !$sock;
118              
119             my $conn = DBGp::Client::Connection->new(socket => $sock);
120              
121             $conn->parse_init;
122              
123             return $conn;
124             }
125              
126             1;
127              
128             __END__