view release on metacpan or  search on metacpan

lib/Labyrinth/Plugin/CPAN/Builder.pm  view on Meta::CPAN

    my ($cpan,$dbi,$progress,$type) = @_;

    # check whether we are running split or combined queries
    my $types = "'rmauth','rmdist'";
    $types = "'rmauth'" if($type && $type eq 'author');
    $types = "'rmdist'" if($type && $type eq 'distro');

    my @rows = $dbi->GetQuery('hash','GetRequests',{types => $types, limit => 20});
    return 0    unless(@rows);

    my @index = $dbi->GetQuery('hash','GetIndexRequests',{types => $types});
    for my $index (@index) {
        my ($type,@list);

        $progress->( ".. processing $index->{type} $index->{name}" )     if(defined $progress);

        if($index->{type} eq 'rmauth') {
            # 2016-04-21 = Barbie - temporarily suspended line below to allow author pages to generate
            # seems to be a bug picking up UUID for PSIXDISTS :(
            RemoveAuthorPages($cpan,$dbi,$progress,$index->{name});
        } else {
            RemoveDistroPages($cpan,$dbi,$progress,$index->{name});
        }
    }
}

# note $name is NOT the author name, but the dist name! need to get the reports to track version and then author

sub RemoveAuthorPages {
    my ($cpan,$dbi,$progress,$name) = @_;
    my (%remove,%author,@reports);
    my $fail = 0;

    # get ids from the page requests
    my @requests = $dbi->GetQuery('hash','GetRequestIDs',{names => $name},'rmauth');
    my %requests = map { $_->{id} => 1 } grep { $_->{id} } @requests;

    return  unless(keys %requests);
    push my @ids, keys %requests;

    my $next = $dbi->Iterator('hash','GetReportsByIDs',{ids=>join(',',@ids)});
    while(my $row = $next->()) {
        my @latest = $dbi->GetQuery('hash','CheckLatest',$row->{dist},$row->{version});
        next    unless(@latest);
        $author{$latest[0]->{author}}++;
        $remove{$row->{dist}}{uc $row->{state}}++;
    }

    for my $author (keys %author) {
        my $cache = sprintf "%s/static/author/%s", $settings{webdir}, substr($author,0,1);
        my $destfile = "$cache/$author.json";

        try {
            # load JSON, if we have one
            if(-f $destfile) {
                $progress->( ".. processing rmauth $author $name (cleaning JSON file)" )     if(defined $progress);
                my $data  = read_file($destfile);
                $progress->( ".. processing rmauth $author $name (read JSON file)" )     if(defined $progress);
                my $store;
                eval { $store = decode_json($data) };
                $progress->( ".. processing rmauth $author $name (decoded JSON data)" )     if(defined $progress);
                if(!$@ && $store) {
                    for my $row (@$store) {
                        next    if($requests{$row->{id}});                      # filter out requests

                        push @reports, $row;
                    }
                }
                overwrite_file( $destfile, _make_json( \@reports ) );
            }

            # clean the summary, if we have one
            my @summary = $dbi->GetQuery('hash','GetAuthorSummary',$author);
            if(@summary) {
                $progress->( ".. processing rmauth $author $name (cleaning summary) " . scalar(@summary) . ' ' . ($summary[0] && $summary[0]->{dataset} ? 'true' : 'false') )     if(defined $progress);
                my $dataset = decode_json($summary[0]->{dataset});
                $progress->( ".. processing rmauth $author $name (decoded JSON summary)" )     if(defined $progress);

                for my $data ( @{ $dataset->{distributions} } ) {
                    my $dist = $data->{dist};
                    my $summ = $data->{summary};

                    next    unless($remove{$dist});

                    for my $state (keys %{ $remove{$dist} }) {
                        $summ->{ $state } -= $remove{$dist}{$state};
                        $summ->{ 'ALL'  } -= $remove{$dist}{$state};
                    }
                }

                $dbi->DoQuery('UpdateAuthorSummary',$summary[0]->{lastid},encode_json($dataset),$author);
            }

            # push in author queue to rebuild pages
            $dbi->DoQuery('PushAuthor',$author);
        } catch {
            $progress->( ".. failed rmauth $author $name (catch block)" )     if(defined $progress);
            $fail = 1;
        };
    }

    return 0 if($fail);

    # remove requests
    $dbi->DoQuery('DeletePageRequests',{ids => join(',',@ids)},'rmauth',$name);

    return scalar(@ids);
}

sub RemoveDistroPages {
    my ($cpan,$dbi,$progress,$name) = @_;

    # get ids from the page requests
    my @requests = $dbi->GetQuery('hash','GetRequestIDs',{names => $name},'rmdist');
    my %requests = map { $_->{id} => 1 } grep { $_->{id} } @requests;

    return  unless(keys %requests);
    push my @ids, keys %requests;

    my $exceptions = $cpan->exceptions;
    my $symlinks   = $cpan->symlinks;
    my $merged     = $cpan->merged;
    my $ignore     = $cpan->ignore;

    my @delete = ($name);
    if(   ( $name =~ /^[A-Za-z0-9][A-Za-z0-9\-_+.]*$/ && !$ignore->{$name} )
       || ( $exceptions && $name =~ /$exceptions/ ) ) {

        # Some distributions are known by multiple names. Rather than create
        # pages for each one, we try and merge them together into one.

        my $dist;
        if($symlinks->{$name}) {
            $name = $symlinks->{$name};
            $dist = join("','", @{$merged->{$name}});
            @delete = @{$merged->{$name}};
        } elsif($merged->{$name}) {