File Coverage

blib/lib/Test/Reporter/Transport/Metabase.pm
Criterion Covered Total %
statement 36 71 50.7
branch 0 16 0.0
condition 0 3 0.0
subroutine 12 15 80.0
pod 2 2 100.0
total 50 107 46.7


line stmt bran cond sub pod time code
1 1     1   23128 use 5.006;
  1         4  
  1         48  
2 1     1   7 use warnings;
  1         1  
  1         38  
3 1     1   6 use strict;
  1         6  
  1         87  
4             package Test::Reporter::Transport::Metabase;
5             # ABSTRACT: Metabase transport for Test::Reporter
6              
7             our $VERSION = '1.999009';
8              
9 1     1   662 use Test::Reporter::Transport 1.57 ();
  1         190  
  1         43  
10             our @ISA = qw/Test::Reporter::Transport/;
11              
12 1     1   7 use Carp ();
  1         1  
  1         19  
13 1     1   703 use Config::Perl::V ();
  1         2890  
  1         53  
14 1     1   763 use CPAN::Testers::Report 1.999001 ();
  1         51834  
  1         32  
15 1     1   9 use File::Glob ();
  1         2  
  1         20  
16 1     1   6 use JSON 2 ();
  1         13  
  1         22  
17 1     1   546 use Metabase::User::Profile 0.016 ();
  1         2642  
  1         31  
18 1     1   516 use Metabase::User::Secret 0.016 ();
  1         292  
  1         28  
19 1     1   558 use Metabase::Client::Simple 0.008 ();
  1         82754  
  1         663  
20              
21             #--------------------------------------------------------------------------#
22             # argument definitions
23             #--------------------------------------------------------------------------#
24              
25             my %default_args = (
26             client => 'Metabase::Client::Simple'
27             );
28             my @allowed_args = qw/uri id_file client/;
29             my @required_args = qw/uri id_file/;
30              
31             #--------------------------------------------------------------------------#
32             # new
33             #--------------------------------------------------------------------------#
34              
35             sub new {
36 0     0 1   my $class = shift;
37 0 0         Carp::confess __PACKAGE__ . " requires transport args in key/value pairs\n"
38             if @_ % 2;
39 0           my %args = ( %default_args, @_ );
40            
41 0           for my $k ( @required_args ) {
42 0 0         Carp::confess __PACKAGE__ . " requires $k argument\n"
43             unless exists $args{$k};
44             }
45              
46 0           for my $k ( keys %args ) {
47 0           Carp::confess __PACKAGE__ . " unknown argument '$k'\n"
48 0 0         unless grep { $k eq $_ } @allowed_args;
49             }
50              
51 0           return bless \%args => $class;
52             }
53              
54             #--------------------------------------------------------------------------#
55             # send
56             #--------------------------------------------------------------------------#
57              
58             sub send {
59 0     0 1   my ($self, $report) = @_;
60              
61 0 0         unless ( eval { $report->distfile } ) {
  0            
62 0           Carp::confess __PACKAGE__ . ": requires the 'distfile' parameter to be set\n"
63             . "Please update CPAN::Reporter and/or CPANPLUS to a version that provides \n"
64             . "this information to Test::Reporter. Report will not be sent.\n";
65             }
66              
67 0           my ($profile, $secret) = $self->_load_id_file;
68              
69             # Load specified metabase client.
70 0           my $class = $self->{client};
71 0 0         eval "require $class"
72             or Carp::confess __PACKAGE__ . ": could not load client '$class':\n$@\n";
73              
74 0           my $client = $class->new(
75             uri => $self->{uri},
76             profile => $profile,
77             secret => $secret,
78             );
79              
80             # Get facts about Perl config that Test::Reporter doesn't capture
81             # Unfortunately we can't do this from the current perl in case this
82             # is a report regenerated from a file and isn't the perl that the report
83             # was run on
84 0           my $perlv = $report->{_perl_version}->{_myconfig};
85 0           my $config = Config::Perl::V::summary(Config::Perl::V::plv2hash($perlv));
86 0   0       my $perl_version = $report->{_perl_version}{_version} || $config->{version};
87              
88             # Build CPAN::Testers::Report with its various component facts.
89 0           my $metabase_report = CPAN::Testers::Report->open(
90             resource => 'cpan:///distfile/' . $report->distfile
91             );
92              
93 0           $metabase_report->add( 'CPAN::Testers::Fact::LegacyReport' => {
94             grade => $report->grade,
95             osname => $config->{osname},
96             osversion => $report->{_perl_version}{_osvers},
97             archname => $report->{_perl_version}{_archname},
98             perl_version => $perl_version,
99             textreport => $report->report
100             });
101              
102             # TestSummary happens to be the same as content metadata
103             # of LegacyReport for now
104 0           $metabase_report->add( 'CPAN::Testers::Fact::TestSummary' =>
105             [$metabase_report->facts]->[0]->content_metadata()
106             );
107            
108             # XXX wish we could fill these in with stuff from CPAN::Testers::ParseReport
109             # but it has too many dependencies to require for T::R::Transport::Metabase.
110             # Could make it optional if installed? Will do this for the offline NNTP
111             # archive conversion, so maybe wait until that is written then move here and
112             # use if CPAN::Testers::ParseReport is installed -- dagolden, 2009-03-30
113             # $metabase_report->add( 'CPAN::Testers::Fact::TestOutput' => $stuff );
114             # $metabase_report->add( 'CPAN::Testers::Fact::TesterComment' => $stuff );
115             # $metabase_report->add( 'CPAN::Testers::Fact::PerlConfig' => $stuff );
116             # $metabase_report->add( 'CPAN::Testers::Fact::TestEnvironment' => $stuff );
117             # $metabase_report->add( 'CPAN::Testers::Fact::Prereqs' => $stuff );
118             # $metabase_report->add( 'CPAN::Testers::Fact::InstalledModules' => $stuff );
119              
120 0           $metabase_report->close();
121              
122 0           return $client->submit_fact($metabase_report);
123             }
124              
125             sub _load_id_file {
126 0     0     my ($self) = shift;
127            
128 0 0         open my $fh, "<", File::Glob::bsd_glob( $self->{id_file} )
129             or Carp::confess __PACKAGE__. ": could not read ID file '$self->{id_file}'"
130             . "\n$!";
131            
132 0           my $data = JSON->new->ascii->decode( do { local $/; <$fh> } );
  0            
  0            
133              
134 0 0         my $profile = eval { Metabase::User::Profile->from_struct($data->[0]) }
  0            
135             or Carp::confess __PACKAGE__ . ": could not load Metabase profile\n"
136             . "from '$self->{id_file}':\n$@";
137              
138 0 0         my $secret = eval { Metabase::User::Secret->from_struct($data->[1]) }
  0            
139             or Carp::confess __PACKAGE__ . ": could not load Metabase secret\n"
140             . "from '$self->{id_file}':\n $@";
141              
142 0           return ($profile, $secret);
143             }
144              
145             1;
146              
147             __END__