thrasherbird.pl: Item disco target config was missing.
[thrasher.git] / perl / lib / Net / REPL / Server.pm
blobdf176feacefe9748acc69bfca0cfd1e1bf76b467
1 package Net::REPL::Server;
2 use strict;
3 use warnings;
5 =pod
7 =head1 NAME
9 Net::REPL::Server - Eval + Socket = interactive development
11 =head1 DESCRIPTION
13 Perl processes running Server objects accept and run code
14 interactively from remote clients. Perl code is received over a
15 socket, eval'd, and the Dumper'd result(s) are sent back.
17 This class can be used as-is or superclassed to plug into an event
18 loop or provide additional capabilities like Devel::REPL integration
19 or serializing results so that usuable Perl data structures can be
20 exchanged bidirectionally.
22 =head2 Methods
24 =cut
26 use base qw(Net::REPL::Base);
28 use Data::Dumper;
29 use Socket qw(AF_UNIX);
31 =head3 new(argument => value...)
33 Arguments:
35 =over
37 =item C<socket_args>
39 Hashref of arguments for L<IO::Socket> configuration. Use C<Domain> to
40 select a socket class.
42 =item C<debug>
44 Debug level (refer to L<Net::REPL::Base>).
46 =back
48 =cut
50 sub new {
51 my $proto = shift;
52 my $class = ref($proto) || $proto;
53 my $self = {
54 'socket_args' => {},
55 @_,
57 bless($self, $class);
59 $self->debug('Server starting:', Dumper($self->{'socket_args'}));
61 my $server = $self->_create_socket(
62 'Domain' => AF_UNIX,
63 'Proto' => 'SOCK_STREAM',
64 'Reuse' => 1,
65 'Listen' => 1,
66 %{$self->{'socket_args'}},
68 if (not $server) {
69 die("Couldn't start server: $!\n");
71 $self->{'server'} = $server;
72 $self->cb_listen();
74 $self->{'fh'} = undef;
76 return $self;
79 sub DESTROY {
80 my ($self) = @_;
82 if ($self->{'server'}) {
83 $self->{'server'}->close();
84 $self->{'server'} = undef;
86 $self->close_fh();
89 sub close_fh {
90 my ($self) = @_;
92 if ($self->{'fh'}) {
93 $self->{'fh'}->close();
94 $self->{'fh'} = undef;
95 $self->cb_disconnect();
99 =head3 interact()
101 Run one iteration of the REPL. Returns true if the socket remains open
102 for further iterations.
104 Blocks until a line of input can be read from the client socket and
105 the result flushed out to it.
107 =cut
109 sub interact {
110 my ($self) = @_;
112 if (not $self->{'fh'}) {
113 $self->{'fh'} = $self->{'server'}->accept();
114 if ($self->{'fh'}) {
115 $self->cb_connect();
117 else {
118 # Accept didn't.
119 $self->{'fh'} = undef;
120 return;
124 my $input = $self->lv_receive();
125 if (not $input) {
126 $self->close_fh();
127 return 0;
129 my @output = $self->formatted_eval($input);
130 my $output_s = "@output";
131 $self->lv_send($output_s);
132 return 1;
135 =head2 Callback Methods
137 =over
139 =item C<cb_listen()>
141 Called when the Server begins to listen for client connections.
143 =item C<cb_connect()>
145 Called whenever a client connection is accepted.
147 =item C<cb_disconnect()>
149 Called whenever a client disconnects.
151 =back
153 =cut
155 sub cb_listen {
156 my ($self) = @_;
157 $self->debug("Server PID $$ listening.");
160 sub cb_connect {
161 my ($self) = @_;
163 if (not $self->{'fh'}) {
164 return;
166 my $client_details = '';
167 if ($self->{'fh'}->can('peerhost')) {
168 $client_details = ' '
169 . $self->{'fh'}->peerhost()
170 . ':'
171 . $self->{'fh'}->peerport();
174 $self->debug("Server PID $$ connected" . $client_details);
177 sub cb_disconnect {
178 my ($self) = @_;