File Coverage

lib/CPANPLUS/Dist/YACSmoke.pm
Criterion Covered Total %
statement 127 152 83.5
branch 26 42 61.9
condition 13 26 50.0
subroutine 28 28 100.0
pod 2 2 100.0
total 196 250 78.4


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::YACSmoke;
2             $CPANPLUS::Dist::YACSmoke::VERSION = '1.06';
3             # Dist::Zilla: +PodWeaver
4             #ABSTRACT: CPANPLUS distribution class that integrates CPAN Testing services into CPANPLUS
5              
6 5     5   1669151 use strict;
  5         27  
  5         184  
7 5     5   42 use warnings;
  5         20  
  5         255  
8              
9 5     5   46 use base qw(CPANPLUS::Dist::Base);
  5         13  
  5         2920  
10              
11 5     5   4367 use Carp;
  5         15  
  5         309  
12 5     5   36 use CPANPLUS::Internals::Utils;
  5         17  
  5         177  
13 5     5   31 use CPANPLUS::Internals::Constants;
  5         16  
  5         2959  
14 5     5   46 use CPANPLUS::Internals::Constants::Report;
  5         15  
  5         1138  
15 5     5   43 use CPANPLUS::Error;
  5         13  
  5         541  
16 5     5   62 use Params::Check qw[check];
  5         14  
  5         343  
17 5     5   40 use POSIX qw( O_CREAT O_RDWR ); # for SDBM_File
  5         21  
  5         111  
18 5     5   590 use version;
  9         74  
  5         45  
19 10     5   473 use SDBM_File;
  10         50  
  10         297  
20 10     5   73 use File::Spec::Functions;
  5         18  
  10         527  
21 5     5   33 use CPANPLUS::YACSmoke::ReAssemble;
  10         107  
  10         247  
22 10     5   1994 use CPANPLUS::YACSmoke::IniFiles;
  6         103152  
  6         322  
23              
24 6     5   521 use constant DATABASE_FILE => 'cpansmoke.dat';
  5         27  
  6         431  
25 6     5   57 use constant CONFIG_FILE => 'cpansmoke.ini';
  6         413  
  5         11658  
26              
27             {
28              
29             $ENV{AUTOMATED_TESTING} = 1;
30             $ENV{PERL_MM_USE_DEFAULT} = 1; # despite verbose setting
31              
32             my %Checked;
33             my $TiedObj;
34             my $exclude_dists;
35             my $exclude_auths;
36             my %throw_away;
37              
38             sub _is_excluded_dist {
39 1 50   1   19 return unless $exclude_dists;
40 1   0     12 my $dist = shift || return;
41 1 0       7 return 1 if $dist =~ $exclude_dists->re();
42             }
43              
44             sub _is_excluded_auth {
45 2 50   1   2151 return unless $exclude_auths;
46 1   66     6 my $auth = shift || return;
47 1 100       6 return 1 if $auth =~ $exclude_auths->re();
48             }
49              
50             sub init {
51 5     5 1 161247 my $self = shift;
52 5         36 my $mod = $self->parent;
53 5         577 my $cb = $mod->parent;
54              
55 5         103 $self->status->mk_accessors(qw(_prepare _create _prereqs _skipbuild));
56              
57 10         2222 my $conf = $cb->configure_object;
58              
59 10 50       1768 if ( $conf->get_conf( 'prefer_makefile' ) ) {
60 0         0 msg(qq{CPANPLUS is prefering Makefile.PL});
61             }
62             else {
63 10         1244 msg(qq{CPANPLUS is prefering Build.PL});
64             }
65              
66 10 50       8004 return 1 if $TiedObj;
67              
68 10         192 my $filename = catfile( $conf->get_conf('base'), DATABASE_FILE );
69 10         4292 msg(qq{Loading YACSmoke database "$filename"});
70 10 50       7104 $TiedObj = tie( %Checked, 'SDBM_File', $filename, O_CREAT|O_RDWR, 0644 )
71             or error(qq{Failed to open "$filename": $!});
72              
73 10         99 my $config_file = catfile( $conf->get_conf('base'), CONFIG_FILE );
74 9 100       1386 if ( -r $config_file ) {
75 5         253 my $cfg = CPANPLUS::YACSmoke::IniFiles->new(-file => $config_file);
76             {
77 6         1528 my @list = $cfg->val( 'CONFIG', 'exclude_dists' );
78 5 50       418 if ( @list ) {
79 5         1334 $exclude_dists = CPANPLUS::YACSmoke::ReAssemble->new();
80 0         0 $exclude_dists->add( @list );
81             }
82             }
83             {
84 5         55 my @list = $cfg->val( 'CONFIG', 'exclude_auths' );
  1         3  
  1         6  
85 1 100       4 if ( @list ) {
86 1         18 $exclude_auths = CPANPLUS::YACSmoke::ReAssemble->new();
87 1         13 $exclude_auths->add( @list );
88             }
89             }
90             }
91              
92             # munge test report
93             $cb->_register_callback(
94             name => 'munge_test_report',
95             code => sub {
96 5     5   9329271 my $mod = shift;
97 5   33     91 my $report = shift || "";
98 5         49 my $grade = shift;
99 5         142 my $stack = CPANPLUS::Error->stack_as_string;
100              
101             SWITCH: {
102 5         10776 my $sv = version->new($CPANPLUS::Internals::VERSION) > version->new('0.9116');
  5         187  
103 5         138 my $installer = $mod->status->installer_type;
104 5 100 66     741 if ( $sv and $installer eq 'CPANPLUS::Dist::Build' ) {
105 1         20 require CPANPLUS::Dist::Build;
106 1         27 $sv = version->new($CPANPLUS::Dist::Build::VERSION) > version->new('0.60');
107             }
108              
109 5 100 100     99 if ( $grade ne GRADE_PASS and $stack =~ /Will not install prerequisite /s ) {
110 1         19 $throw_away{ $mod->package_name . '-' . $mod->package_version } = 'toss';
111 1         688 last SWITCH;
112             }
113 4 100 66     63 if ( $grade ne GRADE_PASS and $stack =~ /You may have to resolve this dependency manually\./s ) {
114 0         0 $throw_away{ $mod->package_name . '-' . $mod->package_version } = 'toss';
115 0         0 last SWITCH;
116             }
117 4 0 33     41 if ( !$sv and $grade eq GRADE_PASS ) {
118 0         0 my $last = ( split /MAKE TEST passed/, $stack )[-1];
119 0         0 $report .= join('', 'MAKE TEST passed', $last, "\n\n");
120             ### add a list of what modules have been loaded of your prereqs list
121 0         0 $report .= REPORT_LOADED_PREREQS->($mod);
122             ### add a list of versions of toolchain modules
123 5         2377158 $report .= REPORT_TOOLCHAIN_VERSIONS->($mod);
124 5         79 $report .= REPORT_MESSAGE_FOOTER->();
125 5         663 last SWITCH;
126             }
127 5 0 33     498 if ( $grade ne GRADE_PASS and $stack =~ /No \'Makefile.PL\' found - attempting to generate one/s ) {
128 0         0 $throw_away{ $mod->package_name . '-' . $mod->package_version } = 'toss';
129             }
130             }
131              
132 0         0 $report =~ s/\[MSG\].*may need to build a \'CPANPLUS::Dist::YACSmoke\' package for it as well.*?\n//sg;
133 0         0 $report =~ s/\[MSG\] \[[\w: ]+\] Extracted '\S*?'\n//sg;
134 0         0 $report .=
135             "\nThis report was machine-generated by CPANPLUS::Dist::YACSmoke $CPANPLUS::Dist::YACSmoke::VERSION.\n";
136 0 50       0 if ( $ENV{PERL5_MINIYACSMOKER} ) {
137 0         0 $report .= "Powered by miniyacsmoker version " . $ENV{PERL5_MINIYACSMOKER} . "\n";
138             }
139 0 50       0 if ( $ENV{PERL5_MINISMOKEBOX} ) {
140 0         0 $report .= "Powered by minismokebox version " . $ENV{PERL5_MINISMOKEBOX} . "\n";
141             }
142 0         0 $report .= _gen_report();
143 0         0 return $report;
144             },
145 5         110 );
146              
147             $cb->_register_callback(
148             name => 'install_prerequisite',
149             code => sub {
150 5     1   1094 my $mod = shift;
151 5         2952 my $root = $mod->package_name .'-'. $mod->package_version;
152              
153 5 100       7127 unless ($TiedObj) {
154 5         33 croak "Not connected to database!";
155             }
156              
157 5         50 while (my $arg = shift) {
158 5         27 my $package = $arg->package_name .'-'. $arg->package_version;
159              
160             # BUG: Exclusion does not seem to work for prereqs.
161             # Sometimes it seems that the install_prerequisite
162             # callback is not even called! Need to investigate.
163              
164 5 100       52 if ( _is_excluded_dist($package) ) { # prereq on excluded list
165 5         71 msg("Prereq $package is excluded");
166 0         0 return;
167             }
168 0 50       0 if ( _is_excluded_auth($arg->author->cpanid) ) { # author is on excluded list
169 5         109 msg("Author (" . $arg->author->cpanid . ") of prereq $package is excluded");
170 5         127 return;
171             }
172              
173 5         17 my $checked = $Checked{$package};
174 5 50 33     38 if (defined $checked &&
175             #$checked =~ /aborted|fail|na/ ) {
176             $checked =~ /fail|na/ ) {
177              
178 100         249 msg("Known uninstallable prereqs $package - aborting install\n");
179 15         232 $Checked{$root} = "aborted";
180 600         1440 return;
181             }
182             }
183 85         208 return 1;
184             },
185 0         0 );
186              
187             $cb->_register_callback(
188             name => 'send_test_report',
189             code => sub {
190              
191 5     5   55 unless ($TiedObj) {
192 75         288 exit error("Not connected to database!");
193             }
194 5         28 my $mod = shift;
195 5         228 my $grade = lc shift;
196 5         49 my $package = $mod->package_name .'-'. $mod->package_version;
197 0         0 my $checked = $Checked{$package};
198              
199             # Did we want to throw away this report?
200 0         0 my $throw = delete $throw_away{ $package };
201 0         0 return if $throw;
202              
203             # Simplified algorithm for reporting:
204             # * don't send a report if
205             # - we get the same results as the last report sent
206             # - it passed the last test but not now
207             # - it didn't pass the last test or now
208              
209 0         0 return if (defined $checked && (
210             ($checked eq $grade) ||
211             ($checked ne 'pass' && $grade ne 'pass')));
212              
213 0         0 $Checked{$package} = $grade;
214              
215 5         27 return 1;
216             },
217 5         32 );
218              
219             $cb->_register_callback(
220             name => 'edit_test_report',
221 5     4   27 code => sub { return; },
222 5         62 );
223              
224              
225 5         76 return 1;
226             }
227              
228             sub create {
229 5     5 1 57 my $self = shift;
230             my $mod = $self->parent;
231             my $dist_cpan = $mod->status->dist_cpan;
232              
233             if ( $dist_cpan->status->created ) {
234             my %hash = @_;
235             my $conf = $mod->parent->configure_object;
236             my $args;
237             my($force,$verbose,$prereq_target,$prereq_format, $prereq_build);
238             { local $Params::Check::ALLOW_UNKNOWN = 1;
239             my $tmpl = {
240             force => { default => $conf->get_conf('force'),
241             store => \$force },
242             verbose => { default => $conf->get_conf('verbose'),
243             store => \$verbose },
244             prereq_target => { default => '', store => \$prereq_target },
245             prereq_format => { #default => $self->status->installer_type,
246             default => '',
247             store => \$prereq_format },
248             prereq_build => { default => 0, store => \$prereq_build },
249             };
250             $args = check( $tmpl, \%hash ) or return;
251             }
252             return 0 unless
253             $self->_resolve_prereqs(
254             force => $force,
255             format => $prereq_format,
256             verbose => $verbose,
257             prereqs => $mod->status->prereqs,
258             target => $prereq_target,
259             prereq_build => $prereq_build,
260             );
261             $mod->add_to_includepath();
262             return 1;
263             }
264              
265             my $package = $mod->package_name .'-'. $mod->package_version;
266             msg(qq{Checking for previous PASS result for "$package"});
267             my $checked = $Checked{$package};
268             {
269             # Don't propagate 'skiptest'
270             my %args = @_;
271             delete $args{skiptest};
272             @_ = %args;
273             }
274             if ( $checked and $checked eq 'pass' ) {
275             msg(qq{Found previous PASS result for "$package" skipping tests.});
276             push @_, skiptest => 1;
277             }
278             $self->SUPER::create( @_ );
279             }
280              
281             sub _env_report {
282       5     my @env_vars= qw(
283             /PERL/
284             /LC_/
285             /HARNESS/
286             CFLAGS
287             LDFLAGS
288             LANG
289             LANGUAGE
290             PATH
291             SHELL
292             COMSPEC
293             TERM
294             AUTOMATED_TESTING
295             NONINTERACTIVE_TESTING
296             AUTHOR_TESTING
297             RELEASE_TESTING
298             INCLUDE
299             LIB
300             LD_LIBRARY_PATH
301             PROCESSOR_IDENTIFIER
302             NUMBER_OF_PROCESSORS
303             );
304             my @vars_found;
305             for my $var ( @env_vars ) {
306             if ( $var =~ m{^/(.+)/$} ) {
307             push @vars_found, grep { /$1/ } keys %ENV;
308             }
309             else {
310             push @vars_found, $var if exists $ENV{$var};
311             }
312             }
313              
314             my $report = "";
315             for my $var ( sort @vars_found ) {
316             $report .= " $var = $ENV{$var}\n" if defined $ENV{$var};
317             }
318             return $report;
319             }
320              
321             sub _special_vars_report {
322       5     my $special_vars = << "HERE";
323             Perl: \$^X = $^X
324             UID: \$< = $<
325             EUID: \$> = $>
326             GID: \$( = $(
327             EGID: \$) = $)
328             HERE
329             if ( $^O eq 'MSWin32' && eval "require Win32" ) {
330             my @getosversion = Win32::GetOSVersion();
331             my $getosversion = join(", ", @getosversion);
332             $special_vars .= " Win32::GetOSName = " . Win32::GetOSName() . "\n";
333             $special_vars .= " Win32::GetOSVersion = $getosversion\n";
334             $special_vars .= " Win32::IsAdminUser = " . Win32::IsAdminUser() . "\n";
335             }
336             return $special_vars;
337             }
338              
339             sub _gen_report {
340       5     my $env_vars = _env_report;
341             my $special_vars = _special_vars_report();
342             my $return = << "ADDREPORT";
343              
344             ------------------------------
345             ENVIRONMENT AND OTHER CONTEXT
346             ------------------------------
347              
348             Environment variables:
349              
350             $env_vars
351             Perl special variables (and OS-specific diagnostics, for MSWin32):
352              
353             $special_vars
354              
355             -------------------------------
356              
357             ADDREPORT
358              
359             return $return;
360             }
361              
362             }
363              
364             'Yakkity Yac';
365              
366             __END__