lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t

   1 ### make sure we can find our conf.pl file
   2 BEGIN {
   3     use FindBin;
   4     require "$FindBin::Bin/inc/conf.pl";
   5 }
   6
   7 use strict;
   8 use CPANPLUS::Backend;
   9 use CPANPLUS::Internals::Constants::Report;
  10
  11 my $send_tests  = 55;
  12 my $query_tests = 8;
  13 my $total_tests = $send_tests + $query_tests;
  14
  15 use Test::More                  'no_plan';
  16 use Module::Load::Conditional   qw[can_load];
  17
  18 use FileHandle;
  19 use Data::Dumper;
  20
  21 use constant NOBODY => 'nobody@xs4all.nl';
  22
  23 my $conf        = gimme_conf();
  24 my $CB          = CPANPLUS::Backend->new( $conf );
  25 my $ModName     = TEST_CONF_MODULE;
  26 my $ModPrereq   = TEST_CONF_PREREQ;
  27 my $Mod         = $CB->module_tree($ModName);
  28 my $int_ver     = $CPANPLUS::Internals::VERSION;
  29
  30 ### explicitly enable testing if possible ###
  31 $CB->configure_object->set_conf(cpantest =>1) if $ARGV[0];
  32
  33 my $map = {
  34     all_ok  => {
  35         buffer  => '',              # output from build process
  36         failed  => 0,               # indicate failure
  37         match   => [qw|/PASS/|],    # list of regexes for the output
  38         check   => 0,               # check if callbacks got called?
  39     },
  40     skipped_test => {
  41         buffer  => '',
  42         failed  => 0,
  43         match   => ['/PASS/',
  44                     '/tests for this module were skipped during this build/',
  45                 ],
  46         check   => 0,
  47         skiptests
  48                 => 1,               # did we skip the tests?
  49     },
  50     missing_prereq  => {
  51         buffer  => missing_prereq_buffer(),
  52         failed  => 1,
  53         match   => ['/The comments above are created mechanically/',
  54                     '/computer-generated error report/',
  55                     '/Below is the error stack from stage/',
  56                     '/test suite seem to fail without these modules/',
  57                     '/floo/',
  58                     '/FAIL/',
  59                     '/make test/',
  60                 ],
  61         check   => 1,
  62     },
  63     missing_tests   => {
  64         buffer  => missing_tests_buffer(),
  65         failed  => 1,
  66         match   => ['/The comments above are created mechanically/',
  67                     '/computer-generated error report/',
  68                     '/Below is the error stack from stage/',
  69                     '/RECOMMENDATIONS/',
  70                     '/UNKNOWN/',
  71                     '/make test/',
  72                 ],
  73         check   => 0,
  74     },
  75     perl_version_too_low_mm => {
  76         buffer  => perl_version_too_low_buffer_mm(),
  77         failed  => 1,
  78         match   => ['/This distribution has been tested/',
  79                     '/http://testers.cpan.org/',
  80                     '/NA/',
  81                 ],
  82         check   => 0,
  83     },
  84     perl_version_too_low_build1 => {
  85         buffer  => perl_version_too_low_buffer_build(1),
  86         failed  => 1,
  87         match   => ['/This distribution has been tested/',
  88                     '/http://testers.cpan.org/',
  89                     '/NA/',
  90                 ],
  91         check   => 0,
  92     },
  93     perl_version_too_low_build2 => {
  94         buffer  => perl_version_too_low_buffer_build(2),
  95         failed  => 1,
  96         match   => ['/This distribution has been tested/',
  97                     '/http://testers.cpan.org/',
  98                     '/NA/',
  99                 ],
 100         check   => 0,
 101     },
 102     prereq_versions_too_low => {
 103         ### set the prereq version incredibly high
 104         pre_hook    => sub {
 105                         my $mod     = shift;
 106                         my $clone   = $mod->clone;
 107                         $clone->status->prereqs( { $ModPrereq => ~0 } );
 108                         return $clone;
 109                     },
 110         failed      => 1,
 111         match       => ['/This distribution has been tested/',
 112                         '/http://testers.cpan.org/',
 113                         '/NA/',
 114                     ],
 115         check       => 0,
 116     },
 117     prereq_not_on_cpan => {
 118         pre_hook    => sub {
 119                         my $mod     = shift;
 120                         my $clone   = $mod->clone;
 121                         $clone->status->prereqs(
 122                             { TEST_CONF_INVALID_MODULE, 0 }
 123                         );
 124                         return $clone;
 125                     },
 126         failed      => 1,
 127         match       => ['/This distribution has been tested/',
 128                         '/http://testers.cpan.org/',
 129                         '/NA/',
 130                     ],
 131         check       => 0,
 132     },
 133
 134
 135
 136 };
 137
 138 ### test config settings
 139 {   for my $opt ( qw[cpantest cpantest_mx] ) {
 140         my $warnings;
 141         local $SIG{__WARN__} = sub { $warnings .= "@_" };
 142
 143         my $org = $conf->get_conf( $opt );
 144         ok( $conf->set_conf( $opt => $$ ),
 145                                 "Setting option $opt to $$" );
 146         is( $conf->get_conf( $opt ), $$,
 147                                 "   Retrieved properly" );
 148         ok( $conf->set_conf( $opt => $org ),
 149                                 "   Option $opt set back to original" );
 150         ok( !$warnings,         "   No warnings" );
 151     }
 152 }
 153
 154 ### test constants ###
 155 {   {   my $to = CPAN_MAIL_ACCOUNT->('foo');
 156         is( $to, 'foo@cpan.org',        "Got proper mail account" );
 157     }
 158
 159     {   ok(RELEVANT_TEST_RESULT->($Mod),"Test is relevant" );
 160
 161         ### test non-relevant tests ###
 162         my $cp = $Mod->clone;
 163         $cp->module( $Mod->module . '::' . ($^O eq 'beos' ? 'MSDOS' : 'Be') );
 164         ok(!RELEVANT_TEST_RESULT->($cp),"Test is irrelevant");
 165     }
 166
 167     {   my $support = "it works!";
 168         my @support = ( "No support for OS",
 169                         "OS unsupported",
 170                         "os unsupported",
 171         );
 172         ok(!UNSUPPORTED_OS->($support), "OS supported");
 173         ok( UNSUPPORTED_OS->($_),   "OS not supported") for(@support);
 174     }
 175
 176     {   ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_mm() ),
 177                                         "Perl version too low" );
 178         ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(1) ),
 179                                         "Perl version too low" );
 180         ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(2) ),
 181                                         "Perl version too low" );
 182         ok(!PERL_VERSION_TOO_LOW->('foo'),
 183                                         "   Perl version adequate" );
 184     }
 185
 186     {   my $tests = "test.pl";
 187         my @none  = (   "No tests defined for Foo extension.",
 188                         "'No tests defined for Foo::Bar extension.'",
 189                         "'No tests defined.'",
 190         );
 191         ok(!NO_TESTS_DEFINED->($tests), "Tests defined");
 192         ok( NO_TESTS_DEFINED->($_),  "No tests defined")    for(@none);
 193     }
 194
 195     {   my $fail = 'MAKE TEST'; my $unknown = 'foo';
 196         is( TEST_FAIL_STAGE->($fail), lc $fail,
 197                                         "Proper test fail stage found" );
 198         is( TEST_FAIL_STAGE->($unknown), 'fetch',
 199                                         "Proper test fail stage found" );
 200     }
 201
 202     ### test missing prereqs
 203     {   my $str = q[Can't locate Foo/Bar.pm in @INC];
 204
 205         ### standard test
 206         {   my @list = MISSING_PREREQS_LIST->( $str );
 207             is( scalar(@list),  1,      "   List of missing prereqs found" );
 208             is( $list[0], 'Foo::Bar',   "       Proper prereq found" );
 209         }
 210
 211         ### multiple mentions of same prereq
 212         {   my @list = MISSING_PREREQS_LIST->( $str . $str );
 213
 214             is( scalar(@list),  1,      "   1 result for multiple mentions" );
 215             is( $list[0], 'Foo::Bar',   "   Proper prereq found" );
 216         }
 217     }
 218
 219     {                                       # cp version, author
 220         my $header = REPORT_MESSAGE_HEADER->($int_ver,'foo');
 221         ok( $header,                    "Test header generated" );
 222         like( $header, qr/Dear foo,/,   "   Proper content found" );
 223         like( $header, qr/puter-gen/,   "   Proper content found" );
 224         like( $header, qr/CPANPLUS,/,   "   Proper content found" );
 225         like( $header, qr/ments may/,   "   Proper content found" );
 226     }
 227
 228     {                                       # stage, buffer
 229         my $header = REPORT_MESSAGE_FAIL_HEADER->('test','buffer');
 230         ok( $header,                    "Test header generated" );
 231         like( $header, qr/uploading/,   "   Proper content found" );
 232         like( $header, qr/RESULTS:/,    "   Proper content found" );
 233         like( $header, qr/stack/,       "   Proper content found" );
 234         like( $header, qr/buffer/,      "   Proper content found" );
 235     }
 236
 237     {   my $prereqs = REPORT_MISSING_PREREQS->('foo','bar@example.com','Foo::Bar');
 238         ok( $prereqs,                   "Test output generated" );
 239         like( $prereqs, qr/'foo \(bar\@example\.com\)'/,
 240                                         "   Proper content found" );
 241         like( $prereqs, qr/Foo::Bar/,   "   Proper content found" );
 242         like( $prereqs, qr/prerequisi/, "   Proper content found" );
 243         like( $prereqs, qr/PREREQ_PM/,  "   Proper content found" );
 244     }
 245
 246     {   my $prereqs = REPORT_MISSING_PREREQS->(undef,undef,'Foo::Bar');
 247         ok( $prereqs,                   "Test output generated" );
 248         like( $prereqs, qr/Your Name/,  "   Proper content found" );
 249         like( $prereqs, qr/Foo::Bar/,   "   Proper content found" );
 250         like( $prereqs, qr/prerequisi/, "   Proper content found" );
 251         like( $prereqs, qr/PREREQ_PM/,  "   Proper content found" );
 252     }
 253
 254     {   my $missing = REPORT_MISSING_TESTS->();
 255         ok( $missing,                   "Missing test string generated" );
 256         like( $missing, qr/tests/,      "   Proper content found" );
 257         like( $missing, qr/Test::More/, "   Proper content found" );
 258     }
 259
 260     {   my $missing = REPORT_MESSAGE_FOOTER->();
 261         ok( $missing,                   "Message footer string generated" );
 262         like( $missing, qr/NOTE/,       "   Proper content found" );
 263         like( $missing, qr/identical/,  "   Proper content found" );
 264         like( $missing, qr/mistaken/,   "   Proper content found" );
 265         like( $missing, qr/appreciate/, "   Proper content found" );
 266         like( $missing, qr/Additional/, "   Proper content found" );
 267     }
 268
 269     {   my @libs = MISSING_EXTLIBS_LIST->("No library found for -lfoo\nNo library found for -lbar");
 270         ok( @libs,                      "Missing external libraries found" );
 271         my @list = qw(foo bar);
 272         is_deeply( \@libs, \@list,      "   Proper content found" );
 273     }
 274
 275     {   my $clone   = $Mod->clone;
 276         my $prereqs = { $ModPrereq => ~0 };
 277
 278         $clone->status->prereqs( $prereqs );
 279
 280         my $str = REPORT_LOADED_PREREQS->( $clone );
 281
 282         like($str, qr/PREREQUISITES:/,  "Listed loaded prerequisites" );
 283         like($str, qr/\! $ModPrereq\s+\S+\s+\S+/,
 284                                         "   Proper content found" );
 285     }
 286 }
 287
 288 ### callback tests
 289 {   ### as reported in bug 13086, this callback returned the wrong item
 290     ### from the list:
 291     ### $self->_callbacks->munge_test_report->($Mod, $message, $grade);
 292     my $rv = $CB->_callbacks->munge_test_report->( 1..4 );
 293     is( $rv, 2,                 "Default 'munge_test_report' callback OK" );
 294 }
 295
 296
 297 ### test creating test reports ###
 298 SKIP: {
 299         skip "You have chosen not to enable test reporting", $total_tests,
 300         unless $CB->configure_object->get_conf('cpantest');
 301
 302     skip "No report send & query modules installed", $total_tests
 303         unless $CB->_have_query_report_modules(verbose => 0);
 304
 305
 306     SKIP: {
 307         my $mod = $CB->module_tree( TEST_CONF_PREREQ ); # is released to CPAN
 308         ok( $mod,                           "Module retrieved" );
 309
 310         ### so we're not pinned down to this specific version of perl
 311         my @list = $mod->fetch_report( all_versions => 1 );
 312         skip "Possibly no net connection, or server down", 7 unless @list;
 313
 314         my $href = $list[0];
 315         ok( scalar(@list),                  "Fetched test report" );
 316         is( ref $href, ref {},              "   Return value has hashrefs" );
 317
 318         ok( $href->{grade},                 "   Has a grade" );
 319
 320         ### XXX use constants for grades?
 321         like( $href->{grade}, qr/pass|fail|unknown|na/i,
 322                                             "   Grade as expected" );
 323
 324         my $pkg_name = $mod->package_name;
 325         ok( $href->{dist},                  "   Has a dist" );
 326         like( $href->{dist}, qr/$pkg_name/, "   Dist as expected" );
 327
 328         ok( $href->{platform},              "   Has a platform" );
 329     }
 330
 331     skip "No report sending modules installed", $send_tests
 332         unless $CB->_have_send_report_modules(verbose => 0);
 333
 334     for my $type ( keys %$map ) {
 335
 336
 337         ### never enter the editor for test reports
 338         ### but check if the callback actually gets called;
 339         my $called_edit; my $called_send;
 340         $CB->_register_callback(
 341             name => 'edit_test_report',
 342             code => sub { $called_edit++; 0 }
 343         );
 344
 345         $CB->_register_callback(
 346             name => 'send_test_report',
 347             code => sub { $called_send++; 1 }
 348         );
 349
 350                 ### reset from earlier tests
 351                 $CB->_register_callback(
 352             name => 'munge_test_report',
 353             code => sub { return $_[1] }
 354         );
 355
 356         my $mod = $map->{$type}->{'pre_hook'}
 357                     ? $map->{$type}->{'pre_hook'}->( $Mod )
 358                     : $Mod;
 359
 360         my $file = $CB->_send_report(
 361                         module        => $mod,
 362                         buffer        => $map->{$type}{'buffer'},
 363                         failed        => $map->{$type}{'failed'},
 364                         tests_skipped => ($map->{$type}{'skiptests'} ? 1 : 0),
 365                         save          => 1,
 366                         dontcc        => 1, # no need to send, and also skips
 367                                             # fetching reports from testers.cpan
 368                     );
 369
 370         ok( $file,              "Type '$type' written to file" );
 371         ok( -e $file,           "   File exists" );
 372
 373         my $fh = FileHandle->new($file);
 374         ok( $fh,                "   Opened file for reading" );
 375
 376         my $in = do { local $/; <$fh> };
 377         ok( $in,                "   File has contents" );
 378
 379         for my $regex ( @{$map->{$type}->{match}} ) {
 380             like( $in, $regex,  "   File contains expected contents" );
 381         }
 382
 383         ### check if our registered callback got called ###
 384         if( $map->{$type}->{check} ) {
 385             ok( $called_edit,   "   Callback to edit was called" );
 386             ok( $called_send,   "   Callback to send was called" );
 387         }
 388
 389         #unlink $file;
 390
 391
 392 ### T::R tests don't even try to mail, let's not try and be smarter
 393 ### ourselves
 394 #        {   ### use a dummy 'editor' and see if the editor
 395 #            ### invocation doesn't break things
 396 #            $conf->set_program( editor => "$^X -le1" );
 397 #            $CB->_callbacks->edit_test_report( sub { 1 } );
 398 #
 399 #            ### XXX whitebox test!!! Might change =/
 400 #            ### this makes test::reporter not ask for what editor to use
 401 #            ### XXX stupid lousy perl warnings;
 402 #            local $Test::Reporter::MacApp = 1;
 403 #            local $Test::Reporter::MacApp = 1;
 404 #
 405 #            ### now try and mail the report to a /dev/null'd mailbox
 406 #            my $ok = $CB->_send_report(
 407 #                            module  => $Mod,
 408 #                            buffer  => $map->{$type}->{'buffer'},
 409 #                            failed  => $map->{$type}->{'failed'},
 410 #                            address => NOBODY,
 411 #                            dontcc  => 1,
 412 #                        );
 413 #            ok( $ok,                "   Mailed report to NOBODY" );
 414 #       }
 415     }
 416 }
 417
 418
 419 sub missing_prereq_buffer {
 420     return q[
 421 MAKE TEST:
 422 Can't locate floo.pm in @INC (@INC contains: /Users/kane/sources/p4/other/archive-extract/lib /Users/kane/sources/p4/other/file-fetch/lib /Users/kane/sources/p4/other/archive-tar-new/lib /Users/kane/sources/p4/other/carp-trace/lib /Users/kane/sources/p4/other/log-message/lib /Users/kane/sources/p4/other/module-load/lib /Users/kane/sources/p4/other/params-check/lib /Users/kane/sources/p4/other/qmail-checkpassword/lib /Users/kane/sources/p4/other/module-load-conditional/lib /Users/kane/sources/p4/other/term-ui/lib /Users/kane/sources/p4/other/ipc-cmd/lib /Users/kane/sources/p4/other/config-auto/lib /Users/kane/sources/NSA /Users/kane/sources/NSA/misc /Users/kane/sources/NSA/test /Users/kane/sources/beheer/perl /opt/lib/perl5/5.8.3/darwin-2level /opt/lib/perl5/5.8.3 /opt/lib/perl5/site_perl/5.8.3/darwin-2level /opt/lib/perl5/site_perl/5.8.3 /opt/lib/perl5/site_perl .).
 423 BEGIN failed--compilation aborted.
 424     ];
 425 }
 426
 427 sub missing_tests_buffer {
 428     return q[
 429 cp lib/Acme/POE/Knee.pm blib/lib/Acme/POE/Knee.pm
 430 cp demo_race.pl blib/lib/Acme/POE/demo_race.pl
 431 cp demo_simple.pl blib/lib/Acme/POE/demo_simple.pl
 432 MAKE TEST:
 433 No tests defined for Acme::POE::Knee extension.
 434     ];
 435 }
 436
 437 sub perl_version_too_low_buffer_mm {
 438     return q[
 439 Running [/usr/bin/perl5.8.1 Makefile.PL ]...
 440 Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1.
 441 BEGIN failed--compilation aborted at Makefile.PL line 1.
 442 [ERROR] Could not run '/usr/bin/perl5.8.1 Makefile.PL': Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1.
 443 BEGIN failed--compilation aborted at Makefile.PL line 1.
 444  -- cannot continue
 445     ];
 446 }
 447
 448 sub perl_version_too_low_buffer_build {
 449     my $type = shift;
 450     return q[
 451 ERROR: perl: Version 5.006001 is installed, but we need version >= 5.008001
 452 ERROR: version: Prerequisite version isn't installed
 453 ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
 454  of the modules indicated above before proceeding with this installation.
 455     ]   if($type == 1);
 456     return q[
 457 ERROR: Version 5.006001 of perl is installed, but we need version >= 5.008001
 458 ERROR: version: Prerequisite version isn't installed
 459 ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
 460  of the modules indicated above before proceeding with this installation.
 461     ]   if($type == 2);
 462 }
 463
 464 # Local variables:
 465 # c-indentation-style: bsd
 466 # c-basic-offset: 4
 467 # indent-tabs-mode: nil
 468 # End:
 469 # vim: expandtab shiftwidth=4: