Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

do not allow case changing #85

Closed
wants to merge 2 commits into from

4 participants

@rjbs
Collaborator

If you have uploaded Foo::Bar, we stop allowing you to now upload FOO::BAR. This reverses our decision in 2013. I have updated both code and tests.

@andk
Owner

Thanks, applied

@andk andk closed this
@dolmen

@clintongormley ElasticSearch vs Elasticsearch will not be allowed anymore.

@rjbs rjbs deleted the rjbs:no-case-change branch
@wollmers wollmers referenced this pull request in cpants/Module-CPANTS-SiteKwalitee
Open

stricter portable_filenames check #2

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
Showing with 33 additions and 19 deletions.
  1. +22 −9 lib/PAUSE/package.pm
  2. +11 −10 t/mldistwatch.t
View
31 lib/PAUSE/package.pm
@@ -190,28 +190,41 @@ sub perm_check {
}
$pp->{version} = '' unless defined $pp->{version}; # accept version 0
- my($p,$owner,@owner);
- @owner = map { $_->[1] } @$auth_ids;
+ my @owners = map { $_->[1] } @$auth_ids;
+ my @owned = grep { $_->[1] eq $userid } @$auth_ids;
+ my @owned_exact = grep { $_->[0] eq $package } @owned;
+
if ($self->{FIO}{DIO}->isa_regular_perl($dist)) {
# seems ok: perl is always right
- } elsif (! grep { $_ eq $userid } @owner) {
+ } elsif (! (@owned && @owned_exact)) {
# we must not index this and we have to inform somebody
- my $owner = eval { PAUSE::owner_of_module($package, $dbh) };
+ my $owner = eval { PAUSE::owner_of_module($package, $dbh) }
+ // "unknown";
+
+ my $not_owner = qq{Not indexed because permission missing.
+Current registered primary maintainer is $owner.
+Hint: you can always find the legitimate maintainer(s) on PAUSE under
+"View Permissions".};
+
+ # XXX: display canonical case -- rjbs, 2014-03-13
+ my $case_bad = qq{Not indexed because of case mismatch.};
+
+ my $message = @owned ? $case_bad : $not_owner;
+ my $error = @owned ? "case mismatch" : "not owner";
+
$self->index_status($package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::EMISSPERM,
- qq{Not indexed because permission missing.
-Current registered primary maintainer is $owner.
-Hint: you can always find the legitimate maintainer(s) on PAUSE under "View Permissions".},
+ $message,
);
- $self->alert(qq{not owner:
+ $self->alert(qq{$error:
package[$package]
version[$pp->{version}]
file[$pp->{infile}]
dist[$dist]
userid[$userid]
-owners[@owner]
+owners[@owners]
owner[$owner]
});
return; # early return
View
21 t/mldistwatch.t
@@ -278,11 +278,11 @@ subtest "case mismatch, authorized for original" => sub {
my $result = $pause->test_reindex;
- file_updated_ok(
- $result->tmpdir
- ->file(qw(cpan modules 02packages.details.txt.gz)),
- "our indexer indexed",
- );
+ # file_not_updated_ok(
+ # $result->tmpdir
+ # ->file(qw(cpan modules 02packages.details.txt.gz)),
+ # "our indexer indexed",
+ # );
package_list_ok(
$result,
@@ -290,14 +290,15 @@ subtest "case mismatch, authorized for original" => sub {
{ package => 'Bug::Gold', version => '9.001' },
{ package => 'Bug::gold', version => '0.001' },
{ package => 'Hall::MtKing', version => '0.01' },
+ { package => 'XForm::Rollout', version => '1.01' },
{ package => 'Y', version => 2 },
- { package => 'xform::rollout', version => '2.00' },
],
);
email_ok(
[
- { subject => 'PAUSE indexer report OPRIME/xform-rollout-2.00.tar.gz' },
+ { subject => 'Failed: PAUSE indexer report OPRIME/xform-rollout-2.00.tar.gz' },
+ { subject => 'Upload Permission or Version mismatch' },
],
);
};
@@ -318,8 +319,8 @@ subtest "case mismatch, authorized for original, desc. version" => sub {
{ package => 'Bug::Gold', version => '9.001' },
{ package => 'Bug::gold', version => '0.001' },
{ package => 'Hall::MtKing', version => '0.01' },
+ { package => 'XForm::Rollout', version => '1.01' },
{ package => 'Y', version => 2 },
- { package => 'xform::rollout', version => '2.00' },
],
);
@@ -347,8 +348,8 @@ subtest "perl-\\d should not get indexed" => sub {
{ package => 'Bug::Gold', version => '9.001' },
{ package => 'Bug::gold', version => '0.001' },
{ package => 'Hall::MtKing', version => '0.01' },
+ { package => 'XForm::Rollout', version => '1.01' },
{ package => 'Y', version => 2 },
- { package => 'xform::rollout', version => '2.00' },
],
);
};
@@ -369,8 +370,8 @@ subtest "perl-\\d should not get indexed" => sub {
{ package => 'Bug::Gold', version => '9.001' },
{ package => 'Bug::gold', version => '0.001' },
{ package => 'Hall::MtKing', version => '0.01' },
+ { package => 'XForm::Rollout', version => '1.01' },
{ package => 'Y', version => 2 },
- { package => 'xform::rollout', version => '2.00' },
],
);
Something went wrong with that request. Please try again.