#!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use Test::Output; use Cwd; my $class = 'Module::Release'; use_ok( $class ); can_ok( $class, 'new' ); BEGIN { use File::Spec; my $file = File::Spec->catfile( qw(t lib setup_common.pl) ); require $file; } my @subs = qw( pause_claim should_upload_to_pause pause_ftp_site set_pause_ftp_site pause_claim_base_url pause_claim_content pause_claim_content_type ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Create test object my $release = $class->new; isa_ok( $release, $class ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Check that the subs load at the right time foreach my $sub ( @subs ) { ok( ! $release->can( $sub ), "$sub not loaded yet" ); } ok( $release->load_mixin( 'Module::Release::PAUSE' ), "Loaded PAUSE mixin" ); can_ok( $release, @subs ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # A few things just need to return a string { my @constant_subs = qw( pause_claim_content_type pause_claim_base_url ); foreach my $sub ( @constant_subs ) { ok( defined $release->$sub(), "method $sub returns something that's defined" ); } } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Set and unset the pause_ftp_site for things that should fail my $site = $release->pause_ftp_site; ok( $site, "pause_ftp_site returns something true [$site]" ); stderr_like { $release->set_pause_ftp_site } qr/does not look like a hostname/, "set_pause_ftp_site fails for no argument"; is( $release->pause_ftp_site, $site, "pause_ftp_site stays the same after set failure" ); stderr_like { $release->set_pause_ftp_site( '' ) } qr/does not look like a hostname/, "set_pause_ftp_site fails for empty string"; is( $release->pause_ftp_site, $site, "pause_ftp_site stays the same after set failure" ); stderr_like { $release->set_pause_ftp_site( 'foo' ) } qr/does not look like a hostname/, "set_pause_ftp_site fails for 'foo'"; is( $release->pause_ftp_site, $site, "pause_ftp_site stays the same after set failure" ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Set and unset the pause_ftp_site for things that should work foreach my $site ( qw( foo.bar.com pause.perl.org brian.buster.org ) ) { ok( $release->set_pause_ftp_site( $site ), "Setting $site works" ); is( $release->pause_ftp_site, $site, "pause_ftp_site returns $site" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Check that we should upload to PAUSE # First, set both CPAN user and password { $release->config->set( 'cpan_user', 'Buster' ); $release->config->set( 'cpan_pass', 'Foo' ); ok( $release->config->cpan_user, "cpan_user is true" ); ok( $release->config->cpan_pass, "cpan_pass is true" ); ok( $release->should_upload_to_pause, "Should upload to PAUSE" ); } # Next, unset both CPAN user and password { $release->config->set( 'cpan_user', undef ); $release->config->set( 'cpan_pass', undef ); ok( ! defined $release->config->cpan_user, "cpan_user is undefined" ); ok( ! defined $release->config->cpan_pass, "cpan_pass is undefined" ); ok( ! $release->should_upload_to_pause, "Shouldn't upload to PAUSE when neither user nor password set" ); } # Then, set just CPAN password { $release->config->set( 'cpan_user', undef ); $release->config->set( 'cpan_pass', 'Foo' ); ok( ! defined $release->config->cpan_user, "cpan_user is undefined" ); ok( $release->config->cpan_pass, "cpan_pass is true" ); ok( ! $release->should_upload_to_pause, "Shouldn't upload to PAUSE when user not set" ); } # Finally, set CPAN user but unset CPAN password { $release->config->set( 'cpan_user', 'Buster' ); $release->config->set( 'cpan_pass', undef ); ok( $release->config->cpan_user, "cpan_user is true" ); ok( ! defined $release->config->cpan_pass, "cpan_pass is undefined" ); ok( ! $release->should_upload_to_pause, "Shouldn't upload to PAUSE when password not set" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Get the FTP site, either by configuration or default # First, the default { my $site = $release->pause_ftp_site; ok( defined $site, "pause_ftp_site returns something that is defined" ); ok( length $site, "pause_ftp_site returns something that is long" ); like( $site, qr/[a-z0-9-]+(\.[a-z0-9-]+)+/, "pause_ftp_site returns something that looks like a host name" ); } # Next, by setting the site first { $release->set_pause_ftp_site( 'pause.perl.org' ); my $site = $release->pause_ftp_site; ok( defined $site, "pause_ftp_site returns something that is defined" ); ok( length $site, "pause_ftp_site returns something that is long" ); like( $site, qr/[a-z0-9-]+(\.[a-z0-9-]+)+/, "pause_ftp_site returns something that looks like a host name" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Test the content for the claim request. It needs to know the remote # file name and the PAUSE user. Mock the config data BEGIN { package Module::Release::MockConfig; our @ISA = qw( Module::Release ); sub config { Module::Release::NullClass->new } package Module::Release::NullClass; sub new { bless {}, $_[0] } sub AUTOLOAD { 1 } sub perls { () } sub cpan_user { 'LOCAL' } sub cpan_pass { 'BUSTER' } } { my $release = Module::Release::MockConfig->new; isa_ok( $release, 'Module::Release::MockConfig' ); $release->remote_file( 'foo.tgz' ); is( $release->remote_file, 'foo.tgz', "Remote file is what I want it to be" ); is( $release->config->cpan_user, 'LOCAL', "CPAN user is what I want it to be" ); my $content = $release->pause_claim_content; like( $content, qr/LOCAL/, "Has the right PAUSE ID" ); like( $content, qr/foo\.tgz/, "Has the right distro name" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Test the reponse to PAUSE claim. Mock the user agent and # HTTP::Response. BEGIN { no warnings 'redefine'; package Module::Release::MockClaim; our @ISA = qw( Module::Release ); sub config { Module::Release::NullClass->new } sub web_user_agent_class { 'Module::Release::MockUA' } package Module::Release::MockUA; sub new { bless {}, $_[0] } sub request { Module::Release::NullClass->new } sub ssl_opts { 1 } sub cookie_jar { 1 } $INC{'Module/Release/MockUA.pm'} = $0; package Module::Release::NullClass; sub as_string { 'Query succeeded' } } # First, test it when we should not upload because the CPAN user # isn't set, etc: { no warnings 'redefine'; local *Module::Release::NullClass::cpan_user = sub { () }; my $release = Module::Release::MockClaim->new; isa_ok( $release, 'Module::Release::MockClaim' ); ok( ! $release->should_upload_to_pause, "Shouldn't upload to PAUSE when cpan_user not set" ); ok( ! defined $release->pause_claim, "pause_claim returns nothing when it shouldn't upload" ); } # Now, test that it works when it sees 'Query succeeded' { my $release = Module::Release::MockClaim->new; isa_ok( $release, 'Module::Release::MockClaim' ); ok( $release->should_upload_to_pause, "Should upload to PAUSE" ); like( Module::Release::NullClass->as_string, qr/Query succeeded/, "Mock as_string looks good" ); stdout_like { $release->pause_claim } qr/successful/, "pause_claim succeeds when response says 'succeeded'"; } # Then, test that it fails when it doesn't see 'Query succeeded' { no warnings 'redefine'; local *Module::Release::NullClass::as_string = sub { 'foo' }; my $release = Module::Release::MockClaim->new; isa_ok( $release, 'Module::Release::MockClaim' ); ok( $release->should_upload_to_pause, "Should upload to PAUSE" ); unlike( Module::Release::NullClass->as_string, qr/succeeded/, "Mock as_string looks good" ); stdout_like { $release->pause_claim } qr/failed/, "pause_claim fails when response does not say 'succeeded'"; }