File Coverage

blib/lib/WWW/PAUSE/CleanUpHomeDir.pm

Criterion	Covered	Total	%
statement	39	137	28.4
branch	3	62	4.8
condition	0	24	0.0
subroutine	11	18	61.1
pod	6	6	100.0
total	59	247	23.8

package WWW::PAUSE::CleanUpHomeDir;

use warnings;
use strict;

our $VERSION = '1.001001'; # VERSION

use Carp;
use URI;
use WWW::Mechanize;
use HTML::TokeParser::Simple;
use File::Basename;
use Devel::TakeHashArgs;
use Sort::Versions;
use base 'Class::Accessor::Grouped';
__PACKAGE__->mk_group_accessors(simple => qw(
    error
    last_list
    deleted_list
    _mech
    _is_use_http
));

sub new {
    my $self = bless {}, shift;

    my ( $login, $pass ) = splice @_, 0, 2;

    croak 'Missing mandatory PAUSE login argument'
        unless defined $login;

    croak 'Missing mandatory PAUSE password argument'
        unless defined $pass;

    get_args_as_hash(\@_, \ my %args, { timeout => 30 } )
        or croak $@;

    $self->_is_use_http( $args{use_http} );
    $self->_mech( WWW::Mechanize->new( timeout => $args{timeout} ) );
    $self->_mech->credentials( $login, $pass );

    return $self;
}

sub fetch_list {
    my $self = shift;

    $self->$_(undef) for qw(last_list error);

    my $uri =
    URI->new(
        ($self->_is_use_http ? 'http' : 'https')
            . '://pause.perl.org/pause/authenquery?ACTION=delete_files'
    );

    my $mech = $self->_mech;
    my $response = $mech->get($uri);
    if ( $response->is_success ) {
        return $self->last_list( $self->_parse_list( $mech->content ) );
    }
    else {
        return $self->_set_error( $response, 'net' );
    }
}

sub list_scheduled {
    my $self = shift;

    my $list_ref = $self->last_list;

    $list_ref = $self->fetch_list
        unless ref $list_ref eq 'HASH';

    return unless defined $list_ref;

    my @scheduled_keys = grep {
        $list_ref->{$_}{status} =~ /Scheduled for deletion/
    } keys %$list_ref;

    return sort @scheduled_keys
        if wantarray;

    return { map { $_ => $list_ref->{$_} } @scheduled_keys };
}

sub list_old {
    my $self = shift;

    my $list_ref = $self->last_list;

    $list_ref = $self->fetch_list
        unless ref $list_ref eq 'HASH';

    return unless defined $list_ref;

    my @suf = qw(.meta .readme .tar.gz .tgz .tar .gz .zip .bz2 .bz );
    my $scheduled_re = qr/Scheduled for deletion/;
    my $extracted_re = qr/\.(?:readme|meta)$/;
    my %files = map { (fileparse $_, @suf )[0,2] }
                    grep {
                        $_ ne 'CHECKSUMS'
                        and $_ !~ /$extracted_re/
                        and $list_ref->{$_}{status} !~ /$scheduled_re/
                    } keys %$list_ref;

    my @files = sort {
        my ($na, $va) = $a =~ /(.+)-(\d.+)/;
        my ($nb, $vb) = $b =~ /(.+)-(\d.+)/;
        $na cmp $nb || versioncmp($va, $vb);
    } grep !/
        -(?!.*-)  # last dash in the filename
        .*(TRIAL|_) # trial versions
    /x, keys %files;

    my @old;
    my $re = qr/([^.]+)-/;
    for ( 0 .. $#files-1) {
        my $name      = ($files[ $_   ] =~ /$re/)[0];
        my $next_name = ($files[ $_+1 ] =~ /$re/)[0];
        next
            unless ( defined $name and defined $next_name )
                or $next_name =~ /
                    -(?!.*-)  # last dash in the filename
                    .*(TRIAL|_) # trial versions
                /x;

        push @old, $files[$_]
            if $name eq $next_name;
    }

    return sort @old
        if wantarray;

    return { map { $_ => $files{$_} } @old  };
}

sub clean_up {
    my $self = shift;
    my $only_these_ref = shift;

    $self->$_(undef) for qw(last_list deleted_list list_old);
    # make sure ->list_old reloads the page to avoid surprises with mech

    my $to_delete_ref = $self->list_old;
    if ( defined $only_these_ref and @$only_these_ref ) {
        $to_delete_ref = {
            map { $_ => $to_delete_ref->{$_} }
                @$only_these_ref
        };
    }

    my @files = map +("$_$to_delete_ref->{$_}", "$_.meta", "$_.readme"),
                    sort keys %$to_delete_ref;

    return $self->_set_error('No files to delete')
        unless @files;

    my $mech = $self->_mech;
    $mech->form_number(1); # we already loaded the page from ->list_old

    $mech->tick('pause99_delete_files_FILE', $_ )
        for @files;

    my $response = $mech->click('SUBMIT_pause99_delete_files_delete');

    if ( $response->is_success ) {
        $self->last_list(undef); # reset list again it's too old now

        return $self->deleted_list( \@files );
    }
    else {
        return $self->_set_error( $response, 'net' );
    }
}

sub undelete {
    my $self = shift;
    my $only_these_ref = shift;

    my @files = @{ $self->deleted_list || [] };
    if ( defined $only_these_ref and @$only_these_ref ) {
        @files = @$only_these_ref;
    }

    return $self->_set_error('No files to undelete')
        unless @files;

    my $uri =
    URI->new(
        ($self->_is_use_http ? 'http' : 'https')
            . '://pause.perl.org/pause/authenquery?ACTION=delete_files'
    );

    my $mech = $self->_mech;
    my $response = $mech->get($uri);
    return $self->_set_error( $response, 'net' )
        unless $mech->success;

    $mech->form_number(1); # we already loaded the page from ->list_old
    $mech->tick('pause99_delete_files_FILE', $_)
        for @files;

    $response = $mech->click('SUBMIT_pause99_delete_files_undelete');

    if ( $response->is_success ) {
        $self->deleted_list(undef); # we successfully undeleted all these

        return \@files;
    }
    else {
        return $self->_set_error( $response, 'net' );
    }
}

sub _parse_list {
    my ( $self, $content ) = @_;

    my $parser = HTML::TokeParser::Simple->new( \$content );

    my %data;
    my %nav;
    my $current_line = 0;
    @nav{ qw(level start get_text) } = (0) x 3;
    while ( my $t = $parser->get_token ) {
        if ( $t->is_start_tag('pre') ) {
            @nav{ qw(level start) } = ( 1, 1 );
        }
        elsif ( $t->is_end_tag('pre') ) {
            @nav{ qw(level start is_success) } = ( 2, 0, 1);
            last;
        }
        elsif ( $nav{start} == 1 and $t->is_start_tag('span') ) {
            $current_line = $t->get_attr('class');
            @nav{ qw(level get_text) } = ( 3, 1 );
        }
        elsif ( $nav{get_text} == 1 and $t->is_text ) {
            if ( my ( $name, $size, $status ) = $t->as_is
                    =~ /^\s*(\S+)\s+(\d+)\s+(.+)/s
            ) {
                $data{$name} = {
                    size    => $size,
                    status  => $status,
                };

                @nav{ qw(level get_text) } = ( 4, 0 );
            }
        }
    }
    croak "Parser error! (level: $nav{level}) Content: $content"
        unless $nav{is_success};

    return \%data;
}

sub _set_error {
    my ( $self, $error, $type ) = @_;
    if ( defined $type and $type eq 'net' ) {
        $self->error( 'Network error: ' . $error->status_line );
    }
    else {
        $self->error( $error );
    }
    return;
}

1;
__END__