perl/lib/Net/REPL/Base.pm

   1 package Net::REPL::Base;
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME
   8
   9 Net::REPL::Base - Utilities for REPL clients and servers.
  10
  11 =head1 DESCRIPTION
  12
  13 This contains the protocol implementation and various other simple
  14 utilities.
  15
  16 The REPL protocol uses length/value strings. A value is encoded to one
  17 of these strings by concatenating its 32-bit unsigned big-endian
  18 length with the value as a bytestring.
  19
  20 =head2 Methods
  21
  22 =cut
  23
  24 use Data::Dumper;
  25 use IO::Socket;
  26
  27 =head3 lv_receive()
  28
  29 Read and return one length/value encoded string from the file handle.
  30
  31 Dies if an error (like the socket closing unexpectedly) occurs during
  32 the read call. Returns a partial string or undef if the read is merely
  33 incomplete.
  34
  35 =cut
  36
  37 sub lv_receive {
  38     my ($self) = @_;
  39
  40     my $total_length = unpack('N', $self->_read_fh(4));
  41     if (not defined($total_length)) {
  42         return;
  43     }
  44     # $self->debug('Incoming message:', $total_length);
  45     my $message = $self->_read_fh($total_length);
  46     return unpack('a*', $message);
  47 }
  48
  49 sub _read_fh {
  50     my ($self, $length) = @_;
  51
  52     my $data;
  53     my $result = sysread($self->{'fh'}, $data, $length);
  54     if (not defined($result)) {
  55         $self->debug("REPL PID $$ reading: $!")
  56     }
  57     return $data;
  58
  59 }
  60
  61 =head3 lv_send($message)
  62
  63 Encode $message as a length/value string and write it to the file handle.
  64
  65 =cut
  66
  67 sub lv_send {
  68     my ($self, $message) = @_;
  69
  70     my $length = length($message);
  71     my $initial = pack('N', $length);
  72     $self->{'fh'}->send($initial . $message);
  73     $self->{'fh'}->flush();
  74 }
  75
  76 =head3 debug(@words)
  77
  78 Write words to the debug log according to the current debug level.
  79
  80 The default implementation writes to STDERR and uses the debug level
  81 as a boolean (i.e., 0 or other false values disable it).
  82
  83 =cut
  84
  85 sub debug {
  86     my ($self, @words) = @_;
  87
  88     if ($self->{'debug'}) {
  89         print STDERR join(' ', 'REPL:', @words) . "\n";
  90     }
  91 }
  92
  93 =head3 formatted_eval($code)
  94
  95 Eval the Perl $code and return the Dumper'd or serialized result.
  96
  97 =cut
  98
  99 # TODO: integrate with Devel::REPL
 100 sub formatted_eval {
 101     my ($self, $input) = @_;
 102
 103     my @output;
 104     do {
 105         local $SIG{'__DIE__'} = 'DEFAULT';
 106         @output = eval('sub { ' . $input . '}->();');
 107     };
 108     # TODO: should this also pass through warnings?
 109     if ($@) {
 110         return $@;
 111     }
 112     else {
 113         my $dumper = Data::Dumper->new(\@output);
 114         $dumper->Deparse(1);
 115         return $dumper->Dump();
 116     }
 117 }
 118
 119 ### Internal methods
 120
 121 sub _create_socket {
 122     my ($self, %socket_args) = @_;
 123
 124     my $domain = $socket_args{'Domain'};
 125     if (not defined($domain)) {
 126         die('Socket "Domain" argument is mandatory');
 127     }
 128
 129     my $pkg = $IO::Socket::domain2pkg[$domain];
 130     if (defined($pkg)) {
 131         eval("use $pkg;");
 132     }
 133     return IO::Socket->new(
 134         %socket_args,
 135     );
 136 }
 137
 138 1;