view release on metacpan or  search on metacpan

lib/CPAN2RT.pm  view on Meta::CPAN

=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;
    $self->init();
    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;

    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(
        indices/find-ls.gz
        authors/00whois.xml
        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 = '00whois.xml';
    debug { "Parsing $file...\n" };
    my $path = $self->file_path( $file );

    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;
}

{ 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 ) {

lib/CPAN2RT.pm  view on Meta::CPAN

    );
    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;

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;