[Bps-public-commit] cpan2rt branch refactor-bounce-email-management created. 0c0a8d1b618d7f6dd4b23f786f138d8614f2b254
BPS Git Server
git at git.bestpractical.com
Tue May 10 14:38:40 UTC 2022
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "cpan2rt".
The branch, refactor-bounce-email-management has been created
at 0c0a8d1b618d7f6dd4b23f786f138d8614f2b254 (commit)
- Log -----------------------------------------------------------------
commit 0c0a8d1b618d7f6dd4b23f786f138d8614f2b254
Author: Brian Conry <bconry at bestpractical.com>
Date: Fri May 6 16:45:59 2022 -0500
Avoid readding email addresses known to bounce
This refactors the logic for clearing known-bouncing email addresses
and completely separates it from the prior logic for handling when to
create and merge users.
For any starting set of users, the user maintenance create/merge
operations should be the same no matter what email addresses are in the
bounce list. But, once we clear email addresses based on the bounce
list then that will result in future runs detecting a different state
(e.g. by not loading an existing user because that email address was
unset), so some future user merges might be missed.
This is the price we pay for reducing bounces now.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 93f5f8b..d1f5820 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -804,15 +804,26 @@ sub load_or_create_user {
my $bounce_map = $self->{bounce_map};
- my $bycpanid = RT::User->new($RT::SystemUser);
- $bycpanid->LoadByCol( Name => $cpanid );
-
# WARNING: when MergeUser extension is used then the same user records
# will be loaded even when there are multiple records in the DB
$email = $self->parse_email_address( $email ) || "$cpanid\@cpan.org";
my $byemail = RT::User->new( $RT::SystemUser );
$byemail->LoadByEmail( $email );
+ if( $byemail->id and exists $bounce_map->{ $email } ) {
+ # unsetting the email address here won't affect the later logic, even in the case
+ # where there's not already a user with $cpanid. that user will still be created
+ # and then merged with the $byemail user (that now doesn't have an email).
+ $byemail->SetEmailAddress( '' );
+ }
+
+ my $bycpanid = RT::User->new($RT::SystemUser);
+ $bycpanid->LoadByCol( Name => $cpanid );
+
+ if( $bycpanid->id and defined $bycpanid->EmailAddress and exists $bounce_map->{ $bycpanid->EmailAddress } ) {
+ $bycpanid->SetEmailAddress( '' );
+ }
+
if ( $bycpanid->id && (($byemail->id && $bycpanid->id == $byemail->id) || !$byemail->id) ) {
# the same users, both cpanid and email...
# or email change, so no user with new email...
@@ -821,16 +832,8 @@ sub load_or_create_user {
# then we set email to the public version from PAUSE only when
# user in RT has no email. The same applies to name.
- # don't use email addresses known to bounce, unsetting them on users if they are already set
- if( exists $bounce_map->{ $email } ) {
- $byemail->SetEmailAddress( '' ) if $byemail->id;
- }
- elsif( defined $bycpanid->EmailAddress && exists $bounce_map->{ $bycpanid->EmailAddress } ) {
- $bycpanid->SetEmailAddress( '' );
- }
-
$bycpanid->SetEmailAddress( $email )
- unless $bycpanid->EmailAddress;
+ unless $bycpanid->EmailAddress or exists $bounce_map->{ $email };
$bycpanid->SetRealName( $realname )
unless $bycpanid->RealName;
@@ -867,6 +870,8 @@ sub load_or_create_user {
return ($new);
}
+ $email = '' if exists $bounce_map->{ $email };
+
return $self->create_user($cpanid, $realname, $email);
}
commit 5bfa5e7e52d95925864da9738c779a2a9b3eb6e2
Author: Blaine Motsinger <blaine at bestpractical.com>
Date: Thu May 5 14:32:16 2022 -0500
Fix uninitialized value in exists warning
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index c7a4909..93f5f8b 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -825,7 +825,7 @@ sub load_or_create_user {
if( exists $bounce_map->{ $email } ) {
$byemail->SetEmailAddress( '' ) if $byemail->id;
}
- elsif( exists $bounce_map->{ $bycpanid->EmailAddress } ) {
+ elsif( defined $bycpanid->EmailAddress && exists $bounce_map->{ $bycpanid->EmailAddress } ) {
$bycpanid->SetEmailAddress( '' );
}
commit 0d33ad54e674b8b7614d5e80935e326ea6d43a15
Author: Brian Conry <bconry at bestpractical.com>
Date: Fri Jan 28 11:18:48 2022 -0600
Fix copy/paste error
I forgot to remove the postcondition after I did a copy/paste.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 200eac3..c7a4909 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -826,7 +826,7 @@ sub load_or_create_user {
$byemail->SetEmailAddress( '' ) if $byemail->id;
}
elsif( exists $bounce_map->{ $bycpanid->EmailAddress } ) {
- $bycpanid->SetEmailAddress( '' ) if $byemail->id;
+ $bycpanid->SetEmailAddress( '' );
}
$bycpanid->SetEmailAddress( $email )
commit 40fd5851818b7d1bbec8e6563336015795e1586d
Author: Brian Conry <bconry at bestpractical.com>
Date: Fri Jan 28 10:21:03 2022 -0600
Remove blocked email address from more users
The previous change missed the case where the 00whois.xml email address
isn't blocked but the RT user for the PAUSE id has a different email
addddress that is blocked.
This was due to not taking into account the fact that cpan2rt was
designed originally to only set email addresses when they weren't
already set so that if a user had modified their email address in RT to
be different from what's listed in PAUSE that would be preserved.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 8c93ab5..200eac3 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -825,11 +825,13 @@ sub load_or_create_user {
if( exists $bounce_map->{ $email } ) {
$byemail->SetEmailAddress( '' ) if $byemail->id;
}
- else {
- $bycpanid->SetEmailAddress( $email )
- unless $bycpanid->EmailAddress;
+ elsif( exists $bounce_map->{ $bycpanid->EmailAddress } ) {
+ $bycpanid->SetEmailAddress( '' ) if $byemail->id;
}
+ $bycpanid->SetEmailAddress( $email )
+ unless $bycpanid->EmailAddress;
+
$bycpanid->SetRealName( $realname )
unless $bycpanid->RealName;
commit 0503b91d9cf3227474004a86a712a7850d9e0f89
Author: Brian Conry <bconry at bestpractical.com>
Date: Wed Dec 22 14:52:28 2021 -0600
Unset email addresses known to bounce
Bounces from cpan RT affect our mail reputation for all customers.
Read email address from 'bounce_list' and prevent them from being set on
users, unsetting them if they are already present.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index bd0cb55..8c93ab5 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -24,6 +24,7 @@ use Email::Address;
use List::Compare;
use CPAN::DistnameInfo;
use List::MoreUtils qw(uniq);
+use File::Copy;
our $DEBUG = 0;
sub debug(&);
@@ -273,11 +274,30 @@ sub for_all_distributions {
sub sync_authors {
my $self = shift;
my $force = shift;
- if ( !$force && !$self->is_new_file( '00whois.xml' ) ) {
+ if ( !$force && !$self->is_new_file( '00whois.xml' ) && !$self->is_new_file( 'bounce_list' ) ) {
debug { "Skip syncing, file's not changed\n" };
return (1);
}
+ my $bouncefile_path = $self->file_path( 'bounce_list' );
+
+ # is_new_file compares the mtimes of $file and $file.old
+ # the other files have their .old created by backup_file, but
+ # we can't use $self->backup_file here because it moves the current
+ # file, expecting that we'll fetch a new copy from somewhere,
+ # and we don't have new copy to fetch.
+ copy( $bouncefile_path, $bouncefile_path . '.old' );
+
+ # one email per line
+ my $bounce_map = $self->{bounce_map} = {};
+
+ open my $fh, "<:utf8", $bouncefile_path or die "Couldn't open '$bouncefile_path': $!";
+
+ while( my $email = <$fh> ) {
+ chomp $email;
+ $bounce_map->{ $email } = 1;
+ }
+
my ($i, @errors) = (0);
my $authors = $self->authors;
while ( my ($cpanid, $meta) = each %$authors ) {
@@ -782,6 +802,8 @@ sub load_or_create_user {
my $self = shift;
my ($cpanid, $realname, $email) = @_;
+ my $bounce_map = $self->{bounce_map};
+
my $bycpanid = RT::User->new($RT::SystemUser);
$bycpanid->LoadByCol( Name => $cpanid );
@@ -798,10 +820,19 @@ sub load_or_create_user {
# XXX: as we have no way to detect email changes on PAUSE
# then we set email to the public version from PAUSE only when
# user in RT has no email. The same applies to name.
- $bycpanid->SetEmailAddress( $email )
- unless $bycpanid->EmailAddress;
+
+ # don't use email addresses known to bounce, unsetting them on users if they are already set
+ if( exists $bounce_map->{ $email } ) {
+ $byemail->SetEmailAddress( '' ) if $byemail->id;
+ }
+ else {
+ $bycpanid->SetEmailAddress( $email )
+ unless $bycpanid->EmailAddress;
+ }
+
$bycpanid->SetRealName( $realname )
unless $bycpanid->RealName;
+
return $bycpanid;
}
elsif ( $bycpanid->id && $byemail->id ) {
commit 2d940a92ca598c45f81ba8ce4fecb6bb2f9e4491
Author: Brian Conry <bconry at bestpractical.com>
Date: Tue Dec 21 11:59:06 2021 -0600
Improve query path for finding ticket custom fields
Significantly reduces the overhead imposed on PostgreSQL by improving
the query path used to locate the queue's ticket custom fields 'Broken
in' and 'Fixed in'. The query(s) for this were the most expensive parts
of the entire process.
Along with this change there should be an index created on
ObjectCustomFields.objectid and RT should be updated/patched to include
dcd729513 - Merge Branch '5.0/use-bind-values' into 5.0-trunk
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 9d30ea3..bd0cb55 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -728,14 +728,28 @@ sub add_versions {
my ($queue, @versions) = @_;
@versions = uniq grep defined && length, @versions;
+ my $cfs = $queue->TicketCustomFields;
+ my %cfs;
+
+ while( my $cf = $cfs->Next ) {
+ $cfs{ $cf->Name } = $cf;
+ }
+
my @errors;
foreach my $name ( "Broken in", "Fixed in" ) {
- my ($cf, $msg) = $self->load_or_create_version_cf( $queue, $name );
- unless ( $cf ) {
- push @errors, $msg;
- next;
+ if( not exists $cfs{ $name } ) {
+ my ($cf, $msg) = $self->create_version_cf( $queue, $name );
+ if ( $cf ) {
+ $cfs{ $name } = $cf;
+ }
+ else {
+ push @errors, $msg;
+ next;
+ }
}
+ my $cf = $cfs{ $name };
+
# Unless it's a new value, don't add it
my %old = map { $_->Name => 1 } @{ $cf->Values->ItemsArrayRef };
foreach my $version ( @versions ) {
@@ -880,29 +894,6 @@ sub load_or_create_queue {
return $queue;
}
-sub load_or_create_version_cf {
- my $self = shift;
- my ($queue, $name) = @_;
-
- my $cfs = RT::CustomFields->new( $RT::SystemUser );
-
- # Explicitly specify case-insensitive searches. Newer versions
- # of RT::SearchBuilder issue a warning if we don't do that.
- $cfs->Limit( FIELD => 'Name', VALUE => $name, CASESENSITIVE => 0 );
-
- $cfs->LimitToQueue( $queue->id );
- $cfs->{'find_disabled_rows'} = 0; # This is why we don't simply do a LoadByName
- $cfs->OrderByCols; # don't sort things
- $cfs->RowsPerPage( 1 );
-
- my $cf = $cfs->First;
- unless ( $cf && $cf->id ) {
- return $self->create_version_cf( $queue, $name );
- }
-
- return ($cf);
-}
-
sub create_version_cf {
my $self = shift;
my ($queue, $name) = @_;
commit ca503adbbdcda2a4adfe3397059c9ea8f43be4c9
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Tue Mar 16 13:29:09 2021 +0000
Maximum queue name length supportable on pobox is 70 characters
diff --git a/bin/sync-queues-to-pobox b/bin/sync-queues-to-pobox
index e691801..2100ea0 100755
--- a/bin/sync-queues-to-pobox
+++ b/bin/sync-queues-to-pobox
@@ -26,8 +26,10 @@ fi
# Maximum pobox alias length is 90 characters. We prefix with "bug-" which
-# leaves 86 characters and "comment-" which leaves 82.
-psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 82" --tuples-only --no-align rt5 | \
+# leaves 86 characters and "comment-" which leaves 82. We then postfix
+# with '@rt.cpan.org' which eats up another 12 characters, for a final
+# maximum queue name length of 70.
+psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) <= 70" --tuples-only --no-align rt5 | \
egrep -v '[ :+]' | grep -v '^___Approvals$' | grep -v '\.$' | \
sed -e 's/\(.*\)/bug-\1,bug-\1 at rt-cpan-org.hostedrt.com\ncomment-\1,comment-\1 at rt-cpan-org.hostedrt.com/' | \
/usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 600m0s --delay 0
commit ee6b8c2d3e80bb072553416498f2a0448998f65e
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Mon Mar 15 12:37:28 2021 +0000
Increase timeout to 10 hours instead of 1 hour
diff --git a/bin/sync-queues-to-pobox b/bin/sync-queues-to-pobox
index b8fa0cb..e691801 100755
--- a/bin/sync-queues-to-pobox
+++ b/bin/sync-queues-to-pobox
@@ -30,4 +30,4 @@ fi
psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 82" --tuples-only --no-align rt5 | \
egrep -v '[ :+]' | grep -v '^___Approvals$' | grep -v '\.$' | \
sed -e 's/\(.*\)/bug-\1,bug-\1 at rt-cpan-org.hostedrt.com\ncomment-\1,comment-\1 at rt-cpan-org.hostedrt.com/' | \
- /usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 60m0s --delay 0
+ /usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 600m0s --delay 0
commit cbe6f875fa0ae04d8634f100b172ba7c438f5d93
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Mar 12 21:03:07 2021 +0000
Oops... we also have to handle "comment-QUEUE" as well as "bug-QUEUE"
diff --git a/bin/sync-queues-to-pobox b/bin/sync-queues-to-pobox
index 29e4312..b8fa0cb 100755
--- a/bin/sync-queues-to-pobox
+++ b/bin/sync-queues-to-pobox
@@ -26,8 +26,8 @@ fi
# Maximum pobox alias length is 90 characters. We prefix with "bug-" which
-# leaves 86 characters for the queue name.
-psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 86" --tuples-only --no-align rt5 | \
+# leaves 86 characters and "comment-" which leaves 82.
+psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 82" --tuples-only --no-align rt5 | \
egrep -v '[ :+]' | grep -v '^___Approvals$' | grep -v '\.$' | \
- sed -e 's/\(.*\)/bug-\1,bug-\1 at rt-cpan-org.hostedrt.com/' | \
+ sed -e 's/\(.*\)/bug-\1,bug-\1 at rt-cpan-org.hostedrt.com\ncomment-\1,comment-\1 at rt-cpan-org.hostedrt.com/' | \
/usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 60m0s --delay 0
commit 25b3076bc37cbba6fc26643d2dd7b28538ae23ef
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Mar 12 20:59:56 2021 +0000
Prefix queue names with "bug-" to form email addresses.
diff --git a/bin/sync-queues-to-pobox b/bin/sync-queues-to-pobox
index 0c70f57..29e4312 100755
--- a/bin/sync-queues-to-pobox
+++ b/bin/sync-queues-to-pobox
@@ -24,7 +24,10 @@ if test "$?" != 0 ; then
exit 1
fi
-psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 90" --tuples-only --no-align rt5 | \
+
+# Maximum pobox alias length is 90 characters. We prefix with "bug-" which
+# leaves 86 characters for the queue name.
+psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 86" --tuples-only --no-align rt5 | \
egrep -v '[ :+]' | grep -v '^___Approvals$' | grep -v '\.$' | \
- sed -e 's/\(.*\)/\1,\1 at rt-cpan-org.hostedrt.com/' | \
+ sed -e 's/\(.*\)/bug-\1,bug-\1 at rt-cpan-org.hostedrt.com/' | \
/usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 60m0s --delay 0
commit f072107eb8810d1a5e0b6cac7abbb12bd09c5541
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Mar 12 20:56:36 2021 +0000
Filter out queue names longer than 90 characters
pobox.com cannot handle aliases longer than that.
diff --git a/bin/sync-queues-to-pobox b/bin/sync-queues-to-pobox
index 8e0872e..0c70f57 100755
--- a/bin/sync-queues-to-pobox
+++ b/bin/sync-queues-to-pobox
@@ -24,7 +24,7 @@ if test "$?" != 0 ; then
exit 1
fi
-psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues" --tuples-only --no-align rt5 | \
+psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues WHERE LENGTH(Name) < 90" --tuples-only --no-align rt5 | \
egrep -v '[ :+]' | grep -v '^___Approvals$' | grep -v '\.$' | \
sed -e 's/\(.*\)/\1,\1 at rt-cpan-org.hostedrt.com/' | \
/usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 60m0s --delay 0
commit 96bbcb71cd8c1d3cb8b5ecb47f6949142e43b9f9
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Mar 12 20:33:51 2021 +0000
Add shell script to push mail routes to pobox.com for all of our queues
diff --git a/bin/sync-queues-to-pobox b/bin/sync-queues-to-pobox
new file mode 100755
index 0000000..8e0872e
--- /dev/null
+++ b/bin/sync-queues-to-pobox
@@ -0,0 +1,30 @@
+#!/bin/bash
+
+# Sync queues over to pobox.com
+#
+# Strategy:
+#
+# Pull out all queue names
+# But not those containing spaces or colons or a plus sign,
+# or the queue named '___Approvals', or any queues whose names end
+# in a period (our data is pretty messy)
+#
+# Convert QNAME to a CSV entry of the form:
+# QNAME,QNAME at rt-cpan-org.hostedrt.com
+#
+# Feed to /home/admin/git-repos-from-github/pobox-bulk-go/cmd/sync/sync.go
+# which must be invoked FROM THE DIRECTORY
+# /home/admin/git-repos-from-github/pobox-bulk-go
+# for some strange go-ish reason
+
+DIR=/home/admin/git-repos-from-github/pobox-bulk-go
+cd $DIR
+if test "$?" != 0 ; then
+ echo "*** Cannot cd $DIR; bailing out"
+ exit 1
+fi
+
+psql -U admin -h 127.0.0.1 -c "SELECT Name FROM Queues" --tuples-only --no-align rt5 | \
+ egrep -v '[ :+]' | grep -v '^___Approvals$' | grep -v '\.$' | \
+ sed -e 's/\(.*\)/\1,\1 at rt-cpan-org.hostedrt.com/' | \
+ /usr/local/go/bin/go run cmd/sync/sync.go --domain rt.cpan.org --timeout 60m0s --delay 0
commit de93cd13eed5866e6e5d6efdb7352c47ac616582
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 11:46:56 2021 -0500
Avoid warnings when printing debug messages that include potentially undef variables
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index d138d03..9d30ea3 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -370,7 +370,8 @@ sub _sync_bugtracker_cpan2rt {
next unless ($maturity || '') eq 'released';
next unless ($status || '') eq 'latest';
- debug { "Got '$dist' ($mailto, $web)" };
+ debug { "Got '$dist' (" . (defined($mailto) ? $mailto : 'undef') .
+ " ," . (defined($web) ? $web : 'undef') . ")" };
# Email based alternative - we don't care if this is rt.cpan.org
if(defined($mailto) && !($mailto =~ m/rt\.cpan\.org/)) {
commit 742339ab5340fe53b8eb774f3301110309ef1ff4
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 11:45:11 2021 -0500
Add "use lib '.';" for modern Perl versions
diff --git a/Makefile.PL b/Makefile.PL
index 5efe4f2..bb07919 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,3 +1,5 @@
+use lib '.';
+
use inc::Module::Install;
name 'CPAN2RT';
commit f8c668549b08623a5004490120900e04ac1a08d1
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 11:43:34 2021 -0500
Get the underlying scroller from the result set
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 33e80db..d138d03 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -313,17 +313,21 @@ sub _sync_bugtracker_cpan2rt {
require MetaCPAN::Client;
my $mc = MetaCPAN::Client->new;
- my $scroller = $mc->all('releases',
+ my $resultset = $mc->all('releases',
{ fields => ['distribution', 'maturity', 'status',
'resources.bugtracker.web',
'resources.bugtracker.mailto']
}
);
- unless ( defined($scroller) ) {
+ unless ( defined($resultset) ) {
die("Request to api.metacpan.org failed.\n");
}
+ # We are given a MetaCPAN::Client::ResultSet but want the underlying
+ # scroller
+ my $scroller = $resultset->scroller;
+
debug { "Requested data from api.metacpan.org\n" };
my @has_bugtracker;
commit 72c9e14e079ea0f638b72a78a20c06bef066f940
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 11:05:29 2021 -0500
Handle differences in how MetaCPAN versions return results.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index e3017dc..33e80db 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -330,7 +330,15 @@ sub _sync_bugtracker_cpan2rt {
# Iterate the results from MetaCPAN
while ( my $result = $scroller->next ) {
- my $data = $result->{fields};
+
+ # Some versions of MetaCPAN::Client return the fields in
+ # {fields}. Some in {data}. Why the change? No idea.
+ my $data;
+ if ($result->{fields}) {
+ $data = $result->{fields};
+ } else {
+ $data = $result->{data};
+ }
my $bugtracker = {};
commit 172ac7869a52f914f1ff80e609a7c8dd2e469866
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 09:48:17 2021 -0500
Work around the fact that MetaCPAN::Client sometimes returns a string and sometimes an array of strings for a given field, with seemingly no way to predict what you will get.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index eaa9ed3..e3017dc 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -334,19 +334,29 @@ sub _sync_bugtracker_cpan2rt {
my $bugtracker = {};
- # Record data
+ # MetaCPAN sometimes returns a string for each
+ # field, and sometimes an array. Why? We have no idea.
+ # But we have to handle it, so if we get back an array,
+ # pull out the first element... all the arrays I have seen
+ # so far have contained only one element.
my $dist = $data->{'distribution'};
+ $dist = $dist->[0] if ( (ref($dist) || '') eq 'ARRAY' );
my $mailto = $data->{'resources.bugtracker.mailto'};
+ $mailto = $mailto->[0] if ( (ref($mailto) || '') eq 'ARRAY' );
my $web = $data->{'resources.bugtracker.web'};
+ $web = $web->[0] if ( (ref($web) || '') eq 'ARRAY' );
if (!$dist) {
#debug { "Result without distribution: " . Data::Dumper::Dumper($result) };
next;
}
- next unless ($data->{'maturity'} || '') eq 'released';
- next unless ($data->{'status'} || '') eq 'latest';
-
+ my $maturity = $data->{'maturity'};
+ $maturity = $maturity->[0] if ( (ref($maturity) || '') eq 'ARRAY' );
+ my $status = $data->{'status'};
+ $status = $status->[0] if ( (ref($status) || '') eq 'ARRAY' );
+ next unless ($maturity || '') eq 'released';
+ next unless ($status || '') eq 'latest';
debug { "Got '$dist' ($mailto, $web)" };
commit fdf1d84d4d605d9bfc28bc6b1b844059cd2e99a9
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 09:02:23 2021 -0500
Core RT treats custom fields as case-insensitive; let's do the same
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index b834147..eaa9ed3 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -863,10 +863,9 @@ sub load_or_create_version_cf {
my $cfs = RT::CustomFields->new( $RT::SystemUser );
- # Explicitly specify case-sensitive searches. Newer versions
- # of RT::SearchBuilder issue a warning if we don't do that,
- # so silence the warnings.
- $cfs->Limit( FIELD => 'Name', VALUE => $name, CASESENSITIVE => 1 );
+ # Explicitly specify case-insensitive searches. Newer versions
+ # of RT::SearchBuilder issue a warning if we don't do that.
+ $cfs->Limit( FIELD => 'Name', VALUE => $name, CASESENSITIVE => 0 );
$cfs->LimitToQueue( $queue->id );
$cfs->{'find_disabled_rows'} = 0; # This is why we don't simply do a LoadByName
commit 17b977521f85e62810a6b345b45d3293a9bc741a
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 08:58:10 2021 -0500
Silence warnings about case-sensitive searches.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 41282b0..b834147 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -862,7 +862,12 @@ sub load_or_create_version_cf {
my ($queue, $name) = @_;
my $cfs = RT::CustomFields->new( $RT::SystemUser );
- $cfs->Limit( FIELD => 'Name', VALUE => $name );
+
+ # Explicitly specify case-sensitive searches. Newer versions
+ # of RT::SearchBuilder issue a warning if we don't do that,
+ # so silence the warnings.
+ $cfs->Limit( FIELD => 'Name', VALUE => $name, CASESENSITIVE => 1 );
+
$cfs->LimitToQueue( $queue->id );
$cfs->{'find_disabled_rows'} = 0; # This is why we don't simply do a LoadByName
$cfs->OrderByCols; # don't sort things
commit 783e5ae797f7432aa3a3dd83a459be74dc387245
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Fri Feb 26 08:28:52 2021 -0500
Pull only the fields of interest when syncing bugtrackers
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index bfadefd..41282b0 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -313,7 +313,12 @@ sub _sync_bugtracker_cpan2rt {
require MetaCPAN::Client;
my $mc = MetaCPAN::Client->new;
- my $scroller = $mc->all('releases');
+ my $scroller = $mc->all('releases',
+ { fields => ['distribution', 'maturity', 'status',
+ 'resources.bugtracker.web',
+ 'resources.bugtracker.mailto']
+ }
+ );
unless ( defined($scroller) ) {
die("Request to api.metacpan.org failed.\n");
@@ -325,28 +330,22 @@ sub _sync_bugtracker_cpan2rt {
# Iterate the results from MetaCPAN
while ( my $result = $scroller->next ) {
- my $data = $result->{data};
+ my $data = $result->{fields};
my $bugtracker = {};
# Record data
- my $dist = $data->{distribution};
- my $mailto;
- my $web;
- if ($data->{resources} && $data->{resources}->{bugtracker}) {
- $mailto = $data->{resources}->{bugtracker}->{mailto};
- $web = $data->{resources}->{bugtracker}->{web};
- }
+ my $dist = $data->{'distribution'};
+ my $mailto = $data->{'resources.bugtracker.mailto'};
+ my $web = $data->{'resources.bugtracker.web'};
if (!$dist) {
#debug { "Result without distribution: " . Data::Dumper::Dumper($result) };
next;
}
- next unless $data->{maturity};
- next unless $data->{maturity} eq 'released';
- next unless $data->{status};
- next unless $data->{status} eq 'latest';
+ next unless ($data->{'maturity'} || '') eq 'released';
+ next unless ($data->{'status'} || '') eq 'latest';
debug { "Got '$dist' ($mailto, $web)" };
commit aed7138b92cbba5a299a5cc94bd355a846375796
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Thu Feb 25 17:02:51 2021 -0500
Use MetaCPAN::Client instead of ElasticSearch to sync bugtracker info
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 3cdd4c1..bfadefd 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -310,54 +310,10 @@ This updates and adds to existing queues.
sub _sync_bugtracker_cpan2rt {
my $self = shift;
- require ElasticSearch;
- my $es = ElasticSearch->new(
- servers => 'fastapi.metacpan.org',
- no_refresh => 1,
- transport => 'http',
- );
- $es->transport->client->agent(join "/", __PACKAGE__, $VERSION);
-
- # Ian Norton wrote:
- # > Thomas Sibley wrote:
- # >> 2) Is it feasible to further limit returned [MetaCPAN] results to those where
- # >> .web or .mailto lacks "rt.cpan.org"?
- # >
- # > Spoke to the metacpan guys on irc and seemingly it would be expensive to
- # > do this server side. Request submitted to have the fields added as full
- # > text searchable - https://github.com/CPAN-API/cpan-api/issues/238
- # > following a chat with clintongormley. Once that's done then we can
- # > improve this.
-
- # Pull the details of distribution bugtrackers
- my $scroller = $es->scrolled_search(
- query => { match_all => {} },
- size => 100,
- search_type => 'scan',
- scroll => '5m',
- index => 'v1',
- type => 'release',
- fields => [ "distribution" , "resources.bugtracker" ],
- filter => {
- and => [{
- or => [
- {
- and => [
- { exists => { field => "resources.bugtracker.mailto" }},
- { not => { query => { wildcard => { "resources.bugtracker.mailto" => '*rt.cpan.org*' }}}},
- ],
- },{
- and => [
- { exists => { field => "resources.bugtracker.web" }},
- { not => { query => { wildcard => { "resources.bugtracker.web" => '*://rt.cpan.org*' }}}},
- ],
- }
- ]},
- { term => { "release.status" => "latest" }},
- { term => { "release.maturity" => "released" }},
- ],
- },
- );
+ require MetaCPAN::Client;
+ my $mc = MetaCPAN::Client->new;
+
+ my $scroller = $mc->all('releases');
unless ( defined($scroller) ) {
die("Request to api.metacpan.org failed.\n");
@@ -369,18 +325,30 @@ sub _sync_bugtracker_cpan2rt {
# Iterate the results from MetaCPAN
while ( my $result = $scroller->next ) {
+ my $data = $result->{data};
+
my $bugtracker = {};
# Record data
- my $dist = $result->{"fields"}->{"distribution"};
- my $mailto = $result->{"fields"}->{"resources.bugtracker"}->{"mailto"};
- my $web = $result->{"fields"}->{"resources.bugtracker"}->{"web"};
+ my $dist = $data->{distribution};
+ my $mailto;
+ my $web;
+ if ($data->{resources} && $data->{resources}->{bugtracker}) {
+ $mailto = $data->{resources}->{bugtracker}->{mailto};
+ $web = $data->{resources}->{bugtracker}->{web};
+ }
if (!$dist) {
#debug { "Result without distribution: " . Data::Dumper::Dumper($result) };
next;
}
+ next unless $data->{maturity};
+ next unless $data->{maturity} eq 'released';
+ next unless $data->{status};
+ next unless $data->{status} eq 'latest';
+
+
debug { "Got '$dist' ($mailto, $web)" };
# Email based alternative - we don't care if this is rt.cpan.org
commit cdb51099d249207e1d6312ad6b564163efe9447e
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Wed Feb 24 15:39:11 2021 -0500
Fix code that created bad SQL; fix code that died with a "Wide character" error
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 18d858f..3cdd4c1 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -467,12 +467,14 @@ sub _sync_bugtracker_rt2cpan {
# Find queues with a DistributionBugtracker attribute
my $queues = RT::Queues->new( $RT::SystemUser );
- $queues->Limit(
- FIELD => 'id',
- OPERATOR => 'NOT IN',
- VALUE => $has_bugtracker,
- );
-
+ if (scalar(@$has_bugtracker)) {
+ $queues->Limit(
+ FIELD => 'id',
+ OPERATOR => 'NOT IN',
+ VALUE => $has_bugtracker,
+ );
+ }
+
my $attributes = $queues->Join(
ALIAS1 => 'main',
FIELD1 => 'id',
@@ -1061,7 +1063,7 @@ sub end_element {
if ( $name eq 'cpanid' ) {
$self->{inside} = 0;
- my %rec = map Encode::decode_utf8($_), @{ delete $self->{'tmp'} };
+ my %rec = @{ delete $self->{'tmp'} };
$self->{'res'}{ delete $rec{'id'} } = \%rec;
}
}
commit 877236d289d33ae1d7afa1d092fcd8d7c4aa9509
Author: Dianne Skoll <dianne at bestpractical.com>
Date: Wed Feb 24 15:38:55 2021 -0500
Fix path to Perl interpreter for Hosted RT installation
diff --git a/bin/cpan2rt b/bin/cpan2rt
index 7bf9e14..8cb64f1 100755
--- a/bin/cpan2rt
+++ b/bin/cpan2rt
@@ -1,6 +1,6 @@
-#!/home/rtcpan/perlbrew/perls/perl-5.16.3/bin/perl
+#!/opt/perl/bin/perl
-eval 'exec /home/rtcpan/perlbrew/perls/perl-5.16.3/bin/perl -S $0 ${1+"$@"}'
+eval 'exec /opt/perl/bin/perl -S $0 ${1+"$@"}'
if 0; # not running under some shell
=head1 NAME
commit 27308caee0e167dba5b254c324a1a39466d8cd6b
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Sat Oct 14 15:24:20 2017 -0400
Check in version found on rt.cpan.org
diff --git a/bin/cpan2rt b/bin/cpan2rt
index cff3165..7bf9e14 100755
--- a/bin/cpan2rt
+++ b/bin/cpan2rt
@@ -1,4 +1,7 @@
-#!/usr/bin/perl
+#!/home/rtcpan/perlbrew/perls/perl-5.16.3/bin/perl
+
+eval 'exec /home/rtcpan/perlbrew/perls/perl-5.16.3/bin/perl -S $0 ${1+"$@"}'
+ if 0; # not running under some shell
=head1 NAME
@@ -89,6 +92,7 @@ sub cmd_update {
$importer->sync_distributions( $opt{'force'} ) unless $opt{'skip'}{'distributions'};
$importer->sync_versions( $opt{'force'} ) unless $opt{'skip'}{'versions'};
$importer->sync_maintainers( $opt{'force'} ) unless $opt{'skip'}{'maintainers'};
+ $importer->sync_bugtracker( $opt{'force'} ) unless $opt{'skip'}{'bugtrackers'};
}
sub usage {
commit 4e6d3c032eb5ac4dcd195808d006aeacfe1e77fd
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Sat Oct 14 15:15:50 2017 -0400
Check in version found on rt.cpan.org
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 1f39c69..18d858f 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -68,31 +68,28 @@ See options in description of L</new>.
sub init {
my $self = shift;
- my $home = ($self->{'home'} ||= $ENV{'RTHOME'});
- if ( $home ) {
- unshift @INC, File::Spec->catdir( $home, 'lib' );
- unshift @INC, File::Spec->catdir( $home, 'local', 'lib' );
- }
+ die "datadir ($self->{datadir}) doesn't exist!\n"
+ if $self->{datadir} and not -d $self->{datadir};
+
+ my $home = ($self->{'home'} ||= $ENV{'RTHOME'} || '/opt/rt3');
+ unshift @INC, File::Spec->catdir( $home, 'lib' );
+ unshift @INC, File::Spec->catdir( $home, 'local', 'lib' );
$DEBUG = $self->{'debug'};
require RT;
RT::LoadConfig();
if ( $DEBUG ) {
- RT->Config->Set( LogToScreen => 'debug' );
+ $RT::LogToScreen = 'debug';
} else {
- RT->Config->Set( LogToScreen => 'warning' );
+ $RT::LogToScreen = 'warning';
}
RT::Init();
-
- unless ( RT::User->can('MergeInto') ) {
- die "CPAN2RT needs RT::Extension::MergeUsers to work properly";
- }
}
sub sync_files {
my $self = shift;
- my $mirror = shift || $self->{'mirror'} || 'http://cpan.perl.org';
+ my $mirror = shift || $self->{'mirror'} || 'ftp://ftp.funet.fi/pub/CPAN';
debug { "Syncing files from '$mirror'\n" };
@@ -293,6 +290,214 @@ sub sync_authors {
return (1);
}
+sub sync_bugtracker {
+ my $self = shift;
+
+ debug { "Syncing alternate bug trackers\n" };
+
+ my $has_bugtracker = $self->_sync_bugtracker_cpan2rt();
+
+ $self->_sync_bugtracker_rt2cpan( $has_bugtracker );
+}
+
+=head2 _sync_bugtracker_cpan2rt
+
+Sync DistributionBugtracker info from CPAN to RT.
+This updates and adds to existing queues.
+
+=cut
+
+sub _sync_bugtracker_cpan2rt {
+ my $self = shift;
+
+ require ElasticSearch;
+ my $es = ElasticSearch->new(
+ servers => 'fastapi.metacpan.org',
+ no_refresh => 1,
+ transport => 'http',
+ );
+ $es->transport->client->agent(join "/", __PACKAGE__, $VERSION);
+
+ # Ian Norton wrote:
+ # > Thomas Sibley wrote:
+ # >> 2) Is it feasible to further limit returned [MetaCPAN] results to those where
+ # >> .web or .mailto lacks "rt.cpan.org"?
+ # >
+ # > Spoke to the metacpan guys on irc and seemingly it would be expensive to
+ # > do this server side. Request submitted to have the fields added as full
+ # > text searchable - https://github.com/CPAN-API/cpan-api/issues/238
+ # > following a chat with clintongormley. Once that's done then we can
+ # > improve this.
+
+ # Pull the details of distribution bugtrackers
+ my $scroller = $es->scrolled_search(
+ query => { match_all => {} },
+ size => 100,
+ search_type => 'scan',
+ scroll => '5m',
+ index => 'v1',
+ type => 'release',
+ fields => [ "distribution" , "resources.bugtracker" ],
+ filter => {
+ and => [{
+ or => [
+ {
+ and => [
+ { exists => { field => "resources.bugtracker.mailto" }},
+ { not => { query => { wildcard => { "resources.bugtracker.mailto" => '*rt.cpan.org*' }}}},
+ ],
+ },{
+ and => [
+ { exists => { field => "resources.bugtracker.web" }},
+ { not => { query => { wildcard => { "resources.bugtracker.web" => '*://rt.cpan.org*' }}}},
+ ],
+ }
+ ]},
+ { term => { "release.status" => "latest" }},
+ { term => { "release.maturity" => "released" }},
+ ],
+ },
+ );
+
+ unless ( defined($scroller) ) {
+ die("Request to api.metacpan.org failed.\n");
+ }
+
+ debug { "Requested data from api.metacpan.org\n" };
+
+ my @has_bugtracker;
+
+ # Iterate the results from MetaCPAN
+ while ( my $result = $scroller->next ) {
+ my $bugtracker = {};
+
+ # Record data
+ my $dist = $result->{"fields"}->{"distribution"};
+ my $mailto = $result->{"fields"}->{"resources.bugtracker"}->{"mailto"};
+ my $web = $result->{"fields"}->{"resources.bugtracker"}->{"web"};
+
+ if (!$dist) {
+ #debug { "Result without distribution: " . Data::Dumper::Dumper($result) };
+ next;
+ }
+
+ debug { "Got '$dist' ($mailto, $web)" };
+
+ # Email based alternative - we don't care if this is rt.cpan.org
+ if(defined($mailto) && !($mailto =~ m/rt\.cpan\.org/)) {
+ $bugtracker->{"mailto"} = $mailto;
+ }
+
+ # Web based alternative - we don't care if this is rt.cpan.org
+ if(defined($web) && !($web =~ m/rt\.cpan\.org/)) {
+ $bugtracker->{"web"} = $web;
+ }
+
+ unless (keys %$bugtracker) {
+ debug { "Got '$dist' from metacpan, but no alternate bugtracker found" };
+ next;
+ }
+
+ # Fetch the queue
+ my $queue = $self->load_queue( $dist );
+ unless( $queue ) {
+ debug { "No queue for dist '$dist'" };
+ next;
+ }
+
+ push @has_bugtracker, $queue->id;
+
+ # Get the existing bugtracker from the queue and log if it's changing
+ my $attr = $queue->DistributionBugtracker();
+
+ # Set this if we need to update when we're done
+ my $update = 0;
+
+ # If the attr is defined, then check it hasn't changed.
+ if(defined($attr)) {
+
+ debug { "Bugtracker set for distribution '$dist'. Has it changed?\n" };
+
+ foreach my $method (keys(%{$bugtracker})) {
+
+ if(ref($attr) eq "HASH") {
+ # If this method has changed, log it
+ if(defined($attr->{$method}) && $attr->{$method} ne $bugtracker->{$method}) {
+ debug { "Changing DistributionBugtracker for $dist from '" . $attr->{$method} . "' to '" . $bugtracker->{$method} . "'\n" };
+ $update = 1;
+ } else {
+ debug { "Bugtracker $method for $dist is the same. Skipping.\n" };
+ }
+ }
+
+ else {
+ # Hmm, something odd happened. Data in the db is wrong, fix it.
+ debug { "Bugtracker data in database looks corrupt? Updating." };
+ $update = 1;
+ }
+ }
+ }
+
+ else {
+ debug { "Setting DistributionBugtracker for $dist from nothing\n" };
+ $update = 1;
+ }
+
+
+ if($update) {
+ # Set the queue bugtracker
+ $queue->SetDistributionBugtracker( $bugtracker );
+ }
+ }
+
+ return \@has_bugtracker;
+}
+
+=head2 _sync_bugtracker_rt2cpan
+
+Sync DistributionBugtracker info from RT to CPAN.
+This deletes records that are no longer needed or missing in the source.
+
+=cut
+
+sub _sync_bugtracker_rt2cpan {
+ my $self = shift;
+ my $has_bugtracker = shift;
+ my $name = "DistributionBugtracker";
+
+ # Find queues with a DistributionBugtracker attribute
+ my $queues = RT::Queues->new( $RT::SystemUser );
+ $queues->Limit(
+ FIELD => 'id',
+ OPERATOR => 'NOT IN',
+ VALUE => $has_bugtracker,
+ );
+
+ my $attributes = $queues->Join(
+ ALIAS1 => 'main',
+ FIELD1 => 'id',
+ TABLE2 => 'Attributes',
+ FIELD2 => 'ObjectId',
+ );
+ $queues->Limit(
+ ALIAS => $attributes,
+ FIELD => "ObjectType",
+ VALUE => "RT::Queue",
+ );
+ $queues->Limit(
+ ALIAS => $attributes,
+ FIELD => "Name",
+ VALUE => $name,
+ );
+
+ # Iterate over queues from RT
+ while(my $queue = $queues->Next()) {
+ # Delete the attribute, it's no longer needed.
+ debug { "Deleting alternate bugtracker attribute for " . $queue->Name };
+ $queue->DeleteAttribute( $name );
+ }
+}
+
sub sync_distributions {
my $self = shift;
my $force = shift;
@@ -569,114 +774,61 @@ sub add_versions {
sub load_or_create_user {
my $self = shift;
- my ($cpanid, $realname, $public_email) = @_;
-
- my $user = $self->load_and_fix_user( $cpanid, $public_email);
- if ( $user ) {
- if ( $realname && $realname ne ($user->RealName||'') ) {
- my ($status, $msg) = $user->SetRealName( $realname );
- $RT::Logger->warning("Couldn't set ${cpanid}'s real name: $msg")
- unless $status;
- }
-
- return $user;
- }
- return $self->create_user($cpanid, $realname, $cpanid .'@cpan.org');
-}
-
-sub load_and_fix_user {
- my $self = shift;
- my ($cpanid, $public_email) = @_;
-
- # WARNING: We can not trust public email addresses people publish
- # on PAUSE. They are not validated in any way! That's it.
-
- my $cpan_email = $cpanid .'@cpan.org';
-
- # quick test for case when Name and Email are cosher in one record
- {
- my $tmp = RT::User->new( $RT::SystemUser );
- $tmp->LoadByCols( Name => $cpanid, EmailAddress => $cpan_email );
- if ( $tmp->id ) {
- $RT::Logger->debug(
- "User record with name '$cpanid'"
- ." and email '$cpan_email' exists."
- );
- return $tmp;
- }
- }
+ my ($cpanid, $realname, $email) = @_;
my $bycpanid = RT::User->new($RT::SystemUser);
- $bycpanid->LoadByCols( Name => $cpanid );
+ $bycpanid->LoadByCol( Name => $cpanid );
+ # WARNING: when MergeUser extension is used then the same user records
+ # will be loaded even when there are multiple records in the DB
+ $email = $self->parse_email_address( $email ) || "$cpanid\@cpan.org";
my $byemail = RT::User->new( $RT::SystemUser );
- $byemail->LoadByEmail( $cpan_email );
+ $byemail->LoadByEmail( $email );
- return undef if !$bycpanid->id && !$byemail->id;
-
- if ( $bycpanid->id && !$byemail->id ) {
- my $current_email = $bycpanid->EmailAddress;
- unless ( $current_email ) {
- my ($status, $msg) = $bycpanid->SetEmailAddress( $cpan_email );
- $RT::Logger->error("Couldn't set email address: $msg")
- unless $status;
- }
- elsif ( $current_email =~ /\@cpan\.org$/i ) {
- # user has fake @cpan.org address, other is impossible
- my ($status, $msg) = $bycpanid->SetEmailAddress( $cpan_email );
- $RT::Logger->error("Couldn't set email address: $msg")
- unless $status;
- }
- else {
- # $current_email ne $cpan_email
- my ($tmp, $msg) = $self->create_user(
- $cpan_email, undef, $cpan_email
- );
- if ( $tmp ) {
- my ($status, $msg) = $tmp->MergeInto( $bycpanid );
- $RT::Logger->error("Couldn't merge users: $msg")
- unless $status;
- } else {
- $RT::Logger->error("Couldn't create user for merging: $msg");
- }
- }
+ if ( $bycpanid->id && (($byemail->id && $bycpanid->id == $byemail->id) || !$byemail->id) ) {
+ # the same users, both cpanid and email...
+ # or email change, so no user with new email...
+ #
+ # XXX: as we have no way to detect email changes on PAUSE
+ # then we set email to the public version from PAUSE only when
+ # user in RT has no email. The same applies to name.
+ $bycpanid->SetEmailAddress( $email )
+ unless $bycpanid->EmailAddress;
+ $bycpanid->SetRealName( $realname )
+ unless $bycpanid->RealName;
return $bycpanid;
}
- elsif ( !$bycpanid->id && $byemail->id ) {
- my ($status, $msg) = $byemail->SetName( $cpanid );
- $RT::Logger->error("Couldn't set user name (login): $msg" )
- unless $status;
- return $byemail;
- }
-# cases when users by id and email exist
- elsif ( $bycpanid->id != $byemail->id ) {
- my $current_email = $bycpanid->EmailAddress;
- if ( $current_email && $current_email =~ /\@cpan\.org$/i ) {
- # user has fake @cpan.org address, other is impossible
- $current_email = undef;
- }
-
- unless ( $current_email ) {
- # switch email address from secondary record to primary
- my ($status, $msg) = $byemail->SetEmailAddress('');
- $RT::Logger->error("Couldn't set email address: $msg")
- unless $status;
- ($status, $msg) = $bycpanid->SetEmailAddress( $cpan_email );
- $RT::Logger->error("Couldn't set email address: $msg")
- unless $status;
- }
-
- my ($status, $msg) = $byemail->MergeInto( $bycpanid );
- $RT::Logger->error(
- "Couldn't merge user #". $byemail->id
- ." into #". $bycpanid->id .": $msg"
- ) unless $status;
+ elsif ( $bycpanid->id && $byemail->id ) {
+ # both exist, but different
+ # XXX: merge them
+ debug {
+ sprintf "WARNING: Two RT users for the same PAUSE author: %s (%d) and %s (%d)\n",
+ $bycpanid->Name, $bycpanid->id, $byemail->EmailAddress, $byemail->id
+ };
return $bycpanid;
}
- else {
- # already merged
- return $bycpanid;
+ elsif ( $byemail->id ) {
+ # there is already user with that address, but different CPANID
+ my ($new, $msg) = $self->create_user( $cpanid, $realname );
+ return ($new, $msg) unless $new;
+
+ if ( $new->can('MergeInto') ) {
+ debug { "Merging user @{[$new->Name]} into @{[$byemail->Name]}...\n" };
+ my ($ok, $msg) = $new->MergeInto( $byemail );
+ if ($ok) {
+ $byemail->SetPrivileged(1);
+ } else {
+ debug { "Couldn't merge user @{[$new->id]} into @{[$byemail->id]}: $msg" };
+ }
+ } else {
+ debug {
+ "WARNING: Couldn't merge user @{[$new->Name]} into @{[$byemail->Name]}."
+ ." Extension is not installed.\n" };
+ }
+ return ($new);
}
+
+ return $self->create_user($cpanid, $realname, $email);
}
sub create_user {
commit ade101e80f6ff9bfc87885fe11b35d500d45a303
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Mar 12 17:16:40 2013 -0700
A working --skip option to bin/cpan2rt
The option was introduced in ef17b54 but didn't work correctly until
now.
Yet another reason to prefer the block form of map. :)
diff --git a/bin/cpan2rt b/bin/cpan2rt
index b334258..cff3165 100755
--- a/bin/cpan2rt
+++ b/bin/cpan2rt
@@ -81,7 +81,7 @@ $commands{ $command }->();
sub cmd_update {
my %opt = ( sync => 1, force => 0, debug => 0, skip => [] );
GetOptions( \%opt, 'sync!', 'force!', 'debug!', 'home=s', 'datadir=s', 'mirror=s', 'skip=s@' );
- $opt{'skip'} = { map $_ => 1, @{$opt{'skip'}} };
+ $opt{'skip'} = { map { $_ => 1 } @{$opt{'skip'}} };
my $importer = CPAN2RT->new( %opt );
$importer->sync_files( $opt{'mirror'} ) if $opt{'sync'};
commit 560f7ff4c2199963aff0d776a6fc8282c9e85363
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Oct 17 13:20:56 2011 -0400
Switch cache check to use the file we parse
Since 01mailrc.txt.old hasn't existed, this didn't stop sync_authors
from running.
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index e4941df..1f39c69 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -276,7 +276,7 @@ sub for_all_distributions {
sub sync_authors {
my $self = shift;
my $force = shift;
- if ( !$force && !$self->is_new_file( '01mailrc.txt' ) ) {
+ if ( !$force && !$self->is_new_file( '00whois.xml' ) ) {
debug { "Skip syncing, file's not changed\n" };
return (1);
}
commit af0cfb4b58346361efe81e110d35dde0ed3d7f8e
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat May 28 01:54:05 2011 +0400
gitignore
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..49467aa
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.old
+*.bak
+*~
+Makefile
+blib/
+pm_to_blib
+t/tmp/
commit ef17b5407b8fcd6c413439cb294f1e32da4d42e8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jan 10 00:39:41 2011 +0300
add --skip option
diff --git a/bin/cpan2rt b/bin/cpan2rt
index b800248..b334258 100755
--- a/bin/cpan2rt
+++ b/bin/cpan2rt
@@ -79,16 +79,16 @@ unless ( $command ) {
$commands{ $command }->();
sub cmd_update {
- my %opt = ( sync => 1, force => 0, debug => 0 );
- GetOptions( \%opt, 'sync!', 'force!', 'debug!', 'home=s', 'datadir=s', 'mirror=s' );
-
+ my %opt = ( sync => 1, force => 0, debug => 0, skip => [] );
+ GetOptions( \%opt, 'sync!', 'force!', 'debug!', 'home=s', 'datadir=s', 'mirror=s', 'skip=s@' );
+ $opt{'skip'} = { map $_ => 1, @{$opt{'skip'}} };
my $importer = CPAN2RT->new( %opt );
$importer->sync_files( $opt{'mirror'} ) if $opt{'sync'};
- $importer->sync_authors( $opt{'force'} );
- $importer->sync_distributions( $opt{'force'} );
- $importer->sync_versions( $opt{'force'} );
- $importer->sync_maintainers( $opt{'force'} );
+ $importer->sync_authors( $opt{'force'} ) unless $opt{'skip'}{'authors'};
+ $importer->sync_distributions( $opt{'force'} ) unless $opt{'skip'}{'distributions'};
+ $importer->sync_versions( $opt{'force'} ) unless $opt{'skip'}{'versions'};
+ $importer->sync_maintainers( $opt{'force'} ) unless $opt{'skip'}{'maintainers'};
}
sub usage {
commit 3a35d83c09f4e4951c60860766346ae3fe63d589
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Jun 8 03:08:47 2010 +0400
refactor load_or_create_user to match new rules
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 5342c87..e4941df 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -569,53 +569,114 @@ sub add_versions {
sub load_or_create_user {
my $self = shift;
- my ($cpanid, $realname, $email) = @_;
+ my ($cpanid, $realname, $public_email) = @_;
+
+ my $user = $self->load_and_fix_user( $cpanid, $public_email);
+ if ( $user ) {
+ if ( $realname && $realname ne ($user->RealName||'') ) {
+ my ($status, $msg) = $user->SetRealName( $realname );
+ $RT::Logger->warning("Couldn't set ${cpanid}'s real name: $msg")
+ unless $status;
+ }
+
+ return $user;
+ }
+ return $self->create_user($cpanid, $realname, $cpanid .'@cpan.org');
+}
+
+sub load_and_fix_user {
+ my $self = shift;
+ my ($cpanid, $public_email) = @_;
+
+ # WARNING: We can not trust public email addresses people publish
+ # on PAUSE. They are not validated in any way! That's it.
+
+ my $cpan_email = $cpanid .'@cpan.org';
+
+ # quick test for case when Name and Email are cosher in one record
+ {
+ my $tmp = RT::User->new( $RT::SystemUser );
+ $tmp->LoadByCols( Name => $cpanid, EmailAddress => $cpan_email );
+ if ( $tmp->id ) {
+ $RT::Logger->debug(
+ "User record with name '$cpanid'"
+ ." and email '$cpan_email' exists."
+ );
+ return $tmp;
+ }
+ }
my $bycpanid = RT::User->new($RT::SystemUser);
- $bycpanid->LoadByCol( Name => $cpanid );
+ $bycpanid->LoadByCols( Name => $cpanid );
- # WARNING: when MergeUser extension is used then the same user records
- # will be loaded even when there are multiple records in the DB
- $email = $self->parse_email_address( $email ) || "$cpanid\@cpan.org";
my $byemail = RT::User->new( $RT::SystemUser );
- $byemail->LoadByEmail( $email );
+ $byemail->LoadByEmail( $cpan_email );
- if ( $bycpanid->id && (($byemail->id && $bycpanid->id == $byemail->id) || !$byemail->id) ) {
- # the same users, both cpanid and email...
- # or email change, so no user with new email...
- #
- # XXX: as we have no way to detect email changes on PAUSE
- # then we set email to the public version from PAUSE only when
- # user in RT has no email. The same applies to name.
- $bycpanid->SetEmailAddress( $email )
- unless $bycpanid->EmailAddress;
- $bycpanid->SetRealName( $realname )
- unless $bycpanid->RealName;
+ return undef if !$bycpanid->id && !$byemail->id;
+
+ if ( $bycpanid->id && !$byemail->id ) {
+ my $current_email = $bycpanid->EmailAddress;
+ unless ( $current_email ) {
+ my ($status, $msg) = $bycpanid->SetEmailAddress( $cpan_email );
+ $RT::Logger->error("Couldn't set email address: $msg")
+ unless $status;
+ }
+ elsif ( $current_email =~ /\@cpan\.org$/i ) {
+ # user has fake @cpan.org address, other is impossible
+ my ($status, $msg) = $bycpanid->SetEmailAddress( $cpan_email );
+ $RT::Logger->error("Couldn't set email address: $msg")
+ unless $status;
+ }
+ else {
+ # $current_email ne $cpan_email
+ my ($tmp, $msg) = $self->create_user(
+ $cpan_email, undef, $cpan_email
+ );
+ if ( $tmp ) {
+ my ($status, $msg) = $tmp->MergeInto( $bycpanid );
+ $RT::Logger->error("Couldn't merge users: $msg")
+ unless $status;
+ } else {
+ $RT::Logger->error("Couldn't create user for merging: $msg");
+ }
+ }
return $bycpanid;
}
- elsif ( $bycpanid->id && $byemail->id ) {
- # both exist, but different
- # XXX: merge them
- debug { "WARNING: Two different users\n" };
+ elsif ( !$bycpanid->id && $byemail->id ) {
+ my ($status, $msg) = $byemail->SetName( $cpanid );
+ $RT::Logger->error("Couldn't set user name (login): $msg" )
+ unless $status;
+ return $byemail;
+ }
+# cases when users by id and email exist
+ elsif ( $bycpanid->id != $byemail->id ) {
+ my $current_email = $bycpanid->EmailAddress;
+ if ( $current_email && $current_email =~ /\@cpan\.org$/i ) {
+ # user has fake @cpan.org address, other is impossible
+ $current_email = undef;
+ }
+
+ unless ( $current_email ) {
+ # switch email address from secondary record to primary
+ my ($status, $msg) = $byemail->SetEmailAddress('');
+ $RT::Logger->error("Couldn't set email address: $msg")
+ unless $status;
+ ($status, $msg) = $bycpanid->SetEmailAddress( $cpan_email );
+ $RT::Logger->error("Couldn't set email address: $msg")
+ unless $status;
+ }
+
+ my ($status, $msg) = $byemail->MergeInto( $bycpanid );
+ $RT::Logger->error(
+ "Couldn't merge user #". $byemail->id
+ ." into #". $bycpanid->id .": $msg"
+ ) unless $status;
return $bycpanid;
}
- elsif ( $byemail->id ) {
- # there is already user with that address, but different CPANID
- my ($new, $msg) = $self->create_user( $cpanid, $realname );
- return ($new, $msg) unless $new;
-
- if ( $new->can('MergeInto') ) {
- debug { "Merging user @{[$new->Name]} into @{[$byemail->Name]}...\n" };
- $new->MergeInto( $byemail );
- } else {
- debug {
- "WARNING: Couldn't merge user @{[$new->Name]} into @{[$byemail->Name]}."
- ." Extension is not installed.\n" };
- }
- return ($new);
+ else {
+ # already merged
+ return $bycpanid;
}
-
- return $self->create_user($cpanid, $realname, $email);
}
sub create_user {
commit eb08758165a1b85f82ff43a73525e49c5e0b1181
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Jun 8 00:47:22 2010 +0400
switch to more reliable mirror by default
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 8ac12d1..5342c87 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -92,7 +92,7 @@ sub init {
sub sync_files {
my $self = shift;
- my $mirror = shift || $self->{'mirror'} || 'ftp://ftp.funet.fi/pub/CPAN';
+ my $mirror = shift || $self->{'mirror'} || 'http://cpan.perl.org';
debug { "Syncing files from '$mirror'\n" };
commit 5900ab692918f55ae55b14941e56ea244bbd9f8d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Jun 8 00:45:05 2010 +0400
we depend on MergeUsers extension
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 8cca211..8ac12d1 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -84,6 +84,10 @@ sub init {
RT->Config->Set( LogToScreen => 'warning' );
}
RT::Init();
+
+ unless ( RT::User->can('MergeInto') ) {
+ die "CPAN2RT needs RT::Extension::MergeUsers to work properly";
+ }
}
sub sync_files {
commit ba5a50b4addf2ad442ac64ce48fb31ea90aa2082
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Jun 8 00:44:32 2010 +0400
use RT->Config->Set
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 63bff70..8cca211 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -79,9 +79,9 @@ sub init {
require RT;
RT::LoadConfig();
if ( $DEBUG ) {
- $RT::LogToScreen = 'debug';
+ RT->Config->Set( LogToScreen => 'debug' );
} else {
- $RT::LogToScreen = 'warning';
+ RT->Config->Set( LogToScreen => 'warning' );
}
RT::Init();
}
commit 8c2581f8ef64b7833ab0e79df646b5ebd6cbf362
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Jun 8 00:43:43 2010 +0400
make module more re-usable as API
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 1a1b0c8..63bff70 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -68,9 +68,11 @@ See options in description of L</new>.
sub init {
my $self = shift;
- my $home = ($self->{'home'} ||= $ENV{'RTHOME'} || '/opt/rt3');
- unshift @INC, File::Spec->catdir( $home, 'lib' );
- unshift @INC, File::Spec->catdir( $home, 'local', 'lib' );
+ my $home = ($self->{'home'} ||= $ENV{'RTHOME'});
+ if ( $home ) {
+ unshift @INC, File::Spec->catdir( $home, 'lib' );
+ unshift @INC, File::Spec->catdir( $home, 'local', 'lib' );
+ }
$DEBUG = $self->{'debug'};
commit 2ca1a45a1726faf5c3675e7f375deb4a0364c606
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Jun 8 00:29:03 2010 +0400
more tests
diff --git a/t/fix_users.t b/t/fix_users.t
index 5610fad..036a789 100644
--- a/t/fix_users.t
+++ b/t/fix_users.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use CPAN2RT::Test tests => 28;
+use CPAN2RT::Test tests => 38;
my $test_class = 'CPAN2RT::Test';
ok( my $importer = CPAN2RT->new( ), "created importer" );
@@ -22,6 +22,10 @@ ok( my $importer = CPAN2RT->new( ), "created importer" );
is( $user->Name, 'A', 'Name is correct' );
is( $user->RealName, 'A A', 'Real name updated' );
is( $user->EmailAddress, 'A at cpan.org', 'Email address is set to cpan\'s' );
+
+ $user = RT::User->new( $RT::SystemUser );
+ $user->LoadByEmail('A at xxx.com');
+ ok(!$user->id, "no user by public email");
}
# user has email and it's no his cpan's
@@ -87,3 +91,93 @@ ok( my $importer = CPAN2RT->new( ), "created importer" );
ok(!$user->id, "no more fake user");
}
+# good 'E' user with E at cpan.org email
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'E',
+ EmailAddress => 'E at cpan.org',
+ Privileged => 1,
+ );
+ $importer->load_or_create_user(
+ E => 'E E' => 'E at xxx.com',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('E');
+ is( $user->Name, 'E', 'Name is correct' );
+ is( $user->RealName, 'E E', 'Real name updated' );
+ is( $user->EmailAddress, 'E at cpan.org', 'Email address is correct' );
+
+ $user = RT::User->new( $RT::SystemUser );
+ $user->LoadByEmail('E at xxx.com');
+ ok(!$user->id, "no user by public email");
+}
+
+# no user at all
+{
+ $importer->load_or_create_user(
+ F => 'F F' => 'F at xxx.com',
+ );
+ my $user = RT::User->new( $RT::SystemUser );
+ $user->Load('F');
+ is( $user->Name, 'F', 'Name is correct' );
+ is( $user->RealName, 'F F', 'Real is set' );
+ is( $user->EmailAddress, 'F at cpan.org', 'Email address is correct' );
+
+ $user = RT::User->new( $RT::SystemUser );
+ $user->LoadByEmail('F at xxx.com');
+ ok(!$user->id, "no user by public email");
+}
+
+# 'G' user with some email and G at cpan.org user with G at cpan.org email
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'G',
+ EmailAddress => 'G at xxx.com',
+ Privileged => 1,
+ );
+ $user = $test_class->load_or_create_user(
+ Name => 'G at cpan.org',
+ EmailAddress => 'G at cpan.org',
+ Privileged => 1,
+ );
+
+ $importer->load_or_create_user(
+ G => 'G G' => 'G at xxx.com',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('G');
+ is( $user->Name, 'G', 'Name is correct' );
+ is( $user->RealName, 'G G', 'Real name updated' );
+ is( $user->EmailAddress, 'G at xxx.com', 'Email address is correct' );
+
+ my $muser = RT::User->new( $RT::SystemUser );
+ $muser->LoadByEmail('G at cpan.org');
+ is($muser->id, $user->id, "users are merged");
+}
+
+# 'H' user with no email and H at cpan.org user with H at cpan.org email
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'H',
+ Privileged => 1,
+ );
+ $user = $test_class->load_or_create_user(
+ Name => 'H at cpan.org',
+ EmailAddress => 'H at cpan.org',
+ Privileged => 1,
+ );
+
+ $importer->load_or_create_user(
+ H => 'H H' => 'H at xxx.com',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('H');
+ is( $user->Name, 'H', 'Name is correct' );
+ is( $user->RealName, 'H H', 'Real name updated' );
+ is( $user->EmailAddress, 'H at cpan.org', 'Email address is correct' );
+
+ my $muser = RT::User->new( $RT::SystemUser );
+ $muser->LoadByCols( Name => 'H at cpan.org' );
+ is($muser->id, $user->id, "users are merged");
+}
+
commit dedd1e05b695435ed5ba871b0466cd1a7b73320a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jun 7 21:04:21 2010 +0400
first tests for importer
diff --git a/t/basics.t b/t/basics.t
new file mode 100644
index 0000000..3a91442
--- /dev/null
+++ b/t/basics.t
@@ -0,0 +1,8 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use CPAN2RT::Test tests => 28;
+ok( my $importer = CPAN2RT->new( ), "created importer" );
+
diff --git a/t/fix_users.t b/t/fix_users.t
new file mode 100644
index 0000000..5610fad
--- /dev/null
+++ b/t/fix_users.t
@@ -0,0 +1,89 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use CPAN2RT::Test tests => 28;
+my $test_class = 'CPAN2RT::Test';
+
+ok( my $importer = CPAN2RT->new( ), "created importer" );
+
+# user has no email and no other user with his cpan email
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'A',
+ Privileged => 1,
+ );
+ $importer->load_or_create_user(
+ A => 'A A' => 'A at xxx.com',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('A');
+ is( $user->Name, 'A', 'Name is correct' );
+ is( $user->RealName, 'A A', 'Real name updated' );
+ is( $user->EmailAddress, 'A at cpan.org', 'Email address is set to cpan\'s' );
+}
+
+# user has email and it's no his cpan's
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'B',
+ EmailAddress => 'B at xxx.com',
+ Privileged => 1,
+ );
+ $importer->load_or_create_user(
+ B => 'B B' => 'B at yyy.com',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('B');
+ is( $user->Name, 'B', 'Name is correct' );
+ is( $user->RealName, 'B B', 'Real name updated' );
+ is( $user->EmailAddress, 'B at xxx.com', 'Email address left alone' );
+
+ my $merged_user = RT::User->new( $RT::SystemUser );
+ $merged_user->LoadByEmail('B at cpan.org');
+
+ is( $merged_user->id, $user->id, 'merged user with email B at cpan.org has been created' );
+
+}
+
+
+# no 'C' user, but user with 'C at cpan.org'
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'C at cpan.org',
+ EmailAddress => 'C at cpan.org',
+ Privileged => 1,
+ );
+ $importer->load_or_create_user(
+ C => 'C C' => 'C at xxx.com',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('C');
+ is( $user->Name, 'C', 'Name is correct' );
+ is( $user->RealName, 'C C', 'Real name updated' );
+ is( $user->EmailAddress, 'C at cpan.org', 'Email address is correct' );
+}
+
+# user has email @cpan.org, but it doesn't match his CPANID
+# some people use it as spam protection
+{
+ my $user = $test_class->load_or_create_user(
+ Name => 'D',
+ EmailAddress => 'QWE at cpan.org',
+ Privileged => 1,
+ );
+ $importer->load_or_create_user(
+ D => 'D D' => 'QWE at cpan.org',
+ );
+ $user = RT::User->new( $RT::SystemUser );
+ $user->Load('D');
+ is( $user->Name, 'D', 'Name is correct' );
+ is( $user->RealName, 'D D', 'Real name updated' );
+ is( $user->EmailAddress, 'D at cpan.org', 'Email address has been changed' );
+
+ $user = RT::User->new( $RT::SystemUser );
+ $user->LoadByEmail('QWE at cpan.org');
+ ok(!$user->id, "no more fake user");
+}
+
commit d82ea762cf254684005aac4517ea14b66e0025ce
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jun 7 21:02:59 2010 +0400
module for testing
diff --git a/lib/CPAN2RT/Test.pm b/lib/CPAN2RT/Test.pm
new file mode 100644
index 0000000..e4e13d0
--- /dev/null
+++ b/lib/CPAN2RT/Test.pm
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+### after: use lib qw(@RT_LIB_PATH@);
+use lib qw(/opt/rt3/local/lib /opt/rt3/lib);
+
+package CPAN2RT::Test;
+
+our @ISA;
+BEGIN {
+ local $@;
+ eval { require RT::Test; 1 } or do {
+ require Test::More;
+ Test::More::BAIL_OUT(
+ "requires 3.8 to run tests. Error:\n$@\n"
+ ."You may need to set PERL5LIB=/path/to/rt/lib"
+ );
+ };
+ push @ISA, 'RT::Test';
+}
+
+sub import {
+ my $class = shift;
+ my %args = @_;
+
+ $args{'requires'} ||= [];
+ if ( $args{'testing'} ) {
+ unshift @{ $args{'requires'} }, 'CPAN2RT';
+ } else {
+ $args{'testing'} = 'CPAN2RT';
+ }
+ unshift @{ $args{'requires'} }, 'RT::Extension::MergeUsers';
+
+ $class->SUPER::import( %args );
+ $class->export_to_level(1);
+
+ require CPAN2RT;
+}
+
+1;
commit 4a5e320350da6bc48438d8703bce424b29dfe07b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Nov 11 13:38:38 2009 +0000
use new sync_versions method
diff --git a/bin/cpan2rt b/bin/cpan2rt
index b8be4cc..b800248 100755
--- a/bin/cpan2rt
+++ b/bin/cpan2rt
@@ -87,6 +87,7 @@ sub cmd_update {
$importer->sync_files( $opt{'mirror'} ) if $opt{'sync'};
$importer->sync_authors( $opt{'force'} );
$importer->sync_distributions( $opt{'force'} );
+ $importer->sync_versions( $opt{'force'} );
$importer->sync_maintainers( $opt{'force'} );
}
commit 49521cca1c19891cb88010fa7332703951da0448
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Nov 11 13:37:11 2009 +0000
improve memory usage
* file2distinfo method to convert file and filter
* two new for_...($callback) methods for stream processing
* drop all_distributions method
* flush cache
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index fe5cd8b..1a1b0c8 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -210,6 +210,16 @@ sub module2file {
sub _module2file {
my $self = shift;
+
+ my %res;
+ $self->for_mapped_distributions( sub { $res{ $_[0] } = $_[2] } );
+ return \%res;
+}
+
+sub for_mapped_distributions {
+ my $self = shift;
+ my $callback = shift;
+
my $file = '02packages.details.txt';
debug { "Parsing $file...\n" };
my $path = $self->file_path( $file );
@@ -217,38 +227,28 @@ sub _module2file {
$self->skip_header( $fh );
- my %res;
while ( my $str = <$fh> ) {
chomp $str;
my ($module, $mver, $file) = split /\s+/, $str;
unless ( $module && $file ) {
- debug { "couldn't parse '$str'\n" };
+ debug { "couldn't parse '$str' in '$file'" };
next;
}
- $res{ $module } = $file;
+ $callback->( $module, $mver, $file );
}
close $fh;
-
- return \%res;
}
-
-{ my $cache;
-sub all_distributions {
+sub for_all_distributions {
my $self = shift;
- $cache = $self->_all_distributions() unless $cache;
- return $cache;
-} }
+ my $callback = shift;
-sub _all_distributions {
- my $self = shift;
my $file = 'find-ls';
debug { "Parsing $file...\n" };
my $path = $self->file_path( $file );
open my $fh, "<:utf8", $path or die "Couldn't open '$path': $!";
- my %res;
while ( my $str = <$fh> ) {
next if $str =~ /^\d+\s+0\s+l\s+1/; # skip symbolic links
chomp $str;
@@ -259,18 +259,12 @@ sub _all_distributions {
next unless index($file, "authors/id/") == 0;
next unless $file =~ /\.(bz2|zip|tgz|tar\.gz)$/i;
- my $info = CPAN::DistnameInfo->new( $file );
- my $dist = $info->dist;
- unless ( $dist ) {
- debug { "Couldn't parse distribution name from '$file'\n" };
- next;
- }
- push @{ $res{ $dist }{'versions'} ||= [] }, $info->version;
- push @{ $res{ $dist }{'uploaders'} ||= [] }, $info->cpanid;
+ my $info = $self->file2distinfo( $file )
+ or next;
+
+ $callback->( $info );
}
close $fh;
-
- return \%res;
}
sub sync_authors {
@@ -281,11 +275,13 @@ sub sync_authors {
return (1);
}
- my @errors;
+ my ($i, @errors) = (0);
my $authors = $self->authors;
while ( my ($cpanid, $meta) = each %$authors ) {
my ($user, @msg) = $self->load_or_create_user( $cpanid, @{ $meta }{qw(fullname email)} );
push @errors, @msg unless $user;
+
+ DBIx::SearchBuilder::Record::Cachable->FlushCache unless ++$i % 100;
}
return (undef, @errors) if @errors;
return (1);
@@ -299,43 +295,71 @@ sub sync_distributions {
return (1);
}
- my @files = uniq values %{ $self->module2file };
- my $all_dists = $self->all_distributions;
+ my @errors;
- my %tmp;
- foreach my $file ( @files ) {
- my $info = CPAN::DistnameInfo->new( "authors/id/$file" );
- my $dist = $info->dist;
- unless ( $dist ) {
- debug { "Couldn't parse distribution name from '$file'\n" };
- next;
- }
- if ( $dist =~ /^(parrot|perl)$/i ) {
- debug { "Skipping $dist as it's hard coded to be skipped." };
- next;
- }
+ my $last = ''; my $i = 0;
+ my $syncer = sub {
+ my $file = $_[2];
+ return if $last eq $file;
- $tmp{ $dist } ||= [];
- if ( my $v = $info->version ) {
- push @{ $tmp{ $dist } }, $v;
- }
- push @{ $tmp{ $dist } }, @{ $all_dists->{ $dist }{'versions'} || [] };
+ $last = $file;
+
+ my $info = $self->file2distinfo( "authors/id/$file" )
+ or return;
+
+ my ($queue, @msg) = $self->load_or_create_queue( $info->dist );
+ push @errors, @msg unless $queue;
+
+ # we don't sync version here as sync_versions does this better
+
+ DBIx::SearchBuilder::Record::Cachable->FlushCache unless ++$i % 100;
+ };
+ $self->for_mapped_distributions( $syncer );
+
+ return (undef, @errors) if @errors;
+ return (1);
+}
+
+sub sync_versions {
+ my $self = shift;
+ my $force = shift;
+ if ( !$force && !$self->is_new_file( '02packages.details.txt' ) ) {
+ debug { "Skip syncing, file's not changed\n" };
+ return (1);
}
+ my $i = 0;
my @errors;
- while ( my ($dist, $versions) = each %tmp ) {
- my ($queue, @msg) = $self->load_or_create_queue( $dist );
+ my ($last_dist, @last_versions) = ('');
+ my $syncer = sub {
+ return unless $last_dist && @last_versions;
+
+ my $queue = $self->load_queue( $last_dist );
unless ( $queue ) {
- push @errors, @msg;
- next;
+ debug { "No queue for dist '$last_dist'" };
+ return;
}
- if ( $versions && @$versions ) {
- my ($status, @msg) = $self->add_versions( $queue, @$versions );
- push @errors, @msg unless $status;
+
+ my ($status, @msg) = $self->add_versions( $queue, @last_versions );
+ push @errors, @msg unless $status;
+
+ DBIx::SearchBuilder::Record::Cachable->FlushCache unless ++$i % 100;
+ };
+ my $collector = sub {
+ my $info = shift;
+
+ my $dist = $info->dist;
+ if ( $dist ne $last_dist ) {
+ $syncer->();
+ $last_dist = $dist;
+ @last_versions = ();
}
- }
- %tmp = ();
+ push @last_versions, $info->version;
+ };
+
+ $self->for_all_distributions( $collector );
+ $syncer->(); # last portion
return (undef, @errors) if @errors;
return (1);
@@ -357,14 +381,13 @@ sub sync_maintainers {
my $file = $m2f->{ $module };
next unless $file;
- my $dist = CPAN::DistnameInfo->new( "authors/id/$file" )->dist;
- unless ( $dist ) {
- debug { "Couldn't parse distribution name from '$file'\n" };
- next;
- }
- push @{ $res{ $dist } ||= [] }, @$maint;
+ my $info = $self->file2distinfo( "authors/id/$file" )
+ or next;
+
+ push @{ $res{ $info->dist } ||= [] }, @$maint;
}
+ my $i = 0;
my @errors = ();
while ( my ($dist, $maint) = each %res ) {
my ($queue, @msg) = $self->load_or_create_queue( $dist );
@@ -376,6 +399,8 @@ sub sync_maintainers {
my $status;
($status, @msg) = $self->set_maintainers( $queue, @$maint );
push @errors, @msg unless $status;
+
+ DBIx::SearchBuilder::Record::Cachable->FlushCache unless ++$i % 100;
}
%res = ();
return (undef, @errors) if @errors;
@@ -611,27 +636,36 @@ sub create_user {
return ($user)
}
-sub load_or_create_queue {
+sub load_queue {
my $self = shift;
my $dist = shift;
my $queue = RT::Queue->new( $RT::SystemUser );
- # Try to load up the current queue by name. Avoids duplication.
$queue->Load( $dist );
- unless ( $queue->id ) {
- my ($status, $msg) = $queue->Create(
- Name => $dist,
- Description => "Bugs in $dist",
- CorrespondAddress => "bug-$dist\@rt.cpan.org",
- CommentAddress => "comment-$dist\@rt.cpan.org",
- );
- unless ( $status ) {
- return (undef, "Couldn't create queue '$dist': $msg\n");
- }
- debug { "Created queue #". $queue->id ." for dist ". $queue->Name ."\n" };
- } else {
- debug { "Found queue #". $queue->id ." for dist ". $queue->Name ."\n" };
+ return undef unless $queue->id;
+
+ debug { "Found queue #". $queue->id ." for dist ". $queue->Name ."\n" };
+ return $queue;
+}
+
+sub load_or_create_queue {
+ my $self = shift;
+ my $dist = shift;
+
+ my $queue = $self->load_queue( $dist );
+ return $queue if $queue;
+
+ $queue = RT::Queue->new( $RT::SystemUser );
+ my ($status, $msg) = $queue->Create(
+ Name => $dist,
+ Description => "Bugs in $dist",
+ CorrespondAddress => "bug-$dist\@rt.cpan.org",
+ CommentAddress => "comment-$dist\@rt.cpan.org",
+ );
+ unless ( $status ) {
+ return (undef, "Couldn't create queue '$dist': $msg\n");
}
+ debug { "Created queue #". $queue->id ." for dist ". $queue->Name ."\n" };
return $queue;
}
@@ -712,6 +746,23 @@ sub parse_email_address {
return $address->address;
}
+sub file2distinfo {
+ my $self = shift;
+ my $file = shift or return undef;
+
+ my $info = CPAN::DistnameInfo->new( $file );
+ my $dist = $info->dist;
+ unless ( $dist ) {
+ debug { "Couldn't parse distribution name from '$file'\n" };
+ return undef;
+ }
+ if ( $dist =~ /^(parrot|perl)$/i ) {
+ debug { "Skipping $dist as it's hard coded to be skipped." };
+ return undef;
+ }
+ return $info;
+}
+
sub file_path {
my $self = shift;
my $file = shift;
commit 1eb2f13fc16576992ff76df93419617ed678bb65
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Nov 11 12:19:16 2009 +0000
retab
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 7b56d65..fe5cd8b 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -628,9 +628,9 @@ sub load_or_create_queue {
unless ( $status ) {
return (undef, "Couldn't create queue '$dist': $msg\n");
}
- debug { "Created queue #". $queue->id ." for dist ". $queue->Name ."\n" };
+ debug { "Created queue #". $queue->id ." for dist ". $queue->Name ."\n" };
} else {
- debug { "Found queue #". $queue->id ." for dist ". $queue->Name ."\n" };
+ debug { "Found queue #". $queue->id ." for dist ". $queue->Name ."\n" };
}
return $queue;
}
commit 106b7afe51b8aea47ade5a99c44924c92a10d11b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Sep 26 03:03:45 2008 +0000
adjust logging to screen according to command line options
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 523a584..7b56d65 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -72,11 +72,16 @@ sub init {
unshift @INC, File::Spec->catdir( $home, 'lib' );
unshift @INC, File::Spec->catdir( $home, 'local', 'lib' );
+ $DEBUG = $self->{'debug'};
+
require RT;
RT::LoadConfig();
+ if ( $DEBUG ) {
+ $RT::LogToScreen = 'debug';
+ } else {
+ $RT::LogToScreen = 'warning';
+ }
RT::Init();
-
- $DEBUG = $self->{'debug'};
}
sub sync_files {
commit fcb4d74daea49df1bd2e2b26dfa40d3d212c12a6
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Sep 26 03:00:47 2008 +0000
filter versions earlier to avoid warnings
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index e4f5e0b..523a584 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -493,7 +493,7 @@ sub del_maintainer {
sub add_versions {
my $self = shift;
my ($queue, @versions) = @_;
- @versions = uniq @versions;
+ @versions = uniq grep defined && length, @versions;
my @errors;
foreach my $name ( "Broken in", "Fixed in" ) {
@@ -505,7 +505,7 @@ sub add_versions {
# Unless it's a new value, don't add it
my %old = map { $_->Name => 1 } @{ $cf->Values->ItemsArrayRef };
- foreach my $version ( grep defined && length, @versions ) {
+ foreach my $version ( @versions ) {
if ( exists $old{$version} ) {
debug { "Version '$version' exists (not adding)\n" };
next;
commit 4e4286ea35a62354d746073eb31d80aa85a2c6d8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Jul 3 07:35:34 2008 +0000
use several attempts to fetch a file as mirror we use
by default may crash with 500 error
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 8d24379..e4f5e0b 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -92,37 +92,51 @@ sub sync_files {
modules/02packages.details.txt.gz
);
+ foreach my $file ( @files ) {
+ $self->fetch_file( $mirror, $file );
+ }
+}
+
+sub fetch_file {
+ my $self = shift;
+ my $mirror = shift;
+ my $file = shift;
+ my $tries = shift || 3;
+
require LWP::UserAgent;
my $ua = new LWP::UserAgent;
$ua->timeout( 10 );
- foreach my $file ( @files ) {
- debug { "Fetching '$file'\n" };
- my $store = $self->file_path( $file );
- $self->backup_file( $store ) if -e $store;
- my $response = $ua->get( "$mirror/$file", ':content_file' => $store );
- unless ( $response->is_success ) {
- print STDERR $response->status_line, "\n";
- next;
- }
- my $mtime = $response->header('Last-Modified');
+ my $store = $self->file_path( $file );
+ $self->backup_file( $store );
+ my $url = "$mirror/$file";
- debug { "Fetched '$file' -> '$store'\n" };
+ debug { "Fetching '$file' from '$url'\n" };
+ my $response = $ua->get( $url, ':content_file' => $store );
+ unless ( $response->is_success ) {
+ print STDERR "Request to '$url' failed. Server response:\n". $response->status_line ."\n";
+ return $self->fetch_file( $mirror, $file, $tries) if --$tries;
- if ( $store =~ /(.*)\.gz$/ ) {
- $self->backup_file( $1 );
- `gunzip -f $store`;
- $store =~ s/\.gz$//;
- debug { "Unzipped '$store'\n" };
- }
+ print STDERR "Failed several attempts to fetch '$url'\n";
+ return undef;
+ }
+ debug { "Fetched '$file' -> '$store'\n" };
- if ( $mtime ) {
- require HTTP::Date;
- $mtime = HTTP::Date::str2time( $mtime );
- utime $mtime, $mtime, $store if $mtime;
- debug { "Last modified: $mtime\n" };
- }
+ if ( $store =~ /(.*)\.gz$/ ) {
+ $self->backup_file( $1 );
+ `gunzip -f $store`;
+ $store =~ s/\.gz$//;
+ debug { "Unzipped '$store'\n" };
+ }
+
+ my $mtime = $response->header('Last-Modified');
+ if ( $mtime ) {
+ require HTTP::Date;
+ $mtime = HTTP::Date::str2time( $mtime );
+ utime $mtime, $mtime, $store if $mtime;
+ debug { "Last modified: $mtime\n" };
}
+ return 1;
}
{ my $cache;
@@ -717,7 +731,7 @@ sub backup_file {
my $self = shift;
my $old = shift;
my $new = $old .'.old';
- rename $old, $new;
+ rename $old, $new if -e $old;
}
sub skip_header {
commit 048916411af890ee7ee5140bbc7ee5f2b2aa6bc1
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jul 2 19:21:50 2008 +0000
bump version
diff --git a/META.yml b/META.yml
index 00c1e62..2771b01 100644
--- a/META.yml
+++ b/META.yml
@@ -22,4 +22,4 @@ requires:
List::MoreUtils: 0
XML::SAX: 0
perl: 5.8.3
-version: 0.02
+version: 0.03
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 99458af..8d24379 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -18,7 +18,7 @@ use v5.8.3;
use strict;
use warnings;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
use Email::Address;
use List::Compare;
commit 194bbe847cd2ed6c158667014571cad10939566c
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jul 2 19:16:26 2008 +0000
adjust dependencies
diff --git a/META.yml b/META.yml
index 68c2c7e..00c1e62 100644
--- a/META.yml
+++ b/META.yml
@@ -13,12 +13,13 @@ no_index:
directory:
- inc
requires:
- CPAN::DistnameInfo: 0
+ CPAN::DistnameInfo: 0.07
Email::Address: 0
File::Spec: 0
HTTP::Date: 0
LWP::UserAgent: 0
List::Compare: 0
List::MoreUtils: 0
+ XML::SAX: 0
perl: 5.8.3
version: 0.02
diff --git a/Makefile.PL b/Makefile.PL
index 4b077d3..5efe4f2 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -10,10 +10,11 @@ install_script 'bin/cpan2rt';
requires 'Email::Address';
requires 'List::Compare';
requires 'List::MoreUtils';
-requires 'CPAN::DistnameInfo';
+requires 'CPAN::DistnameInfo' => '0.07'; # for .tar.bz2
requires 'LWP::UserAgent';
requires 'HTTP::Date';
requires 'File::Spec';
+requires 'XML::SAX';
auto_install();
WriteAll();
commit a58be5cbb534734ffe7eb6bbb45e12d91560f67d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jul 2 19:12:49 2008 +0000
switch from 01mailrc.txt.gz to 00whois.xml
** use XML::SAX parser to minimize memory impact
** filter maintainers by type, set only users with
type 'author' as maintainers and skip lists
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 0d9b071..99458af 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -87,7 +87,7 @@ sub sync_files {
my @files = qw(
indices/find-ls.gz
- authors/01mailrc.txt.gz
+ authors/00whois.xml
modules/06perms.txt.gz
modules/02packages.details.txt.gz
);
@@ -134,26 +134,19 @@ sub authors {
sub _authors {
my $self = shift;
- my $file = '01mailrc.txt';
+ my $file = '00whois.xml';
debug { "Parsing $file...\n" };
my $path = $self->file_path( $file );
- open my $fh, "<:utf8", $path or die "Couldn't open '$path': $!";
- my %res;
- while ( my $str = <$fh> ) {
- chomp $str;
- my ($cpanid, $real_name, $email) = ($str =~ m{^alias\s+([A-Z0-9]+)\s+"([^<>]*?)\s*<([^>]+)>"$});
- unless ( $cpanid ) {
- debug { "couldn't parse '$str'\n" };
- next;
- }
- $res{ $cpanid } = {
- real_name => $real_name,
- email_address => $self->parse_email_address($email) || $cpanid .'@cpan.org',
- };
- }
+ use XML::SAX::ParserFactory;
+ my $handler = CPAN2RT::UsersSAXParser->new();
+ my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
+
+ open my $fh, "<:raw", $path or die "Couldn't open '$path': $!";
+ my $res = $p->parse_file( $fh );
close $fh;
- return \%res;
+
+ return $res;
}
{ my $cache;
@@ -272,7 +265,7 @@ sub sync_authors {
my @errors;
my $authors = $self->authors;
while ( my ($cpanid, $meta) = each %$authors ) {
- my ($user, @msg) = $self->load_or_create_user( $cpanid, @{ $meta }{qw(real_name email_address)} );
+ my ($user, @msg) = $self->load_or_create_user( $cpanid, @{ $meta }{qw(fullname email)} );
push @errors, @msg unless $user;
}
return (undef, @errors) if @errors;
@@ -379,10 +372,17 @@ sub current_maintainers {
return map uc $_->Name, @{ $users->ItemsArrayRef };
}
+sub filter_maintainers {
+ my $self = shift;
+ my $authors = $self->authors;
+ return grep { ($authors->{$_}{'type'}||'') eq 'author' } @_;
+}
+
sub set_maintainers {
my $self = shift;
my $queue = shift;
- my @maints = @_;
+
+ my @maints = $self->filter_maintainers( @_ );
my @current = $self->current_maintainers( $queue );
my @errors;
@@ -476,7 +476,6 @@ sub del_maintainer {
return (1);
}
-
sub add_versions {
my $self = shift;
my ($queue, @versions) = @_;
@@ -735,3 +734,52 @@ sub debug(&) {
}
1;
+
+package CPAN2RT::UsersSAXParser;
+use base qw(XML::SAX::Base);
+
+sub start_document {
+ my ($self, $doc) = @_;
+ $self->{'res'} = {};
+}
+
+sub start_element {
+ my ($self, $el) = @_;
+ my $name = $el->{LocalName};
+ return if $name ne 'cpanid' && !$self->{inside};
+
+ if ( $name eq 'cpanid' ) {
+ $self->{inside} = 1;
+ $self->{tmp} = [];
+ return;
+ } else {
+ $self->{inside_prop} = 1;
+ }
+
+ push @{ $self->{'tmp'} }, $name, '';
+}
+
+sub characters {
+ my ($self, $el) = @_;
+ $self->{'tmp'}[-1] .= $el->{Data} if $self->{inside_prop};
+}
+
+sub end_element {
+ my ($self, $el) = @_;
+ $self->{inside_prop} = 0;
+
+ my $name = $el->{LocalName};
+
+ if ( $name eq 'cpanid' ) {
+ $self->{inside} = 0;
+ my %rec = map Encode::decode_utf8($_), @{ delete $self->{'tmp'} };
+ $self->{'res'}{ delete $rec{'id'} } = \%rec;
+ }
+}
+
+sub end_document {
+ my ($self) = @_;
+ return $self->{'res'};
+}
+
+1;
commit 06ceca7189f4401f8afbe68253c1016369438cf8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jun 30 12:46:02 2008 +0000
use find-ls index to get more versions of distributions
available from the mirror
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index c28f8ad..0d9b071 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -288,6 +288,7 @@ sub sync_distributions {
}
my @files = uniq values %{ $self->module2file };
+ my $all_dists = $self->all_distributions;
my %tmp;
foreach my $file ( @files ) {
@@ -306,6 +307,7 @@ sub sync_distributions {
if ( my $v = $info->version ) {
push @{ $tmp{ $dist } }, $v;
}
+ push @{ $tmp{ $dist } }, @{ $all_dists->{ $dist }{'versions'} || [] };
}
my @errors;
@@ -478,6 +480,7 @@ sub del_maintainer {
sub add_versions {
my $self = shift;
my ($queue, @versions) = @_;
+ @versions = uniq @versions;
my @errors;
foreach my $name ( "Broken in", "Fixed in" ) {
commit 43c7db7b23f02483da4c5ac5bedb30dbc317645d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jun 30 12:44:56 2008 +0000
adjust debug output
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 5d9628e..c28f8ad 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -178,7 +178,7 @@ sub _permissions {
my ($module, $cpanid, $permission) = (split /\s*,\s*/, $str);
unless ( $module && $cpanid ) {
- debug { "couldn't parse '$str'\n" };
+ debug { "couldn't parse '$str' from '$file'\n" };
next;
}
$res{ $module } ||= [];
@@ -387,10 +387,12 @@ sub set_maintainers {
my $set = List::Compare->new( '--unsorted', \@current, \@maints );
foreach ( $set->get_unique ) {
+ debug { "Going to delete $_ from maintainers of ". $queue->Name };
my ($status, @msg) = $self->del_maintainer( $queue, $_, 'force' );
push @errors, @msg unless $status;
}
foreach ( $set->get_complement ) {
+ debug { "Going to add $_ as maintainer of ". $queue->Name };
my ($status, @msg) = $self->add_maintainer( $queue, $_, 'force' );
push @errors, @msg unless $status;
}
@@ -418,7 +420,7 @@ sub add_maintainer {
}
if ( !$force && $queue->IsAdminCc( $user->PrincipalId ) ) {
- debug { $user->Name ." is allready maintainer of '". $queue->Name ."'\n" };
+ debug { $user->Name ." is already maintainer of '". $queue->Name ."'\n" };
return (1);
}
@@ -467,7 +469,7 @@ sub del_maintainer {
." from AdminCc list of '". $queue->Name ."': $msg\n";
return (undef, $msg);
} else {
- debug { "Delete ". $user->Name ." from maintainers of '". $queue->Name ."'\n" };
+ debug { "Deleted ". $user->Name ." from maintainers of '". $queue->Name ."'\n" };
}
return (1);
}
@@ -554,7 +556,9 @@ sub load_or_create_user {
debug { "Merging user @{[$new->Name]} into @{[$byemail->Name]}...\n" };
$new->MergeInto( $byemail );
} else {
- debug { "WARNING: Couldn't merge users. Extension is not installed.\n" };
+ debug {
+ "WARNING: Couldn't merge user @{[$new->Name]} into @{[$byemail->Name]}."
+ ." Extension is not installed.\n" };
}
return ($new);
}
@@ -603,9 +607,9 @@ sub load_or_create_queue {
unless ( $status ) {
return (undef, "Couldn't create queue '$dist': $msg\n");
}
- debug { "Created queue for dist ". $queue->Name ." #". $queue->id ."\n" };
+ debug { "Created queue #". $queue->id ." for dist ". $queue->Name ."\n" };
} else {
- debug { "Found queue for dist ". $queue->Name ." #". $queue->id ."\n" };
+ debug { "Found queue #". $queue->id ." for dist ". $queue->Name ."\n" };
}
return $queue;
}
commit 62a38016cbce63287ff47de0a6a85bb931c7912a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jun 30 12:43:58 2008 +0000
add parsing of find-ls index file
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 6e0025e..5d9628e 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -86,6 +86,7 @@ sub sync_files {
debug { "Syncing files from '$mirror'\n" };
my @files = qw(
+ indices/find-ls.gz
authors/01mailrc.txt.gz
modules/06perms.txt.gz
modules/02packages.details.txt.gz
@@ -220,6 +221,46 @@ sub _module2file {
return \%res;
}
+
+{ my $cache;
+sub all_distributions {
+ my $self = shift;
+ $cache = $self->_all_distributions() unless $cache;
+ return $cache;
+} }
+
+sub _all_distributions {
+ my $self = shift;
+ my $file = 'find-ls';
+ debug { "Parsing $file...\n" };
+ my $path = $self->file_path( $file );
+ open my $fh, "<:utf8", $path or die "Couldn't open '$path': $!";
+
+ my %res;
+ while ( my $str = <$fh> ) {
+ next if $str =~ /^\d+\s+0\s+l\s+1/; # skip symbolic links
+ chomp $str;
+
+ my ($mode, $file) = (split /\s+/, $str)[2, -1];
+ next if index($mode, 'x') >= 0; # skip executables (dirs)
+ # we're only interested in files in authors/id/ dir
+ next unless index($file, "authors/id/") == 0;
+ next unless $file =~ /\.(bz2|zip|tgz|tar\.gz)$/i;
+
+ my $info = CPAN::DistnameInfo->new( $file );
+ my $dist = $info->dist;
+ unless ( $dist ) {
+ debug { "Couldn't parse distribution name from '$file'\n" };
+ next;
+ }
+ push @{ $res{ $dist }{'versions'} ||= [] }, $info->version;
+ push @{ $res{ $dist }{'uploaders'} ||= [] }, $info->cpanid;
+ }
+ close $fh;
+
+ return \%res;
+}
+
sub sync_authors {
my $self = shift;
my $force = shift;
commit fb08b97c65071921896eb9196cfbb362d9a54e9b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Jun 30 12:42:31 2008 +0000
pod update
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index 38c2b2b..6e0025e 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -28,6 +28,28 @@ use List::MoreUtils qw(uniq);
our $DEBUG = 0;
sub debug(&);
+=head1 METHODS
+
+=head2 new
+
+Simple constructor that creates a hash based object and stores all
+passed arguments inside it. Then L</init> is called.
+
+=head3 options
+
+=over 8
+
+=item home - RT home dir, RTHOME is checked if empty and defaults to
+"/opt/rt3".
+
+=item debug - turn on ddebug output to STDERR.
+
+=item mirror - CPAN mirror to fetch files from.
+
+=back
+
+=cut
+
sub new {
my $proto = shift;
my $self = bless { @_ }, ref($proto) || $proto;
@@ -35,6 +57,14 @@ sub new {
return $self;
}
+=head2 init
+
+Called right after constructor, changes @INC, loads RT and initilize it.
+
+See options in description of L</new>.
+
+=cut
+
sub init {
my $self = shift;
commit d8a2694d84773f5c696f22443e70f9c2290bf8ce
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jun 4 21:48:52 2008 +0000
really bump version
diff --git a/META.yml b/META.yml
index ba46601..68c2c7e 100644
--- a/META.yml
+++ b/META.yml
@@ -1,5 +1,5 @@
---
-abstract: ~
+abstract: 'CPAN to RT converter for rt.cpan.org service'
author:
- 'Ruslan Zakirov <ruz at bestpractical.com>'
distribution_type: module
@@ -21,4 +21,4 @@ requires:
List::Compare: 0
List::MoreUtils: 0
perl: 5.8.3
-version: 0.01
+version: 0.02
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
index f48bb42..38c2b2b 100644
--- a/lib/CPAN2RT.pm
+++ b/lib/CPAN2RT.pm
@@ -1,10 +1,24 @@
package CPAN2RT;
+=head1 NAME
+
+CPAN2RT - CPAN to RT converter for rt.cpan.org service
+
+=head1 DESCRIPTION
+
+An utility and module with functions to import and update metadata
+about CPAN distributions into RT DB using files available from each
+CPAN mirror.
+
+Comes with `cpan2rt` script.
+
+=cut
+
use v5.8.3;
use strict;
use warnings;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use Email::Address;
use List::Compare;
commit 4ab7a531ac667236788fb4ff5401718afc990cdf
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jun 4 21:46:50 2008 +0000
bump version to 0.02
* prepare for intitial release to CPAN
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..994ac61
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,17 @@
+bin/cpan2rt
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/CPAN2RT.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
commit 009bf3045d1bac13446279f6890f0f494f69d7a4
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jun 4 21:33:04 2008 +0000
update M::I
diff --git a/META.yml b/META.yml
index b2dcc64..ba46601 100644
--- a/META.yml
+++ b/META.yml
@@ -1,19 +1,18 @@
----
+---
abstract: ~
-author:
- - Ruslan Zakirov <ruz at bestpractical.com>
+author:
+ - 'Ruslan Zakirov <ruz at bestpractical.com>'
distribution_type: module
-generated_by: Module::Install version 0.68
+generated_by: 'Module::Install version 0.75'
license: perl
-meta-spec:
+meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
name: CPAN2RT
-no_index:
- directory:
+no_index:
+ directory:
- inc
- - t
-requires:
+requires:
CPAN::DistnameInfo: 0
Email::Address: 0
File::Spec: 0
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 89a8653..8fb6b20 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -17,20 +17,30 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-use 5.004;
+BEGIN {
+ require 5.004;
+}
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- # All Module::Install core packages now require synchronised versions.
- # This will be used to ensure we don't accidentally load old or
- # different versions of modules.
- # This is not enforced yet, but will be some time in the next few
- # releases once we can make sure it won't clash with custom
- # Module::Install extensions.
- $VERSION = '0.68';
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '0.75';
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
}
+
+
+
+
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
@@ -38,26 +48,29 @@ BEGIN {
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) {
- die <<"END_DIE";
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
Please invoke ${\__PACKAGE__} with:
- use inc::${\__PACKAGE__};
+ use inc::${\__PACKAGE__};
not:
- use ${\__PACKAGE__};
+ use ${\__PACKAGE__};
END_DIE
-}
+
+
+
+
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
-if ( -f $0 and (stat($0))[9] > time ) {
- die << "END_DIE";
+if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
Your installer $0 has a modification time in the future.
This is known to create infinite loops in make.
@@ -65,115 +78,142 @@ This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
-}
+
+
+
+
+
+# Build.PL was formerly supported, but no longer is due to excessive
+# difficulty in implementing every single feature twice.
+if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+
+Module::Install no longer supports Build.PL.
+
+It was impossible to maintain duel backends, and has been deprecated.
+
+Please remove all Build.PL files and only use the Makefile.PL installer.
+
+END_DIE
+
+
+
+
+
+# To save some more typing in Module::Install installers, every...
+# use inc::Module::Install
+# ...also acts as an implicit use strict.
+$^H |= strict::bits(qw(refs subs vars));
+
+
+
+
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
-*inc::Module::Install::VERSION = *VERSION;
- at inc::Module::Install::ISA = __PACKAGE__;
-
sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ($self, $1);
- goto &{$self->can('call')} unless uc($1) eq $1;
- };
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
}
sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+
+ return 1;
}
sub preload {
- my ($self) = @_;
-
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
- }
-
- my %seen;
- foreach my $obj ( @exts ) {
- while (my ($method, $glob) = each %{ref($obj) . '::'}) {
- next unless $obj->can($method);
- next if $method =~ /^_/;
- next if $method eq uc($method);
- $seen{$method}++;
- }
- }
-
- my $who = $self->_caller;
- foreach my $name ( sort keys %seen ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
}
sub new {
- my ($class, %args) = @_;
-
- # ignore the prefix on extension modules built from top level.
- my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
- delete $args{prefix};
- }
-
- return $args{_self} if $args{_self};
-
- $args{dispatch} ||= 'Admin';
- $args{prefix} ||= 'inc';
- $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
- $args{bundle} ||= 'inc/BUNDLES';
- $args{base} ||= $base_path;
- $class =~ s/^\Q$args{prefix}\E:://;
- $args{name} ||= $class;
- $args{version} ||= $class->VERSION;
- unless ( $args{path} ) {
- $args{path} = $args{name};
- $args{path} =~ s!::!/!g;
- }
- $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
-
- bless( \%args, $class );
+ my ($class, %args) = @_;
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+ $args{wrote} = 0;
+
+ bless( \%args, $class );
}
sub call {
@@ -184,98 +224,130 @@ sub call {
}
sub load {
- my ($self, $method) = @_;
+ my ($self, $method) = @_;
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
- my $admin = $self->{admin} or die <<"END_DIE";
+ my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
- my $obj = $admin->load($method, 1);
- push @{$self->{extensions}}, $obj;
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
- $obj;
+ $obj;
}
sub load_extensions {
- my ($self, $path, $top) = @_;
-
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
-
- $self->{extensions} ||= [];
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
}
sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( sub {
- my $file = $File::Find::name;
- return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
- my $subpath = $1;
- return if lc($subpath) eq lc($self->{dispatch});
-
- $file = "$self->{path}/$subpath.pm";
- my $pkg = "$self->{name}::$subpath";
- $pkg =~ s!/!::!g;
-
- # If we have a mixed-case package name, assume case has been preserved
- # correctly. Otherwise, root through the file to locate the case-preserved
- # version of the package name.
- if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
- my $in_pod = 0;
- while ( <PKGFILE> ) {
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/); # skip pod text
- next if /^\s*#/; # and comments
- if ( m/^\s*package\s+($pkg)\s*;/i ) {
- $pkg = $1;
- last;
- }
- }
- close PKGFILE;
- }
-
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
-
- @found;
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ my $content = Module::Install::_read($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $content ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
}
+
+
+
+
+#####################################################################
+# Utility Functions
+
sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+sub _read {
+ local *FH;
+ open FH, "< $_[0]" or die "open($_[0]): $!";
+ my $str = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $str;
+}
+
+sub _write {
+ local *FH;
+ open FH, "> $_[0]" or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
+ close FH or die "close($_[0]): $!";
+}
+
+sub _version {
+ my $s = shift || 0;
+ $s =~ s/^(\d+)\.?//;
+ my $l = $1 || 0;
+ my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
+ return $l + 0;
}
1;
+
+# Copyright 2008 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index 3a490fb..3055ec1 100644
--- a/inc/Module/Install/AutoInstall.pm
+++ b/inc/Module/Install/AutoInstall.pm
@@ -6,7 +6,7 @@ use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.75';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 49dfde6..bd12f2b 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.68';
+$VERSION = '0.75';
# Suspend handler for "redefined" warnings
BEGIN {
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index ec66fdb..3f436c7 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -11,7 +11,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.75';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index e0dd6db..1327f35 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -6,7 +6,7 @@ use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.75';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 001d0c6..d0fd7f8 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.75';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 17bd8a7..b7c2ba9 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -7,7 +7,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.75';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -37,7 +37,7 @@ sub prompt {
sub makemaker_args {
my $self = shift;
my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
+ %$args = ( %$args, @_ ) if @_;
$args;
}
@@ -63,18 +63,18 @@ sub build_subdirs {
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
+ %$clean = (
%$clean,
- FILES => join(' ', grep length, $clean->{FILES}, @_),
+ FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
- my $self = shift;
+ my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
+ %$realclean = (
%$realclean,
- FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
@@ -104,8 +104,8 @@ sub tests_recursive {
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- require File::Find;
%test_dir = ();
+ require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -114,10 +114,15 @@ sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
+ # Make sure we have a new enough
+ require ExtUtils::MakeMaker;
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION );
+
+ # Generate the
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
- $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
@@ -142,9 +147,12 @@ sub write {
map { @$_ }
map { @$_ }
grep $_,
- ($self->build_requires, $self->requires)
+ ($self->configure_requires, $self->build_requires, $self->requires)
);
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
@@ -205,7 +213,7 @@ sub fix_up_makefile {
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
+ $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
@@ -234,4 +242,4 @@ sub postamble {
__END__
-#line 363
+#line 371
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index f77d68a..ce26bf6 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,18 +6,31 @@ use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.75';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my @scalar_keys = qw{
- name module_name abstract author version license
- distribution_type perl_version tests installdirs
+ name
+ module_name
+ abstract
+ author
+ version
+ license
+ distribution_type
+ perl_version
+ tests
+ installdirs
};
my @tuple_keys = qw{
- build_requires requires recommends bundles
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
};
sub Meta { shift }
@@ -25,44 +38,85 @@ sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
foreach my $key (@scalar_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
- return $self;
- };
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
}
-foreach my $key (@tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} unless @_;
-
- my @rv;
- while (@_) {
- my $module = shift or last;
- my $version = shift || 0;
- if ( $module eq 'perl' ) {
- $version =~ s{^(\d+)\.(\d+)\.(\d+)}
- {$1 + $2/1_000 + $3/1_000_000}e;
- $self->perl_version($version);
- next;
- }
- my $rv = [ $module, $version ];
- push @rv, $rv;
- }
- push @{ $self->{values}{$key} }, @rv;
- @rv;
- };
+sub requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{requires} }, [ $module, $version ];
+ }
+ $self->{values}{requires};
}
-# configure_requires is currently a null-op
-sub configure_requires { 1 }
+sub build_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{build_requires} }, [ $module, $version ];
+ }
+ $self->{values}{build_requires};
+}
+
+sub configure_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
+ }
+ $self->{values}->{configure_requires};
+}
+
+sub recommends {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{recommends} }, [ $module, $version ];
+ }
+ $self->{values}->{recommends};
+}
+
+sub bundles {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{bundles} }, [ $module, $version ];
+ }
+ $self->{values}->{bundles};
+}
+
+# Resource handling
+sub resources {
+ my $self = shift;
+ while ( @_ ) {
+ my $resource = shift or last;
+ my $value = shift or next;
+ push @{ $self->{values}->{resources} }, [ $resource, $value ];
+ }
+ $self->{values}->{resources};
+}
+
+sub repository {
+ my $self = shift;
+ $self->resources( repository => shift );
+ return 1;
+}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
-sub test_requires { shift->build_requires(@_) }
-sub install_requires { shift->build_requires(@_) }
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
@@ -71,10 +125,10 @@ sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
- my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and ! @_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
- return $self;
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and ! @_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
}
sub dynamic_config {
@@ -83,254 +137,271 @@ sub dynamic_config {
warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
return $self;
}
- $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
+ $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
return $self;
}
sub all_from {
- my ( $self, $file ) = @_;
-
- unless ( defined($file) ) {
- my $name = $self->name
- or die "all_from called with no args without setting name() first";
- $file = join('/', 'lib', split(/-/, $name)) . '.pm';
- $file =~ s{.*/}{} unless -e $file;
- die "all_from: cannot find $file from $name" unless -e $file;
- }
-
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
-
- # The remaining probes read from POD sections; if the file
- # has an accompanying .pod, use that instead
- my $pod = $file;
- if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
- $file = $pod;
- }
-
- $self->author_from($file) unless $self->author;
- $self->license_from($file) unless $self->license;
- $self->abstract_from($file) unless $self->abstract;
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name
+ or die "all_from called with no args without setting name() first";
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ # Some methods pull from POD instead of code.
+ # If there is a matching .pod, use that instead
+ my $pod = $file;
+ $pod =~ s/\.pm$/.pod/i;
+ $pod = $file unless -e $pod;
+
+ # Pull the different values
+ $self->name_from($file) unless $self->name;
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+ $self->author_from($pod) unless $self->author;
+ $self->license_from($pod) unless $self->license;
+ $self->abstract_from($pod) unless $self->abstract;
+
+ return 1;
}
sub provides {
- my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
}
sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
-
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
-
- # Avoid spurious warnings as we are not checking manifest here.
-
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
-
- require Module::Build;
- my $build = Module::Build->new(
- dist_name => $self->name,
- dist_version => $self->version,
- license => $self->license,
- );
- $self->provides(%{ $build->find_dist_packages || {} });
+ my $self = shift;
+ return $self unless $self->is_admin;
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+ # Avoid spurious warnings as we are not checking manifest here.
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
- my $self = shift;
- my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
-
- my $mods;
-
- if ( @_ == 1 and ref( $_[0] ) ) {
- # The user used ->feature like ->features by passing in the second
- # argument as a reference. Accomodate for that.
- $mods = $_[0];
- } else {
- $mods = \@_;
- }
-
- my $count = 0;
- push @$features, (
- $name => [
- map {
- ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
- : @$_
- : $_
- } @$mods
- ]
- );
-
- return @$features;
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
}
sub features {
- my $self = shift;
- while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
- $self->feature( $name, @$mods );
- }
- return $self->{values}->{features}
- ? @{ $self->{values}->{features} }
- : ();
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
}
sub no_index {
- my $self = shift;
- my $type = shift;
- push @{ $self->{values}{no_index}{$type} }, @_ if $type;
- return $self->{values}{no_index};
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
}
sub read {
- my $self = shift;
- $self->include_deps( 'YAML', 0 );
-
- require YAML;
- my $data = YAML::LoadFile('META.yml');
-
- # Call methods explicitly in case user has already set some values.
- while ( my ( $key, $value ) = each %$data ) {
- next unless $self->can($key);
- if ( ref $value eq 'HASH' ) {
- while ( my ( $module, $version ) = each %$value ) {
- $self->can($key)->($self, $module => $version );
- }
- }
- else {
- $self->can($key)->($self, $value);
- }
- }
- return $self;
+ my $self = shift;
+ $self->include_deps( 'YAML::Tiny', 0 );
+
+ require YAML::Tiny;
+ my $data = YAML::Tiny::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ } else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
}
sub write {
- my $self = shift;
- return $self unless $self->is_admin;
- $self->admin->write_meta;
- return $self;
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
}
sub version_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
}
-sub _slurp {
- my ( $self, $file ) = @_;
-
- local *FH;
- open FH, "< $file" or die "Cannot open $file.pod: $!";
- do { local $/; <FH> };
+# Add both distribution and module name
+sub name_from {
+ my ($self, $file) = @_;
+ if (
+ Module::Install::_read($file) =~ m/
+ ^ \s*
+ package \s*
+ ([\w:]+)
+ \s* ;
+ /ixms
+ ) {
+ my ($name, $module_name) = ($1, $1);
+ $name =~ s{::}{-}g;
+ $self->name($name);
+ unless ( $self->module_name ) {
+ $self->module_name($module_name);
+ }
+ } else {
+ die "Cannot determine name from $file\n";
+ }
}
sub perl_version_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- ^
- use \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- )
- {
- my $v = $1;
- $v =~ s{_}{}g;
- $self->perl_version($1);
- }
- else {
- warn "Cannot determine perl version info from $file\n";
- return;
- }
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
}
sub author_from {
- my ( $self, $file ) = @_;
- my $content = $self->_slurp($file);
- if ($content =~ m/
- =head \d \s+ (?:authors?)\b \s*
- ([^\n]*)
- |
- =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
- .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
- ([^\n]*)
- /ixms) {
- my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- }
- else {
- warn "Cannot determine author info from $file\n";
- }
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
}
sub license_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms
- )
- {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser public license' => 'gpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms ) {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
+ }
+ $self->license($license);
+ return 1;
+ }
}
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $file\n";
- return 'unknown';
+ }
+
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+}
+
+sub install_script {
+ my $self = shift;
+ my $args = $self->makemaker_args;
+ my $exe = $args->{EXE_FILES} ||= [];
+ foreach ( @_ ) {
+ if ( -f $_ ) {
+ push @$exe, $_;
+ } elsif ( -d 'script' and -f "script/$_" ) {
+ push @$exe, "script/$_";
+ } else {
+ die "Cannot find script '$_'";
+ }
+ }
}
1;
diff --git a/inc/Module/Install/Scripts.pm b/inc/Module/Install/Scripts.pm
deleted file mode 100644
index 544cdb8..0000000
--- a/inc/Module/Install/Scripts.pm
+++ /dev/null
@@ -1,50 +0,0 @@
-#line 1
-package Module::Install::Scripts;
-
-use strict;
-use Module::Install::Base;
-use File::Basename ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub prompt_script {
- my ($self, $script_file) = @_;
-
- my ($prompt, $abstract, $default);
- foreach my $line ( $self->_read_script($script_file) ) {
- last unless $line =~ /^#/;
- $prompt = $1 if $line =~ /^#\s*prompt:\s+(.*)/;
- $default = $1 if $line =~ /^#\s*default:\s+(.*)/;
- $abstract = $1 if $line =~ /^#\s*abstract:\s+(.*)/;
- }
- unless (defined $prompt) {
- my $script_name = File::Basename::basename($script_file);
- $prompt = "Do you want to install '$script_name'";
- $prompt .= " ($abstract)" if defined $abstract;
- $prompt .= '?';
- }
- return unless $self->prompt($prompt, ($default || 'n')) =~ /^[Yy]/;
- $self->install_script($script_file);
-}
-
-sub install_script {
- my $self = shift;
- my $args = $self->makemaker_args;
- my $exe_files = $args->{EXE_FILES} ||= [];
- push @$exe_files, @_;
-}
-
-sub _read_script {
- my ($self, $script_file) = @_;
- local *SCRIPT;
- open SCRIPT, $script_file
- or die "Can't open '$script_file' for input: $!\n";
- return <SCRIPT>;
-}
-
-1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 4f808c7..c97701b 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -4,11 +4,11 @@ package Module::Install::Win32;
use strict;
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.75';
@ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
@@ -16,7 +16,7 @@ sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
-
+
require Config;
return unless (
$^O eq 'MSWin32' and
@@ -38,8 +38,7 @@ sub check_nmake {
remove => 1,
);
- if (!$rv) {
- die <<'END_MESSAGE';
+ die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
@@ -59,7 +58,7 @@ You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
- }
+
}
1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 078797c..e80deb8 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -4,40 +4,37 @@ package Module::Install::WriteAll;
use strict;
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.75';
@ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
}
sub WriteAll {
- my $self = shift;
- my %args = (
- meta => 1,
- sign => 0,
- inline => 0,
- check_nmake => 1,
- @_
- );
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
- $self->sign(1) if $args{sign};
- $self->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
- if ( $0 =~ /Build.PL$/i ) {
- $self->Build->write;
- } else {
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{'PL_FILES'} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
- if ($args{inline}) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
- }
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
}
1;
commit 3191cd9a824a65c57913fbd5296915f0a0317694
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jun 4 21:24:45 2008 +0000
initial import
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..b2dcc64
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,25 @@
+---
+abstract: ~
+author:
+ - Ruslan Zakirov <ruz at bestpractical.com>
+distribution_type: module
+generated_by: Module::Install version 0.68
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+name: CPAN2RT
+no_index:
+ directory:
+ - inc
+ - t
+requires:
+ CPAN::DistnameInfo: 0
+ Email::Address: 0
+ File::Spec: 0
+ HTTP::Date: 0
+ LWP::UserAgent: 0
+ List::Compare: 0
+ List::MoreUtils: 0
+ perl: 5.8.3
+version: 0.01
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..4b077d3
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,19 @@
+use inc::Module::Install;
+
+name 'CPAN2RT';
+author 'Ruslan Zakirov <ruz at bestpractical.com>';
+license 'perl';
+all_from 'lib/CPAN2RT.pm';
+
+install_script 'bin/cpan2rt';
+
+requires 'Email::Address';
+requires 'List::Compare';
+requires 'List::MoreUtils';
+requires 'CPAN::DistnameInfo';
+requires 'LWP::UserAgent';
+requires 'HTTP::Date';
+requires 'File::Spec';
+
+auto_install();
+WriteAll();
diff --git a/README b/README
new file mode 100644
index 0000000..deff363
--- /dev/null
+++ b/README
@@ -0,0 +1,2 @@
+Toools to import data about CPAN distributions into RT DB
+using files available from each CPAN mirror.
diff --git a/bin/cpan2rt b/bin/cpan2rt
new file mode 100755
index 0000000..b8be4cc
--- /dev/null
+++ b/bin/cpan2rt
@@ -0,0 +1,103 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+cpan2rt - tool for importing CPAN meatdata into RT
+
+=head1 USAGE
+
+ cpan2rt command [options]
+
+ # update
+ cpan2rt update
+ cpan2rt update --nosync --force --debug --home /opt/rt3 --datadir /var/lib/cpan2rt
+
+=head1 LIST OF COMMANDS
+
+=over 4
+
+=item L</update> - does full sync of data from a CPAN mirror into RT.
+
+=back
+
+=head1 GENERAL OPTIONS
+
+=over 4
+
+=item --home - RT home
+
+=item --datadir - Storage for metadata
+
+=item --mirror - URI of a CPAN mirror
+
+=item --debug - Debug output
+
+=item --force - Force an action
+
+=item --sync - Sync files from a CPAN mirror
+
+=back
+
+Some options may have different defaults for different commands as
+well as meaning. Boolean options can be prepended with 'no' to turn
+option off, for example --nosync.
+
+=head1 COMMANDS
+
+=head2 update
+
+Does full sync of data from a CPAN mirror into RT. By default sync files
+from a mirror, use --nosync option to acvoid. Don't update corresponding
+data if file(s) hasn't been changed since last update, you can use --force
+option to force the action.
+
+=cut
+
+use strict;
+use warnings;
+
+use CPAN2RT;
+
+our $DEBUG = 0;
+our $DATA_DIR = '';
+
+use Getopt::Long;
+use File::Spec;
+
+my $command = shift;
+my %commands = (
+ update => \&cmd_update,
+);
+
+unless ( $command ) {
+ # XXX: help
+ usage( "command is mandatory", 1 );
+} elsif ( !$commands{ $command } ) {
+ usage( "unknown command $command", 1 );
+}
+
+$commands{ $command }->();
+
+sub cmd_update {
+ my %opt = ( sync => 1, force => 0, debug => 0 );
+ GetOptions( \%opt, 'sync!', 'force!', 'debug!', 'home=s', 'datadir=s', 'mirror=s' );
+
+ my $importer = CPAN2RT->new( %opt );
+
+ $importer->sync_files( $opt{'mirror'} ) if $opt{'sync'};
+ $importer->sync_authors( $opt{'force'} );
+ $importer->sync_distributions( $opt{'force'} );
+ $importer->sync_maintainers( $opt{'force'} );
+}
+
+sub usage {
+ my ($msg, $status) = @_;
+ require Pod::Usage;
+ Pod::Usage::pod2usage(
+ -message => $msg,
+ -exitval => $status,
+ -verbose => 2,
+ -noperldoc => 1,
+ );
+}
+
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
new file mode 100644
index 0000000..7efc552
--- /dev/null
+++ b/inc/Module/AutoInstall.pm
@@ -0,0 +1,768 @@
+#line 1
+package Module::AutoInstall;
+
+use strict;
+use Cwd ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.03';
+}
+
+# special map on pre-defined feature sets
+my %FeatureMap = (
+ '' => 'Core Features', # XXX: deprecated
+ '-core' => 'Core Features',
+);
+
+# various lexical flags
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
+my ( $PostambleActions, $PostambleUsed );
+
+# See if it's a testing or non-interactive session
+_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
+_init();
+
+sub _accept_default {
+ $AcceptDefault = shift;
+}
+
+sub missing_modules {
+ return @Missing;
+}
+
+sub do_install {
+ __PACKAGE__->install(
+ [
+ $Config
+ ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ : ()
+ ],
+ @Missing,
+ );
+}
+
+# initialize various flags, and/or perform install
+sub _init {
+ foreach my $arg (
+ @ARGV,
+ split(
+ /[\s\t]+/,
+ $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
+ )
+ )
+ {
+ if ( $arg =~ /^--config=(.*)$/ ) {
+ $Config = [ split( ',', $1 ) ];
+ }
+ elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
+ elsif ( $arg =~ /^--default(?:deps)?$/ ) {
+ $AcceptDefault = 1;
+ }
+ elsif ( $arg =~ /^--check(?:deps)?$/ ) {
+ $CheckOnly = 1;
+ }
+ elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
+ $SkipInstall = 1;
+ }
+ elsif ( $arg =~ /^--test(?:only)?$/ ) {
+ $TestOnly = 1;
+ }
+ }
+}
+
+# overrides MakeMaker's prompt() to automatically accept the default choice
+sub _prompt {
+ goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
+
+ my ( $prompt, $default ) = @_;
+ my $y = ( $default =~ /^[Yy]/ );
+
+ print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
+ print "$default\n";
+ return $default;
+}
+
+# the workhorse
+sub import {
+ my $class = shift;
+ my @args = @_ or return;
+ my $core_all;
+
+ print "*** $class version " . $class->VERSION . "\n";
+ print "*** Checking for Perl dependencies...\n";
+
+ my $cwd = Cwd::cwd();
+
+ $Config = [];
+
+ my $maxlen = length(
+ (
+ sort { length($b) <=> length($a) }
+ grep { /^[^\-]/ }
+ map {
+ ref($_)
+ ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
+ : ''
+ }
+ map { +{@args}->{$_} }
+ grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
+ )[0]
+ );
+
+ while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
+ my ( @required, @tests, @skiptests );
+ my $default = 1;
+ my $conflict = 0;
+
+ if ( $feature =~ m/^-(\w+)$/ ) {
+ my $option = lc($1);
+
+ # check for a newer version of myself
+ _update_to( $modules, @_ ) and return if $option eq 'version';
+
+ # sets CPAN configuration options
+ $Config = $modules if $option eq 'config';
+
+ # promote every features to core status
+ $core_all = ( $modules =~ /^all$/i ) and next
+ if $option eq 'core';
+
+ next unless $option eq 'core';
+ }
+
+ print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
+
+ $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
+
+ unshift @$modules, -default => &{ shift(@$modules) }
+ if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
+
+ while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
+ if ( $mod =~ m/^-(\w+)$/ ) {
+ my $option = lc($1);
+
+ $default = $arg if ( $option eq 'default' );
+ $conflict = $arg if ( $option eq 'conflict' );
+ @tests = @{$arg} if ( $option eq 'tests' );
+ @skiptests = @{$arg} if ( $option eq 'skiptests' );
+
+ next;
+ }
+
+ printf( "- %-${maxlen}s ...", $mod );
+
+ if ( $arg and $arg =~ /^\D/ ) {
+ unshift @$modules, $arg;
+ $arg = 0;
+ }
+
+ # XXX: check for conflicts and uninstalls(!) them.
+ if (
+ defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
+ {
+ print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
+ push @Existing, $mod => $arg;
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+ else {
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ push @required, $mod => $arg;
+ }
+ }
+
+ next unless @required;
+
+ my $mandatory = ( $feature eq '-core' or $core_all );
+
+ if (
+ !$SkipInstall
+ and (
+ $CheckOnly
+ or _prompt(
+ qq{==> Auto-install the }
+ . ( @required / 2 )
+ . ( $mandatory ? ' mandatory' : ' optional' )
+ . qq{ module(s) from CPAN?},
+ $default ? 'y' : 'n',
+ ) =~ /^[Yy]/
+ )
+ )
+ {
+ push( @Missing, @required );
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+
+ elsif ( !$SkipInstall
+ and $default
+ and $mandatory
+ and
+ _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
+ =~ /^[Nn]/ )
+ {
+ push( @Missing, @required );
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+
+ else {
+ $DisabledTests{$_} = 1 for map { glob($_) } @tests;
+ }
+ }
+
+ $UnderCPAN = _check_lock(); # check for $UnderCPAN
+
+ if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ require Config;
+ print
+"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
+
+ # make an educated guess of whether we'll need root permission.
+ print " (You may need to do that as the 'root' user.)\n"
+ if eval '$>';
+ }
+ print "*** $class configuration finished.\n";
+
+ chdir $cwd;
+
+ # import to main::
+ no strict 'refs';
+ *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
+}
+
+# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
+# if we are, then we simply let it taking care of our dependencies
+sub _check_lock {
+ return unless @Missing;
+
+ if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
+ print <<'END_MESSAGE';
+
+*** Since we're running under CPANPLUS, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+ }
+
+ _load_cpan();
+
+ # Find the CPAN lock-file
+ my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
+ return unless -f $lock;
+
+ # Check the lock
+ local *LOCK;
+ return unless open(LOCK, $lock);
+
+ if (
+ ( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
+ and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
+ ) {
+ print <<'END_MESSAGE';
+
+*** Since we're running under CPAN, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+ }
+
+ close LOCK;
+ return;
+}
+
+sub install {
+ my $class = shift;
+
+ my $i; # used below to strip leading '-' from config keys
+ my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
+
+ my ( @modules, @installed );
+ while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
+
+ # grep out those already installed
+ if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ push @installed, $pkg;
+ }
+ else {
+ push @modules, $pkg, $ver;
+ }
+ }
+
+ return @installed unless @modules; # nothing to do
+ return @installed if _check_lock(); # defer to the CPAN shell
+
+ print "*** Installing dependencies...\n";
+
+ return unless _connected_to('cpan.org');
+
+ my %args = @config;
+ my %failed;
+ local *FAILED;
+ if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
+ while (<FAILED>) { chomp; $failed{$_}++ }
+ close FAILED;
+
+ my @newmod;
+ while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
+ push @newmod, ( $k => $v ) unless $failed{$k};
+ }
+ @modules = @newmod;
+ }
+
+ if ( _has_cpanplus() ) {
+ _install_cpanplus( \@modules, \@config );
+ } else {
+ _install_cpan( \@modules, \@config );
+ }
+
+ print "*** $class installation finished.\n";
+
+ # see if we have successfully installed them
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ push @installed, $pkg;
+ }
+ elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
+ print FAILED "$pkg\n";
+ }
+ }
+
+ close FAILED if $args{do_once};
+
+ return @installed;
+}
+
+sub _install_cpanplus {
+ my @modules = @{ +shift };
+ my @config = _cpanplus_config( @{ +shift } );
+ my $installed = 0;
+
+ require CPANPLUS::Backend;
+ my $cp = CPANPLUS::Backend->new;
+ my $conf = $cp->configure_object;
+
+ return unless $conf->can('conf') # 0.05x+ with "sudo" support
+ or _can_write($conf->_get_build('base')); # 0.04x
+
+ # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
+ my $makeflags = $conf->get_conf('makeflags') || '';
+ if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
+ # 0.03+ uses a hashref here
+ $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
+
+ } else {
+ # 0.02 and below uses a scalar
+ $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
+ if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
+
+ }
+ $conf->set_conf( makeflags => $makeflags );
+ $conf->set_conf( prereqs => 1 );
+
+
+
+ while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
+ $conf->set_conf( $key, $val );
+ }
+
+ my $modtree = $cp->module_tree;
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ print "*** Installing $pkg...\n";
+
+ MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
+
+ my $success;
+ my $obj = $modtree->{$pkg};
+
+ if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = $cp->install( modules => [ $obj->{module} ] );
+
+ if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
+ print "*** $pkg successfully installed.\n";
+ $success = 1;
+ } else {
+ print "*** $pkg installation cancelled.\n";
+ $success = 0;
+ }
+
+ $installed += $success;
+ } else {
+ print << ".";
+*** Could not find a version $ver or above for $pkg; skipping.
+.
+ }
+
+ MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
+ }
+
+ return $installed;
+}
+
+sub _cpanplus_config {
+ my @config = ();
+ while ( @_ ) {
+ my ($key, $value) = (shift(), shift());
+ if ( $key eq 'prerequisites_policy' ) {
+ if ( $value eq 'follow' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
+ } elsif ( $value eq 'ask' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_ASK();
+ } elsif ( $value eq 'ignore' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
+ } else {
+ die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
+ }
+ } else {
+ die "*** Cannot convert option $key to CPANPLUS version.\n";
+ }
+ }
+ return @config;
+}
+
+sub _install_cpan {
+ my @modules = @{ +shift };
+ my @config = @{ +shift };
+ my $installed = 0;
+ my %args;
+
+ _load_cpan();
+ require Config;
+
+ if (CPAN->VERSION < 1.80) {
+ # no "sudo" support, probe for writableness
+ return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
+ and _can_write( $Config::Config{sitelib} );
+ }
+
+ # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
+ my $makeflags = $CPAN::Config->{make_install_arg} || '';
+ $CPAN::Config->{make_install_arg} =
+ join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
+ if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
+
+ # don't show start-up info
+ $CPAN::Config->{inhibit_startup_message} = 1;
+
+ # set additional options
+ while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
+ ( $args{$opt} = $arg, next )
+ if $opt =~ /^force$/; # pseudo-option
+ $CPAN::Config->{$opt} = $arg;
+ }
+
+ local $CPAN::Config->{prerequisites_policy} = 'follow';
+
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
+
+ print "*** Installing $pkg...\n";
+
+ my $obj = CPAN::Shell->expand( Module => $pkg );
+ my $success = 0;
+
+ if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
+ : CPAN::Shell->install($pkg);
+ $rv ||= eval {
+ $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
+ ->{install}
+ if $CPAN::META;
+ };
+
+ if ( $rv eq 'YES' ) {
+ print "*** $pkg successfully installed.\n";
+ $success = 1;
+ }
+ else {
+ print "*** $pkg installation failed.\n";
+ $success = 0;
+ }
+
+ $installed += $success;
+ }
+ else {
+ print << ".";
+*** Could not find a version $ver or above for $pkg; skipping.
+.
+ }
+
+ MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
+ }
+
+ return $installed;
+}
+
+sub _has_cpanplus {
+ return (
+ $HasCPANPLUS = (
+ $INC{'CPANPLUS/Config.pm'}
+ or _load('CPANPLUS::Shell::Default')
+ )
+ );
+}
+
+# make guesses on whether we're under the CPAN installation directory
+sub _under_cpan {
+ require Cwd;
+ require File::Spec;
+
+ my $cwd = File::Spec->canonpath( Cwd::cwd() );
+ my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
+
+ return ( index( $cwd, $cpan ) > -1 );
+}
+
+sub _update_to {
+ my $class = __PACKAGE__;
+ my $ver = shift;
+
+ return
+ if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
+
+ if (
+ _prompt( "==> A newer version of $class ($ver) is required. Install?",
+ 'y' ) =~ /^[Nn]/
+ )
+ {
+ die "*** Please install $class $ver manually.\n";
+ }
+
+ print << ".";
+*** Trying to fetch it from CPAN...
+.
+
+ # install ourselves
+ _load($class) and return $class->import(@_)
+ if $class->install( [], $class, $ver );
+
+ print << '.'; exit 1;
+
+*** Cannot bootstrap myself. :-( Installation terminated.
+.
+}
+
+# check if we're connected to some host, using inet_aton
+sub _connected_to {
+ my $site = shift;
+
+ return (
+ ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
+ qq(
+*** Your host cannot resolve the domain name '$site', which
+ probably means the Internet connections are unavailable.
+==> Should we try to install the required module(s) anyway?), 'n'
+ ) =~ /^[Yy]/
+ );
+}
+
+# check if a directory is writable; may create it on demand
+sub _can_write {
+ my $path = shift;
+ mkdir( $path, 0755 ) unless -e $path;
+
+ return 1 if -w $path;
+
+ print << ".";
+*** You are not allowed to write to the directory '$path';
+ the installation may fail due to insufficient permissions.
+.
+
+ if (
+ eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
+ qq(
+==> Should we try to re-execute the autoinstall process with 'sudo'?),
+ ((-t STDIN) ? 'y' : 'n')
+ ) =~ /^[Yy]/
+ )
+ {
+
+ # try to bootstrap ourselves from sudo
+ print << ".";
+*** Trying to re-execute the autoinstall process with 'sudo'...
+.
+ my $missing = join( ',', @Missing );
+ my $config = join( ',',
+ UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ if $Config;
+
+ return
+ unless system( 'sudo', $^X, $0, "--config=$config",
+ "--installdeps=$missing" );
+
+ print << ".";
+*** The 'sudo' command exited with error! Resuming...
+.
+ }
+
+ return _prompt(
+ qq(
+==> Should we try to install the required module(s) anyway?), 'n'
+ ) =~ /^[Yy]/;
+}
+
+# load a module and return the version it reports
+sub _load {
+ my $mod = pop; # class/instance doesn't matter
+ my $file = $mod;
+
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+
+ local $@;
+ return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
+}
+
+# Load CPAN.pm and it's configuration
+sub _load_cpan {
+ return if $CPAN::VERSION;
+ require CPAN;
+ if ( $CPAN::HandleConfig::VERSION ) {
+ # Newer versions of CPAN have a HandleConfig module
+ CPAN::HandleConfig->load;
+ } else {
+ # Older versions had the load method in Config directly
+ CPAN::Config->load;
+ }
+}
+
+# compare two versions, either use Sort::Versions or plain comparison
+sub _version_check {
+ my ( $cur, $min ) = @_;
+ return unless defined $cur;
+
+ $cur =~ s/\s+$//;
+
+ # check for version numbers that are not in decimal format
+ if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
+ if ( ( $version::VERSION or defined( _load('version') )) and
+ version->can('new')
+ ) {
+
+ # use version.pm if it is installed.
+ return (
+ ( version->new($cur) >= version->new($min) ) ? $cur : undef );
+ }
+ elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
+ {
+
+ # use Sort::Versions as the sorting algorithm for a.b.c versions
+ return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
+ ? $cur
+ : undef );
+ }
+
+ warn "Cannot reliably compare non-decimal formatted versions.\n"
+ . "Please install version.pm or Sort::Versions.\n";
+ }
+
+ # plain comparison
+ local $^W = 0; # shuts off 'not numeric' bugs
+ return ( $cur >= $min ? $cur : undef );
+}
+
+# nothing; this usage is deprecated.
+sub main::PREREQ_PM { return {}; }
+
+sub _make_args {
+ my %args = @_;
+
+ $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
+ if $UnderCPAN or $TestOnly;
+
+ if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
+ require ExtUtils::Manifest;
+ my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
+
+ $args{EXE_FILES} =
+ [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
+ }
+
+ $args{test}{TESTS} ||= 't/*.t';
+ $args{test}{TESTS} = join( ' ',
+ grep { !exists( $DisabledTests{$_} ) }
+ map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
+
+ my $missing = join( ',', @Missing );
+ my $config =
+ join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ if $Config;
+
+ $PostambleActions = (
+ $missing
+ ? "\$(PERL) $0 --config=$config --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ return %args;
+}
+
+# a wrapper to ExtUtils::MakeMaker::WriteMakefile
+sub Write {
+ require Carp;
+ Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
+
+ if ($CheckOnly) {
+ print << ".";
+*** Makefile not written in check-only mode.
+.
+ return;
+ }
+
+ my %args = _make_args(@_);
+
+ no strict 'refs';
+
+ $PostambleUsed = 0;
+ local *MY::postamble = \&postamble unless defined &MY::postamble;
+ ExtUtils::MakeMaker::WriteMakefile(%args);
+
+ print << "." unless $PostambleUsed;
+*** WARNING: Makefile written with customized MY::postamble() without
+ including contents from Module::AutoInstall::postamble() --
+ auto installation features disabled. Please contact the author.
+.
+
+ return 1;
+}
+
+sub postamble {
+ $PostambleUsed = 1;
+
+ return << ".";
+
+config :: installdeps
+\t\$(NOECHO) \$(NOOP)
+
+checkdeps ::
+\t\$(PERL) $0 --checkdeps
+
+installdeps ::
+\t$PostambleActions
+
+.
+
+}
+
+1;
+
+__END__
+
+#line 1003
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
new file mode 100644
index 0000000..89a8653
--- /dev/null
+++ b/inc/Module/Install.pm
@@ -0,0 +1,281 @@
+#line 1
+package Module::Install;
+
+# For any maintainers:
+# The load order for Module::Install is a bit magic.
+# It goes something like this...
+#
+# IF ( host has Module::Install installed, creating author mode ) {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
+# 3. The installed version of inc::Module::Install loads
+# 4. inc::Module::Install calls "require Module::Install"
+# 5. The ./inc/ version of Module::Install loads
+# } ELSE {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
+# 3. The ./inc/ version of Module::Install loads
+# }
+
+use 5.004;
+use strict 'vars';
+
+use vars qw{$VERSION};
+BEGIN {
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '0.68';
+}
+
+# Whether or not inc::Module::Install is actually loaded, the
+# $INC{inc/Module/Install.pm} is what will still get set as long as
+# the caller loaded module this in the documented manner.
+# If not set, the caller may NOT have loaded the bundled version, and thus
+# they may not have a MI version that works with the Makefile.PL. This would
+# result in false errors or unexpected behaviour. And we don't want that.
+my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+unless ( $INC{$file} ) {
+ die <<"END_DIE";
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+}
+
+# If the script that is loading Module::Install is from the future,
+# then make will detect this and cause it to re-run over and over
+# again. This is bad. Rather than taking action to touch it (which
+# is unreliable on some platforms and requires write permissions)
+# for now we should catch this and refuse to run.
+if ( -f $0 and (stat($0))[9] > time ) {
+ die << "END_DIE";
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+}
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+*inc::Module::Install::VERSION = *VERSION;
+ at inc::Module::Install::ISA = __PACKAGE__;
+
+sub autoload {
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+}
+
+sub preload {
+ my ($self) = @_;
+
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+
+ bless( \%args, $class );
+}
+
+sub call {
+ my ($self, $method) = @_;
+ my $obj = $self->load($method) or return;
+ splice(@_, 0, 2, $obj);
+ goto &{$obj->can($method)};
+}
+
+sub load {
+ my ($self, $method) = @_;
+
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
+
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
+
+ my $admin = $self->{admin} or die <<"END_DIE";
+The '$method' method does not exist in the '$self->{prefix}' path!
+Please remove the '$self->{prefix}' directory and run $0 again to load it.
+END_DIE
+
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
+
+ $obj;
+}
+
+sub load_extensions {
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
+ my $in_pod = 0;
+ while ( <PKGFILE> ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ close PKGFILE;
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+1;
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
new file mode 100644
index 0000000..3a490fb
--- /dev/null
+++ b/inc/Module/Install/AutoInstall.pm
@@ -0,0 +1,61 @@
+#line 1
+package Module::Install::AutoInstall;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub AutoInstall { $_[0] }
+
+sub run {
+ my $self = shift;
+ $self->auto_install_now(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->auto_install(@_);
+}
+
+sub auto_install {
+ my $self = shift;
+ return if $self->{done}++;
+
+ # Flatten array of arrays into a single array
+ my @core = map @$_, map @$_, grep ref,
+ $self->build_requires, $self->requires;
+
+ my @config = @_;
+
+ # We'll need Module::AutoInstall
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall->import(
+ (@config ? (-config => \@config) : ()),
+ (@core ? (-core => \@core) : ()),
+ $self->features,
+ );
+
+ $self->makemaker_args( Module::AutoInstall::_make_args() );
+
+ my $class = ref($self);
+ $self->postamble(
+ "# --- $class section:\n" .
+ Module::AutoInstall::postamble()
+ );
+}
+
+sub auto_install_now {
+ my $self = shift;
+ $self->auto_install(@_);
+ Module::AutoInstall::do_install();
+}
+
+1;
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
new file mode 100644
index 0000000..49dfde6
--- /dev/null
+++ b/inc/Module/Install/Base.pm
@@ -0,0 +1,70 @@
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.68';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+sub is_admin {
+ $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 138
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..ec66fdb
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,82 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+ my ($self, $mod, $ver) = @_;
+ $mod =~ s{::|\\}{/}g;
+ $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+ my $pkg = $mod;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+
+ local $@;
+ eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# can we locate a (the) C compiler
+sub can_cc {
+ my $self = shift;
+ my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ return $self->can_run("@chunks") || (pop(@chunks), next);
+ }
+
+ return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+ require ExtUtils::MM_Cygwin;
+ require ExtUtils::MM_Win32;
+ if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+ *ExtUtils::MM_Cygwin::maybe_command = sub {
+ my ($self, $file) = @_;
+ if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+ ExtUtils::MM_Win32->maybe_command($file);
+ } else {
+ ExtUtils::MM_Unix->maybe_command($file);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+#line 157
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..e0dd6db
--- /dev/null
+++ b/inc/Module/Install/Fetch.pm
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub get_file {
+ my ($self, %args) = @_;
+ my ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+ if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+ $args{url} = $args{ftp_url}
+ or (warn("LWP support unavailable!\n"), return);
+ ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+ }
+
+ $|++;
+ print "Fetching '$file' from $host... ";
+
+ unless (eval { require Socket; Socket::inet_aton($host) }) {
+ warn "'$host' resolve failed!\n";
+ return;
+ }
+
+ return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+ require Cwd;
+ my $dir = Cwd::getcwd();
+ chdir $args{local_dir} or return if exists $args{local_dir};
+
+ if (eval { require LWP::Simple; 1 }) {
+ LWP::Simple::mirror($args{url}, $file);
+ }
+ elsif (eval { require Net::FTP; 1 }) { eval {
+ # use Net::FTP to get past firewall
+ my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+ $ftp->login("anonymous", 'anonymous at example.com');
+ $ftp->cwd($path);
+ $ftp->binary;
+ $ftp->get($file) or (warn("$!\n"), return);
+ $ftp->quit;
+ } }
+ elsif (my $ftp = $self->can_run('ftp')) { eval {
+ # no Net::FTP, fallback to ftp.exe
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+ unless ($fh->open("|$ftp -n")) {
+ warn "Couldn't open ftp: $!\n";
+ chdir $dir; return;
+ }
+
+ my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ } }
+ else {
+ warn "No working 'ftp' program available!\n";
+ chdir $dir; return;
+ }
+
+ unless (-f $file) {
+ warn "Fetching failed: $@\n";
+ chdir $dir; return;
+ }
+
+ return if exists $args{size} and -s $file != $args{size};
+ system($args{run}) if exists $args{run};
+ unlink($file) if $args{remove};
+
+ print(((!exists $args{check_for} or -e $args{check_for})
+ ? "done!" : "failed! ($!)"), "\n");
+ chdir $dir; return !$?;
+}
+
+1;
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
new file mode 100644
index 0000000..001d0c6
--- /dev/null
+++ b/inc/Module/Install/Include.pm
@@ -0,0 +1,34 @@
+#line 1
+package Module::Install::Include;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub include {
+ shift()->admin->include(@_);
+}
+
+sub include_deps {
+ shift()->admin->include_deps(@_);
+}
+
+sub auto_include {
+ shift()->admin->auto_include(@_);
+}
+
+sub auto_include_deps {
+ shift()->admin->auto_include_deps(@_);
+}
+
+sub auto_include_dependent_dists {
+ shift()->admin->auto_include_dependent_dists(@_);
+}
+
+1;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
new file mode 100644
index 0000000..17bd8a7
--- /dev/null
+++ b/inc/Module/Install/Makefile.pm
@@ -0,0 +1,237 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
+ }
+
+ # In automated testing, always use defaults
+ if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ($self->{makemaker_args} ||= {});
+ %$args = ( %$args, @_ ) if @_;
+ $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = sShift;
+ my $name = shift;
+ my $args = $self->makemaker_args;
+ $args->{name} = defined $args->{$name}
+ ? join( ' ', $args->{name}, @_ )
+ : join( ' ', @_ );
+}
+
+sub build_subdirs {
+ my $self = shift;
+ my $subdirs = $self->makemaker_args->{DIR} ||= [];
+ for my $subdir (@_) {
+ push @$subdirs, $subdir;
+ }
+}
+
+sub clean_files {
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join(' ', grep length, $clean->{FILES}, @_),
+ );
+}
+
+sub realclean_files {
+ my $self = shift;
+ my $realclean = $self->makemaker_args->{realclean} ||= {};
+ %$realclean = (
+ %$realclean,
+ FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ );
+}
+
+sub libs {
+ my $self = shift;
+ my $libs = ref $_[0] ? shift : [ shift ];
+ $self->makemaker_args( LIBS => $libs );
+}
+
+sub inc {
+ my $self = shift;
+ $self->makemaker_args( INC => shift );
+}
+
+my %test_dir = ();
+
+sub _wanted_t {
+ /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
+}
+
+sub tests_recursive {
+ my $self = shift;
+ if ( $self->tests ) {
+ die "tests_recursive will not work if tests are already defined";
+ }
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ require File::Find;
+ %test_dir = ();
+ File::Find::find( \&_wanted_t, $dir );
+ $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ }
+ map { @$_ }
+ grep $_,
+ ($self->build_requires, $self->requires)
+ );
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ if ( my $perl_version = $self->perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
+
+ $args->{INSTALLDIRS} = $self->installdirs;
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if (my $preop = $self->admin->preop($user_preop)) {
+ $args{dist} = $preop;
+ }
+
+ my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+ $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+}
+
+sub fix_up_makefile {
+ my $self = shift;
+ my $makefile_name = shift;
+ my $top_class = ref($self->_top) || '';
+ my $top_version = $self->_top->VERSION || '';
+
+ my $preamble = $self->preamble
+ ? "# Preamble by $top_class $top_version\n"
+ . $self->preamble
+ : '';
+ my $postamble = "# Postamble by $top_class $top_version\n"
+ . ($self->postamble || '');
+
+ local *MAKEFILE;
+ open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE or die $!;
+
+ $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+ $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
+
+ # XXX - This is currently unused; not sure if it breaks other MM-users
+ # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
+
+ open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
+}
+
+sub preamble {
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
+}
+
+sub postamble {
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 363
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
new file mode 100644
index 0000000..f77d68a
--- /dev/null
+++ b/inc/Module/Install/Metadata.pm
@@ -0,0 +1,336 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name module_name abstract author version license
+ distribution_type perl_version tests installdirs
+};
+
+my @tuple_keys = qw{
+ build_requires requires recommends bundles
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+
+foreach my $key (@scalar_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} unless @_;
+
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ( $module eq 'perl' ) {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [ $module, $version ];
+ push @rv, $rv;
+ }
+ push @{ $self->{values}{$key} }, @rv;
+ @rv;
+ };
+}
+
+# configure_requires is currently a null-op
+sub configure_requires { 1 }
+
+# Aliases for build_requires that will have alternative
+# meanings in some future version of META.yml.
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
+
+# Aliases for installdirs options
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
+
+sub sign {
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and ! @_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ return $self;
+ }
+ $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
+ return $self;
+}
+
+sub all_from {
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name
+ or die "all_from called with no args without setting name() first";
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+
+ # The remaining probes read from POD sections; if the file
+ # has an accompanying .pod, use that instead
+ my $pod = $file;
+ if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+ $file = $pod;
+ }
+
+ $self->author_from($file) unless $self->author;
+ $self->license_from($file) unless $self->license;
+ $self->abstract_from($file) unless $self->abstract;
+}
+
+sub provides {
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
+}
+
+sub auto_provides {
+ my $self = shift;
+ return $self unless $self->is_admin;
+
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+
+ # Avoid spurious warnings as we are not checking manifest here.
+
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides(%{ $build->find_dist_packages || {} });
+}
+
+sub feature {
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
+ : @$_
+ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
+}
+
+sub features {
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
+}
+
+sub no_index {
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
+}
+
+sub read {
+ my $self = shift;
+ $self->include_deps( 'YAML', 0 );
+
+ require YAML;
+ my $data = YAML::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ }
+ else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
+}
+
+sub write {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
+}
+
+sub version_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+sub _slurp {
+ my ( $self, $file ) = @_;
+
+ local *FH;
+ open FH, "< $file" or die "Cannot open $file.pod: $!";
+ do { local $/; <FH> };
+}
+
+sub perl_version_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ )
+ {
+ my $v = $1;
+ $v =~ s{_}{}g;
+ $self->perl_version($1);
+ }
+ else {
+ warn "Cannot determine perl version info from $file\n";
+ return;
+ }
+}
+
+sub author_from {
+ my ( $self, $file ) = @_;
+ my $content = $self->_slurp($file);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ }
+ else {
+ warn "Cannot determine author info from $file\n";
+ }
+}
+
+sub license_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms
+ )
+ {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser public license' => 'gpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ }
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $file\n";
+ return 'unknown';
+}
+
+1;
diff --git a/inc/Module/Install/Scripts.pm b/inc/Module/Install/Scripts.pm
new file mode 100644
index 0000000..544cdb8
--- /dev/null
+++ b/inc/Module/Install/Scripts.pm
@@ -0,0 +1,50 @@
+#line 1
+package Module::Install::Scripts;
+
+use strict;
+use Module::Install::Base;
+use File::Basename ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub prompt_script {
+ my ($self, $script_file) = @_;
+
+ my ($prompt, $abstract, $default);
+ foreach my $line ( $self->_read_script($script_file) ) {
+ last unless $line =~ /^#/;
+ $prompt = $1 if $line =~ /^#\s*prompt:\s+(.*)/;
+ $default = $1 if $line =~ /^#\s*default:\s+(.*)/;
+ $abstract = $1 if $line =~ /^#\s*abstract:\s+(.*)/;
+ }
+ unless (defined $prompt) {
+ my $script_name = File::Basename::basename($script_file);
+ $prompt = "Do you want to install '$script_name'";
+ $prompt .= " ($abstract)" if defined $abstract;
+ $prompt .= '?';
+ }
+ return unless $self->prompt($prompt, ($default || 'n')) =~ /^[Yy]/;
+ $self->install_script($script_file);
+}
+
+sub install_script {
+ my $self = shift;
+ my $args = $self->makemaker_args;
+ my $exe_files = $args->{EXE_FILES} ||= [];
+ push @$exe_files, @_;
+}
+
+sub _read_script {
+ my ($self, $script_file) = @_;
+ local *SCRIPT;
+ open SCRIPT, $script_file
+ or die "Can't open '$script_file' for input: $!\n";
+ return <SCRIPT>;
+}
+
+1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..4f808c7
--- /dev/null
+++ b/inc/Module/Install/Win32.pm
@@ -0,0 +1,65 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# determine if the user needs nmake, and download it if needed
+sub check_nmake {
+ my $self = shift;
+ $self->load('can_run');
+ $self->load('get_file');
+
+ require Config;
+ return unless (
+ $^O eq 'MSWin32' and
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ ! $self->can_run('nmake')
+ );
+
+ print "The required 'nmake' executable not found, fetching it...\n";
+
+ require File::Basename;
+ my $rv = $self->get_file(
+ url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+ ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+ local_dir => File::Basename::dirname($^X),
+ size => 51928,
+ run => 'Nmake15.exe /o > nul',
+ check_for => 'Nmake.exe',
+ remove => 1,
+ );
+
+ if (!$rv) {
+ die <<'END_MESSAGE';
+
+-------------------------------------------------------------------------------
+
+Since you are using Microsoft Windows, you will need the 'nmake' utility
+before installation. It's available at:
+
+ http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
+ or
+ ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
+
+Please download the file manually, save it to a directory in %PATH% (e.g.
+C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
+that directory, and run "Nmake15.exe" from there; that will create the
+'nmake.exe' file needed by this module.
+
+You may then resume the installation process described in README.
+
+-------------------------------------------------------------------------------
+END_MESSAGE
+ }
+}
+
+1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
new file mode 100644
index 0000000..078797c
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,43 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ if ( $0 =~ /Build.PL$/i ) {
+ $self->Build->write;
+ } else {
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{'PL_FILES'} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+ if ($args{inline}) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+ }
+}
+
+1;
diff --git a/lib/CPAN2RT.pm b/lib/CPAN2RT.pm
new file mode 100644
index 0000000..f48bb42
--- /dev/null
+++ b/lib/CPAN2RT.pm
@@ -0,0 +1,645 @@
+package CPAN2RT;
+
+use v5.8.3;
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Email::Address;
+use List::Compare;
+use CPAN::DistnameInfo;
+use List::MoreUtils qw(uniq);
+
+our $DEBUG = 0;
+sub debug(&);
+
+sub new {
+ my $proto = shift;
+ my $self = bless { @_ }, ref($proto) || $proto;
+ $self->init();
+ return $self;
+}
+
+sub init {
+ my $self = shift;
+
+ my $home = ($self->{'home'} ||= $ENV{'RTHOME'} || '/opt/rt3');
+ unshift @INC, File::Spec->catdir( $home, 'lib' );
+ unshift @INC, File::Spec->catdir( $home, 'local', 'lib' );
+
+ require RT;
+ RT::LoadConfig();
+ RT::Init();
+
+ $DEBUG = $self->{'debug'};
+}
+
+sub sync_files {
+ my $self = shift;
+ my $mirror = shift || $self->{'mirror'} || 'ftp://ftp.funet.fi/pub/CPAN';
+
+ debug { "Syncing files from '$mirror'\n" };
+
+ my @files = qw(
+ authors/01mailrc.txt.gz
+ modules/06perms.txt.gz
+ modules/02packages.details.txt.gz
+ );
+
+ require LWP::UserAgent;
+ my $ua = new LWP::UserAgent;
+ $ua->timeout( 10 );
+
+ foreach my $file ( @files ) {
+ debug { "Fetching '$file'\n" };
+ my $store = $self->file_path( $file );
+ $self->backup_file( $store ) if -e $store;
+ my $response = $ua->get( "$mirror/$file", ':content_file' => $store );
+ unless ( $response->is_success ) {
+ print STDERR $response->status_line, "\n";
+ next;
+ }
+ my $mtime = $response->header('Last-Modified');
+
+ debug { "Fetched '$file' -> '$store'\n" };
+
+ if ( $store =~ /(.*)\.gz$/ ) {
+ $self->backup_file( $1 );
+ `gunzip -f $store`;
+ $store =~ s/\.gz$//;
+ debug { "Unzipped '$store'\n" };
+ }
+
+ if ( $mtime ) {
+ require HTTP::Date;
+ $mtime = HTTP::Date::str2time( $mtime );
+ utime $mtime, $mtime, $store if $mtime;
+ debug { "Last modified: $mtime\n" };
+ }
+ }
+}
+
+{ my $cache;
+sub authors {
+ my $self = shift;
+ $cache = $self->_authors unless $cache;
+ return $cache;
+} }
+
+sub _authors {
+ my $self = shift;
+ my $file = '01mailrc.txt';
+ debug { "Parsing $file...\n" };
+ my $path = $self->file_path( $file );
+ open my $fh, "<:utf8", $path or die "Couldn't open '$path': $!";
+
+ my %res;
+ while ( my $str = <$fh> ) {
+ chomp $str;
+ my ($cpanid, $real_name, $email) = ($str =~ m{^alias\s+([A-Z0-9]+)\s+"([^<>]*?)\s*<([^>]+)>"$});
+ unless ( $cpanid ) {
+ debug { "couldn't parse '$str'\n" };
+ next;
+ }
+ $res{ $cpanid } = {
+ real_name => $real_name,
+ email_address => $self->parse_email_address($email) || $cpanid .'@cpan.org',
+ };
+ }
+ close $fh;
+ return \%res;
+}
+
+{ my $cache;
+sub permissions {
+ my $self = shift;
+ $cache = $self->_permissions unless $cache;
+ return $cache;
+} }
+
+sub _permissions {
+ my $self = shift;
+ my $file = '06perms.txt';
+ debug { "Parsing $file...\n" };
+ my $path = $self->file_path( $file );
+ open my $fh, "<:utf8", $path or die "Couldn't open '$path': $!";
+
+ $self->skip_header( $fh );
+
+ my %res;
+ while ( my $str = <$fh> ) {
+ chomp $str;
+
+ my ($module, $cpanid, $permission) = (split /\s*,\s*/, $str);
+ unless ( $module && $cpanid ) {
+ debug { "couldn't parse '$str'\n" };
+ next;
+ }
+ $res{ $module } ||= [];
+ push @{ $res{ $module } }, $cpanid;
+ }
+ close $fh;
+
+ return \%res;
+}
+
+{ my $cache;
+sub module2file {
+ my $self = shift;
+ $cache = $self->_module2file() unless $cache;
+ return $cache;
+} }
+
+sub _module2file {
+ my $self = shift;
+ my $file = '02packages.details.txt';
+ debug { "Parsing $file...\n" };
+ my $path = $self->file_path( $file );
+ open my $fh, "<:utf8", $path or die "Couldn't open '$path': $!";
+
+ $self->skip_header( $fh );
+
+ my %res;
+ while ( my $str = <$fh> ) {
+ chomp $str;
+
+ my ($module, $mver, $file) = split /\s+/, $str;
+ unless ( $module && $file ) {
+ debug { "couldn't parse '$str'\n" };
+ next;
+ }
+ $res{ $module } = $file;
+ }
+ close $fh;
+
+ return \%res;
+}
+
+sub sync_authors {
+ my $self = shift;
+ my $force = shift;
+ if ( !$force && !$self->is_new_file( '01mailrc.txt' ) ) {
+ debug { "Skip syncing, file's not changed\n" };
+ return (1);
+ }
+
+ my @errors;
+ my $authors = $self->authors;
+ while ( my ($cpanid, $meta) = each %$authors ) {
+ my ($user, @msg) = $self->load_or_create_user( $cpanid, @{ $meta }{qw(real_name email_address)} );
+ push @errors, @msg unless $user;
+ }
+ return (undef, @errors) if @errors;
+ return (1);
+}
+
+sub sync_distributions {
+ my $self = shift;
+ my $force = shift;
+ if ( !$force && !$self->is_new_file( '02packages.details.txt' ) ) {
+ debug { "Skip syncing, file's not changed\n" };
+ return (1);
+ }
+
+ my @files = uniq values %{ $self->module2file };
+
+ my %tmp;
+ foreach my $file ( @files ) {
+ my $info = CPAN::DistnameInfo->new( "authors/id/$file" );
+ my $dist = $info->dist;
+ unless ( $dist ) {
+ debug { "Couldn't parse distribution name from '$file'\n" };
+ next;
+ }
+ if ( $dist =~ /^(parrot|perl)$/i ) {
+ debug { "Skipping $dist as it's hard coded to be skipped." };
+ next;
+ }
+
+ $tmp{ $dist } ||= [];
+ if ( my $v = $info->version ) {
+ push @{ $tmp{ $dist } }, $v;
+ }
+ }
+
+ my @errors;
+ while ( my ($dist, $versions) = each %tmp ) {
+ my ($queue, @msg) = $self->load_or_create_queue( $dist );
+ unless ( $queue ) {
+ push @errors, @msg;
+ next;
+ }
+ if ( $versions && @$versions ) {
+ my ($status, @msg) = $self->add_versions( $queue, @$versions );
+ push @errors, @msg unless $status;
+ }
+ }
+
+ %tmp = ();
+
+ return (undef, @errors) if @errors;
+ return (1);
+}
+
+sub sync_maintainers {
+ my $self = shift;
+ my $force = shift;
+ if ( !$force && !$self->is_new_file( '06perms.txt' ) ) {
+ debug { "Skip syncing, file's not changed\n" };
+ return (1);
+ }
+
+ my $m2f = $self->module2file;
+ my $perm = $self->permissions;
+
+ my %res;
+ while ( my ($module, $maint) = each %$perm ) {
+ my $file = $m2f->{ $module };
+ next unless $file;
+
+ my $dist = CPAN::DistnameInfo->new( "authors/id/$file" )->dist;
+ unless ( $dist ) {
+ debug { "Couldn't parse distribution name from '$file'\n" };
+ next;
+ }
+ push @{ $res{ $dist } ||= [] }, @$maint;
+ }
+
+ my @errors = ();
+ while ( my ($dist, $maint) = each %res ) {
+ my ($queue, @msg) = $self->load_or_create_queue( $dist );
+ unless ( $queue ) {
+ push @errors, @msg;
+ next;
+ }
+
+ my $status;
+ ($status, @msg) = $self->set_maintainers( $queue, @$maint );
+ push @errors, @msg unless $status;
+ }
+ %res = ();
+ return (undef, @errors) if @errors;
+ return (1);
+}
+
+sub current_maintainers {
+ my $self = shift;
+ my $queue = shift;
+
+ my $users = $queue->AdminCc->UserMembersObj;
+ $users->OrderByCols;
+ return map uc $_->Name, @{ $users->ItemsArrayRef };
+}
+
+sub set_maintainers {
+ my $self = shift;
+ my $queue = shift;
+ my @maints = @_;
+ my @current = $self->current_maintainers( $queue );
+
+ my @errors;
+
+ my $set = List::Compare->new( '--unsorted', \@current, \@maints );
+ foreach ( $set->get_unique ) {
+ my ($status, @msg) = $self->del_maintainer( $queue, $_, 'force' );
+ push @errors, @msg unless $status;
+ }
+ foreach ( $set->get_complement ) {
+ my ($status, @msg) = $self->add_maintainer( $queue, $_, 'force' );
+ push @errors, @msg unless $status;
+ }
+
+ return (undef, @errors) if @errors;
+ return (1);
+}
+
+sub add_maintainer {
+ my $self = shift;
+ my $queue = shift;
+ my $user = shift;
+ my $force = shift || 0;
+
+ unless ( ref $user ) {
+ my $tmp = RT::User->new( $RT::SystemUser );
+ $tmp->LoadByCols( Name => $user );
+ return (undef, "Couldn't load user '$user'")
+ unless $tmp->id;
+
+ $user = $tmp;
+ }
+ unless ( $user->id ) {
+ return (undef, "Empty user object");
+ }
+
+ if ( !$force && $queue->IsAdminCc( $user->PrincipalId ) ) {
+ debug { $user->Name ." is allready maintainer of '". $queue->Name ."'\n" };
+ return (1);
+ }
+
+ my ($status, $msg) = $queue->AddWatcher(
+ Type => 'AdminCc',
+ PrincipalId => $user->PrincipalId,
+ );
+ unless ( $status ) {
+ $msg = "Couldn't add ". $user->Name ." as AdminCc for ". $queue->Name .": $msg\n";
+ return (undef, $msg);
+ } else {
+ debug { "Added ". $user->Name ." as maintainer of '". $queue->Name ."'\n" };
+ }
+ return (1);
+}
+
+sub del_maintainer {
+ my $self = shift;
+ my $queue = shift;
+ my $user = shift;
+ my $force = shift;
+
+ unless ( ref $user ) {
+ my $tmp = RT::User->new( $RT::SystemUser );
+ $tmp->LoadByCols( Name => $user );
+ return (undef, "Couldn't load user '$user'")
+ unless $tmp->id;
+
+ $user = $tmp;
+ }
+ unless ( $user->id ) {
+ return (undef, "Empty user object");
+ }
+
+ if ( !$force && !$queue->IsAdminCc( $user->PrincipalId ) ) {
+ debug { $user->Name ." is not maintainer of '". $queue->Name ."'. Skipping...\n" };
+ return (1);
+ }
+
+ my ($status, $msg) = $queue->DeleteWatcher(
+ Type => 'AdminCc',
+ PrincipalId => $user->PrincipalId,
+ );
+ unless ( $status ) {
+ $msg = "Couldn't delete ". $user->Name
+ ." from AdminCc list of '". $queue->Name ."': $msg\n";
+ return (undef, $msg);
+ } else {
+ debug { "Delete ". $user->Name ." from maintainers of '". $queue->Name ."'\n" };
+ }
+ return (1);
+}
+
+
+sub add_versions {
+ my $self = shift;
+ my ($queue, @versions) = @_;
+
+ my @errors;
+ foreach my $name ( "Broken in", "Fixed in" ) {
+ my ($cf, $msg) = $self->load_or_create_version_cf( $queue, $name );
+ unless ( $cf ) {
+ push @errors, $msg;
+ next;
+ }
+
+ # Unless it's a new value, don't add it
+ my %old = map { $_->Name => 1 } @{ $cf->Values->ItemsArrayRef };
+ foreach my $version ( grep defined && length, @versions ) {
+ if ( exists $old{$version} ) {
+ debug { "Version '$version' exists (not adding)\n" };
+ next;
+ }
+
+ my ($val, $msg) = $cf->AddValue(
+ Name => $version,
+ Description => "Version $version",
+ SortOrder => 0,
+ );
+ unless ( $val ) {
+ $msg = "Failed to add value '$version' to CF $name"
+ ." for queue ". $queue->Name .": $msg";
+ debug { $msg };
+ push @errors, $msg;
+ }
+ else {
+ debug { "Added version '$version' into '$name' list for queue '". $queue->Name ."'\n" };
+ }
+ }
+ }
+ return (undef, @errors) if @errors;
+ return (1);
+}
+
+sub load_or_create_user {
+ my $self = shift;
+ my ($cpanid, $realname, $email) = @_;
+
+ my $bycpanid = RT::User->new($RT::SystemUser);
+ $bycpanid->LoadByCol( Name => $cpanid );
+
+ # WARNING: when MergeUser extension is used then the same user records
+ # will be loaded even when there are multiple records in the DB
+ $email = $self->parse_email_address( $email ) || "$cpanid\@cpan.org";
+ my $byemail = RT::User->new( $RT::SystemUser );
+ $byemail->LoadByEmail( $email );
+
+ if ( $bycpanid->id && (($byemail->id && $bycpanid->id == $byemail->id) || !$byemail->id) ) {
+ # the same users, both cpanid and email...
+ # or email change, so no user with new email...
+ #
+ # XXX: as we have no way to detect email changes on PAUSE
+ # then we set email to the public version from PAUSE only when
+ # user in RT has no email. The same applies to name.
+ $bycpanid->SetEmailAddress( $email )
+ unless $bycpanid->EmailAddress;
+ $bycpanid->SetRealName( $realname )
+ unless $bycpanid->RealName;
+ return $bycpanid;
+ }
+ elsif ( $bycpanid->id && $byemail->id ) {
+ # both exist, but different
+ # XXX: merge them
+ debug { "WARNING: Two different users\n" };
+ return $bycpanid;
+ }
+ elsif ( $byemail->id ) {
+ # there is already user with that address, but different CPANID
+ my ($new, $msg) = $self->create_user( $cpanid, $realname );
+ return ($new, $msg) unless $new;
+
+ if ( $new->can('MergeInto') ) {
+ debug { "Merging user @{[$new->Name]} into @{[$byemail->Name]}...\n" };
+ $new->MergeInto( $byemail );
+ } else {
+ debug { "WARNING: Couldn't merge users. Extension is not installed.\n" };
+ }
+ return ($new);
+ }
+
+ return $self->create_user($cpanid, $realname, $email);
+}
+
+sub create_user {
+ my $self = shift;
+ my ($username, $realname, $email) = @_;
+
+ my $user = RT::User->new( $RT::SystemUser );
+ my ($val, $msg) = $user->Create(
+ Name => $username,
+ RealName => $realname,
+ EmailAddress => $email,
+ Privileged => 1
+ );
+
+ unless ( $val ) {
+ $msg = "Failed to create user $username: $msg";
+ debug { "FAILED! $msg\n" };
+ return (undef, $msg);
+ }
+ else {
+ debug { "Created user $username... " };
+ }
+
+ return ($user)
+}
+
+sub load_or_create_queue {
+ my $self = shift;
+ my $dist = shift;
+
+ my $queue = RT::Queue->new( $RT::SystemUser );
+ # Try to load up the current queue by name. Avoids duplication.
+ $queue->Load( $dist );
+ unless ( $queue->id ) {
+ my ($status, $msg) = $queue->Create(
+ Name => $dist,
+ Description => "Bugs in $dist",
+ CorrespondAddress => "bug-$dist\@rt.cpan.org",
+ CommentAddress => "comment-$dist\@rt.cpan.org",
+ );
+ unless ( $status ) {
+ return (undef, "Couldn't create queue '$dist': $msg\n");
+ }
+ debug { "Created queue for dist ". $queue->Name ." #". $queue->id ."\n" };
+ } else {
+ debug { "Found queue for dist ". $queue->Name ." #". $queue->id ."\n" };
+ }
+ return $queue;
+}
+
+sub load_or_create_version_cf {
+ my $self = shift;
+ my ($queue, $name) = @_;
+
+ my $cfs = RT::CustomFields->new( $RT::SystemUser );
+ $cfs->Limit( FIELD => 'Name', VALUE => $name );
+ $cfs->LimitToQueue( $queue->id );
+ $cfs->{'find_disabled_rows'} = 0; # This is why we don't simply do a LoadByName
+ $cfs->OrderByCols; # don't sort things
+ $cfs->RowsPerPage( 1 );
+
+ my $cf = $cfs->First;
+ unless ( $cf && $cf->id ) {
+ return $self->create_version_cf( $queue, $name );
+ }
+
+ return ($cf);
+}
+
+sub create_version_cf {
+ my $self = shift;
+ my ($queue, $name) = @_;
+
+ my $cf = RT::CustomField->new( $RT::SystemUser );
+ debug { "creating custom field $name..." };
+ my ($val, $msg) = $cf->Create(
+ Name => $name,
+ TypeComposite => 'Select-0',
+ # This is a much clearer way of associating a CF
+ # with a queue, except that it's not as efficient
+ # as the method below...
+ #
+ #Queue => $queue->Id,
+ #
+ # So instead we're going to set the lookup type here...
+ #
+ LookupType => 'RT::Queue-RT::Ticket',
+ );
+ unless ( $val ) {
+ debug { "FAILED! $msg\n" };
+ return (undef, "Failed to create CF $name for queue "
+ . $queue->Name
+ . ": $msg");
+ }
+ else {
+ debug { "ok\n" };
+ }
+
+ #
+ # ... and associate with the queue down here.
+ #
+ # This is the other way of associating a CF with a queue. Unlike
+ # the much more clear method above, it doesn't have to fetch the
+ # queue object again. And since this is an import, we do kinda
+ # care about that stuff...
+ #
+ ($val, $msg) = $cf->AddToObject( $queue );
+ unless ( $val ) {
+ $msg = "Failed to link CF $name with queue " . $queue->Name . ": $msg";
+ debug { $msg };
+ $cf->Delete;
+ return (undef, $msg);
+ }
+ return ($cf);
+}
+
+sub parse_email_address {
+ my $self = shift;
+ my $string = shift;
+ return undef unless defined $string && length $string;
+ return undef if uc($string) eq 'CENSORED';
+
+ my $address = (grep defined, Email::Address->parse( $string || '' ))[0];
+ return undef unless defined $address;
+ return $address->address;
+}
+
+sub file_path {
+ my $self = shift;
+ my $file = shift;
+ my $res = $file;
+ $res =~ s/.*\///; # strip leading dirs
+ if ( my $dir = $self->{'datadir'} ) {
+ require File::Spec;
+ $res = File::Spec->catfile( $dir, $res );
+ }
+ return $res;
+}
+
+sub is_new_file {
+ my $self = shift;
+ my $new = $self->file_path( shift );
+ my $old = $new .'.old';
+ return 1 unless -e $old;
+ return (stat $new)[9] > (stat $old)[9]? 1 : 0;
+}
+
+sub backup_file {
+ my $self = shift;
+ my $old = shift;
+ my $new = $old .'.old';
+ rename $old, $new;
+}
+
+sub skip_header {
+ my $self = shift;
+ my $fh = shift;
+ while ( my $str = <$fh> ) {
+ return if $str =~ /^\s*$/;
+ }
+}
+
+sub debug(&) {
+ return unless $DEBUG;
+ print STDERR map { /\n$/? $_ : $_."\n" } $_[0]->();
+}
+
+1;
commit 8ab6dccb1b54d57958f21dc3a8d3a85790e3293a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Jun 4 21:08:15 2008 +0000
CPAN to RT importer for rt.cpan.org
-----------------------------------------------------------------------
hooks/post-receive
--
cpan2rt
More information about the Bps-public-commit
mailing list