view release on metacpan or  search on metacpan

lib/Test/Reporter/Transport/Socket.pm  view on Meta::CPAN

package Test::Reporter::Transport::Socket;
$Test::Reporter::Transport::Socket::VERSION = '1.02';
# ABSTRACT: Simple socket transport for Test::Reporter

use strict;
use warnings;
use Carp ();
use Storable qw[nfreeze];
use base qw[Test::Reporter::Transport];

my @required_args = qw/host port/;

my $sockclass;

BEGIN {
  eval {
    require IO::Socket::IP;
    $sockclass = 'IO::Socket::IP';
  };
  if ( !$sockclass ) {
    require IO::Socket::INET;
    $sockclass = 'IO::Socket::INET';
  }
}

sub new {
  my $class = shift;
  Carp::confess __PACKAGE__ . " requires transport args in key/value pairs\n"
    if @_ % 2;
  my %args = @_;
  $args{lc $_} = delete $args{$_} for keys %args;

  for my $k ( @required_args ) {
    Carp::confess __PACKAGE__ . " requires $k argument\n"
      unless exists $args{$k};
  }

  if ( ref $args{host} eq 'ARRAY' and !scalar @{ $args{host} } ) {
    Carp::confess __PACKAGE__ . " requires 'host' argument to have elements if it is an arrayref\n";
  }

  return bless \%args => $class;
}

sub send {
  my ($self, $report) = @_;

  unless ( eval { $report->distfile } ) {
    Carp::confess __PACKAGE__ . ": requires the 'distfile' parameter to be set\n"
      . "Please update your CPAN testing software to a version that provides \n"
      . "this information to Test::Reporter.  Report will not be sent.\n";
  }

  # Open the socket to the given host:port
  # confess on failure.

  my $sock;

  foreach my $host ( ( ref $self->{host} eq 'ARRAY' ? @{ $self->{host} } : $self->{host} ) ) {
    $sock = $sockclass->new(
      PeerAddr => $host,
      PeerPort => $self->{port},
      Proto    => 'tcp'
    );
    last if $sock;
  }

  unless ( $sock ) {
    Carp::confess __PACKAGE__ . ": could not connect to '$self->{host}' '$!'\n";
  }

  # Get facts about Perl config that Test::Reporter doesn't capture
  # Unfortunately we can't do this from the current perl in case this
  # is a report regenerated from a file and isn't the perl that the report
  # was run on
  my $perlv = $report->{_perl_version}->{_myconfig};
  my $config = TRTS::Config::Perl::V::summary(TRTS::Config::Perl::V::plv2hash($perlv));
  my $perl_version = $report->{_perl_version}{_version} || $config->{version};

  my $data = {
    distfile      => $report->distfile,
    grade         => $report->grade,
    osname        => $config->{osname},
    osversion     => $report->{_perl_version}{_osvers},
    archname      => $report->{_perl_version}{_archname},
    perl_version  => $perl_version,
    textreport    => $report->report
  };

  my $froze;
  eval { $froze = nfreeze( $data ); };

  Carp::confess __PACKAGE__ . ": Could not freeze data '$@'\n"
    unless $froze;

  # Thanks to Tony Cook for this

  while ( length( $froze ) ) {
    my $sent = $sock->send( $froze ) or Carp::confess "Could not send data '$!'\n";
    substr( $froze, 0, $sent, '' );
  }