File Coverage

blib/lib/CPAN/Testers/Schema/ResultSet/TestReport.pm
Criterion Covered Total %
statement 28 36 77.7
branch 3 8 37.5
condition n/a
subroutine 5 6 83.3
pod 2 2 100.0
total 38 52 73.0


line stmt bran cond sub pod time code
1 13     13   14780 use utf8;
  13         36  
  13         89  
2             package CPAN::Testers::Schema::ResultSet::TestReport;
3             our $VERSION = '0.024';
4             # ABSTRACT: Query the raw test reports
5              
6             #pod =head1 SYNOPSIS
7             #pod
8             #pod my $rs = $schema->resultset( 'TestReport' );
9             #pod $rs->insert_metabase_fact( $fact );
10             #pod
11             #pod =head1 DESCRIPTION
12             #pod
13             #pod This object helps to insert and query the raw test reports.
14             #pod
15             #pod =head1 SEE ALSO
16             #pod
17             #pod L<CPAN::Testers::Schema::Result::TestReport>, L<DBIx::Class::ResultSet>,
18             #pod L<CPAN::Testers::Schema>
19             #pod
20             #pod =cut
21              
22 13     13   903 use CPAN::Testers::Schema::Base 'ResultSet';
  13         49  
  13         89  
23 13     13   539 use Scalar::Util qw( blessed );
  13         33  
  13         733  
24 13     13   78 use Log::Any qw( $LOG );
  13         36  
  13         83  
25              
26             #pod =method dist
27             #pod
28             #pod my $rs = $rs->dist( 'Perl 5', 'CPAN-Testers-Schema' );
29             #pod my $rs = $rs->dist( 'Perl 5', 'CPAN-Testers-Schema', '0.012' );
30             #pod
31             #pod Fetch reports only for the given distribution, optionally for the given
32             #pod version. Returns a new C<CPAN::Testers::Schema::ResultSet::TestReport>
33             #pod object that will only return reports with the given data.
34             #pod
35             #pod This can be used to scan the full reports for specific data.
36             #pod
37             #pod =cut
38              
39 0     0 1 0 sub dist( $self, $lang, $dist, $version=undef ) {
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
40 0 0       0 return $self->search( {
41             'report' => [ -and =>
42             \[ "->> '\$.environment.language.name'=?", $lang ],
43             \[ "->> '\$.distribution.name'=?", $dist ],
44             ( defined $version ? (
45             \[ "->> '\$.distribution.version'=?", $version ],
46             ) : () ),
47             ],
48             } );
49             }
50              
51             #pod =method insert_metabase_fact
52             #pod
53             #pod my $row = $rs->insert_metabase_fact( $fact );
54             #pod
55             #pod Convert a L<Metabase::Fact> object to the new test report structure and
56             #pod insert it into the database. This is for creating backwards-compatible
57             #pod APIs.
58             #pod
59             #pod =cut
60              
61 2     2 1 1064169 sub insert_metabase_fact( $self, $fact ) {
  2         7  
  2         9  
  2         8  
62 2         25 $LOG->infof( 'Inserting test report from Metabase fact (%s)', $fact->core_metadata->{guid} );
63 2         73 my ( $fact_report ) = grep { blessed $_ eq 'CPAN::Testers::Fact::LegacyReport' } $fact->content->@*;
  4         28  
64             my %fact_data = (
65             $fact_report->content->%*,
66             $fact->core_metadata->%{qw( creation_time guid )},
67 2         15 $fact->core_metadata->{resource}->metadata->%{qw( dist_name dist_version dist_file cpan_id )},
68             );
69              
70 2         102 my $user_id = $fact->core_metadata->{creator}->resource;
71 2         45 my ( $metabase_user ) = $self->result_source->schema->resultset( 'MetabaseUser' )
72             ->search( { resource => $user_id }, { order_by => { -desc => 'id' }, limit => 1 } )->all;
73              
74 2 50       9651 if ( !$metabase_user ) {
75 0         0 warn $LOG->warn( "Could not find metabase user $user_id" ) . "\n";
76             }
77              
78             # Remove leading "v" from Perl version
79 2         181 $fact_data{perl_version} =~ s/^v+//;
80              
81             my %report = (
82             reporter => {
83             name => ( $metabase_user ? $metabase_user->fullname : 'Unknown' ),
84             email => ( $metabase_user ? $metabase_user->email : undef ),
85             },
86             environment => {
87             system => {
88             osname => $fact_data{osname},
89             osversion => $fact_data{osversion},
90             },
91             language => {
92             name => "Perl 5",
93             version => $fact_data{perl_version},
94             archname => $fact_data{archname},
95             },
96             },
97             distribution => {
98             name => $fact_data{dist_name},
99             version => $fact_data{dist_version},
100             },
101             result => {
102             grade => lc $fact_data{grade},
103             output => {
104             uncategorized => $fact_data{textreport},
105             },
106             }
107 2 50       79 );
    50          
108              
109 2         330 my $format = DateTime::Format::ISO8601->new();
110 2         301 my $creation = $format->parse_datetime( $fact->creation_time );
111              
112 2         2145 return $self->update_or_create({
113             id => $fact->guid,
114             created => $creation,
115             report => \%report,
116             });
117             }
118              
119             1;
120              
121             __END__
122              
123             =pod
124              
125             =head1 NAME
126              
127             CPAN::Testers::Schema::ResultSet::TestReport - Query the raw test reports
128              
129             =head1 VERSION
130              
131             version 0.024
132              
133             =head1 SYNOPSIS
134              
135             my $rs = $schema->resultset( 'TestReport' );
136             $rs->insert_metabase_fact( $fact );
137              
138             =head1 DESCRIPTION
139              
140             This object helps to insert and query the raw test reports.
141              
142             =head1 METHODS
143              
144             =head2 dist
145              
146             my $rs = $rs->dist( 'Perl 5', 'CPAN-Testers-Schema' );
147             my $rs = $rs->dist( 'Perl 5', 'CPAN-Testers-Schema', '0.012' );
148              
149             Fetch reports only for the given distribution, optionally for the given
150             version. Returns a new C<CPAN::Testers::Schema::ResultSet::TestReport>
151             object that will only return reports with the given data.
152              
153             This can be used to scan the full reports for specific data.
154              
155             =head2 insert_metabase_fact
156              
157             my $row = $rs->insert_metabase_fact( $fact );
158              
159             Convert a L<Metabase::Fact> object to the new test report structure and
160             insert it into the database. This is for creating backwards-compatible
161             APIs.
162              
163             =head1 SEE ALSO
164              
165             L<CPAN::Testers::Schema::Result::TestReport>, L<DBIx::Class::ResultSet>,
166             L<CPAN::Testers::Schema>
167              
168             =head1 AUTHORS
169              
170             =over 4
171              
172             =item *
173              
174             Oriol Soriano <oriolsoriano@gmail.com>
175              
176             =item *
177              
178             Doug Bell <preaction@cpan.org>
179              
180             =back
181              
182             =head1 COPYRIGHT AND LICENSE
183              
184             This software is copyright (c) 2018 by Oriol Soriano, Doug Bell.
185              
186             This is free software; you can redistribute it and/or modify it under
187             the same terms as the Perl 5 programming language system itself.
188              
189             =cut