perl/lib/Net/REPL/Server.pm

   1 package Net::REPL::Server;
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME
   8
   9 Net::REPL::Server - Eval + Socket = interactive development
  10
  11 =head1 DESCRIPTION
  12
  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.
  16
  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.
  21
  22 =head2 Methods
  23
  24 =cut
  25
  26 use base qw(Net::REPL::Base);
  27
  28 use Data::Dumper;
  29
  30 =head3 new(argument => value...)
  31
  32 Arguments:
  33
  34 =over
  35
  36 =item C<socket_class>
  37
  38 E.g. L<IO::Socket::UNIX> (the default) or L<IO::Socket::INET>.
  39
  40 =item C<socket_args>
  41
  42 Hashref of arguments for the socket class.
  43
  44 =item C<debug>
  45
  46 Debug level (refer to L<Net::REPL::Base>).
  47
  48 =back
  49
  50 =cut
  51
  52 sub new {
  53     my $proto = shift;
  54     my $class = ref($proto) || $proto;
  55     my $self = {
  56         'socket_class' => 'IO::Socket::UNIX',
  57         'socket_args' => {},
  58         @_,
  59     };
  60     bless($self, $class);
  61
  62     $self->debug('Server starting:', Dumper($self->{'socket_args'}));
  63
  64     my $server = $self->_create_socket(
  65         'Proto' => 'SOCK_STREAM',
  66         'Reuse' => 1,
  67         'Listen' => 1,
  68         %{$self->{'socket_args'}},
  69     );
  70     if (not $server) {
  71         die("Couldn't start server: $!\n");
  72     }
  73     $self->{'server'} = $server;
  74     $self->cb_listen();
  75
  76     $self->{'fh'} = undef;
  77
  78     return $self;
  79 }
  80
  81 sub DESTROY {
  82     my ($self) = @_;
  83
  84     if ($self->{'server'}) {
  85         $self->{'server'}->close();
  86         $self->{'server'} = undef;
  87     }
  88     $self->close_fh();
  89 }
  90
  91 sub close_fh {
  92     my ($self) = @_;
  93
  94     if ($self->{'fh'}) {
  95         $self->{'fh'}->close();
  96         $self->{'fh'} = undef;
  97         $self->cb_disconnect();
  98     }
  99 }
 100
 101 =head3 interact()
 102
 103 Run one iteration of the REPL. Returns true if the socket remains open
 104 for further iterations.
 105
 106 Blocks until a line of input can be read from the client socket and
 107 the result flushed out to it.
 108
 109 =cut
 110
 111 sub interact {
 112     my ($self) = @_;
 113
 114     if (not $self->{'fh'}) {
 115         $self->{'fh'} = $self->{'server'}->accept();
 116         if ($self->{'fh'}) {
 117             $self->cb_connect();
 118         }
 119         else {
 120             # Accept didn't.
 121             $self->{'fh'} = undef;
 122             return;
 123         }
 124     }
 125
 126     my $input = $self->lv_receive();
 127     if (not $input) {
 128         $self->close_fh();
 129         return 0;
 130     }
 131     my @output = $self->formatted_eval($input);
 132     my $output_s = "@output";
 133     $self->lv_send($output_s);
 134     return 1;
 135 }
 136
 137 =head2 Callback Methods
 138
 139 =over
 140
 141 =item C<cb_listen()>
 142
 143 Called when the Server begins to listen for client connections.
 144
 145 =item C<cb_connect()>
 146
 147 Called whenever a client connection is accepted.
 148
 149 =item C<cb_disconnect()>
 150
 151 Called whenever a client disconnects.
 152
 153 =back
 154
 155 =cut
 156
 157 sub cb_listen {
 158     my ($self) = @_;
 159     $self->debug("Server PID $$ listening.");
 160 }
 161
 162 sub cb_connect {
 163     my ($self) = @_;
 164
 165     if (not $self->{'fh'}) {
 166         return;
 167     }
 168     my $client_details = '';
 169     if ($self->{'fh'}->can('peerhost')) {
 170         $client_details = ' '
 171           . $self->{'fh'}->peerhost()
 172           . ':'
 173           . $self->{'fh'}->peerport();
 174
 175     }
 176     $self->debug("Server PID $$ connected" . $client_details);
 177 }
 178
 179 sub cb_disconnect {
 180     my ($self) = @_;
 181 }
 182
 183 1;