line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package WWW::PAUSE::CleanUpHomeDir; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
254308
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
30
|
|
4
|
1
|
|
|
1
|
|
7
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
45
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = '0.004'; |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
7
|
use Carp; |
|
1
|
|
|
|
|
14
|
|
|
1
|
|
|
|
|
51
|
|
9
|
1
|
|
|
1
|
|
7
|
use URI; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
10
|
1
|
|
|
1
|
|
6
|
use WWW::Mechanize; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
21
|
|
11
|
1
|
|
|
1
|
|
5
|
use HTML::TokeParser::Simple; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
28
|
|
12
|
1
|
|
|
1
|
|
5
|
use File::Basename; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
63
|
|
13
|
1
|
|
|
1
|
|
7
|
use Devel::TakeHashArgs; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
54
|
|
14
|
1
|
|
|
1
|
|
6
|
use Sort::Versions; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
98
|
|
15
|
1
|
|
|
1
|
|
6
|
use base 'Class::Data::Accessor'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1810
|
|
16
|
|
|
|
|
|
|
__PACKAGE__->mk_classaccessors (qw( |
17
|
|
|
|
|
|
|
error |
18
|
|
|
|
|
|
|
last_list |
19
|
|
|
|
|
|
|
deleted_list |
20
|
|
|
|
|
|
|
_mech |
21
|
|
|
|
|
|
|
_is_use_http |
22
|
|
|
|
|
|
|
)); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub new { |
25
|
1
|
|
|
1
|
1
|
1002
|
my $self = bless {}, shift; |
26
|
|
|
|
|
|
|
|
27
|
1
|
|
|
|
|
8
|
my ( $login, $pass ) = splice @_, 0, 2; |
28
|
|
|
|
|
|
|
|
29
|
1
|
50
|
|
|
|
9
|
croak 'Missing mandatory PAUSE login argument' |
30
|
|
|
|
|
|
|
unless defined $login; |
31
|
|
|
|
|
|
|
|
32
|
1
|
50
|
|
|
|
6
|
croak 'Missing mandatory PAUSE password argument' |
33
|
|
|
|
|
|
|
unless defined $pass; |
34
|
|
|
|
|
|
|
|
35
|
1
|
50
|
|
|
|
13
|
get_args_as_hash(\@_, \ my %args, { timeout => 30 } ) |
36
|
|
|
|
|
|
|
or croak $@; |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
|
|
|
39
|
$self->_is_use_http( $args{use_http} ); |
39
|
1
|
|
|
|
|
38
|
$self->_mech( WWW::Mechanize->new( timeout => $args{timeout} ) ); |
40
|
1
|
|
|
|
|
19768
|
$self->_mech->credentials( $login, $pass ); |
41
|
|
|
|
|
|
|
|
42
|
1
|
|
|
|
|
28
|
return $self; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub fetch_list { |
46
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
47
|
|
|
|
|
|
|
|
48
|
0
|
|
|
|
|
|
$self->$_(undef) for qw(last_list error); |
49
|
|
|
|
|
|
|
|
50
|
0
|
0
|
|
|
|
|
my $uri = |
51
|
|
|
|
|
|
|
URI->new( |
52
|
|
|
|
|
|
|
($self->_is_use_http ? 'http' : 'https') |
53
|
|
|
|
|
|
|
. '://pause.perl.org/pause/authenquery?ACTION=delete_files' |
54
|
|
|
|
|
|
|
); |
55
|
|
|
|
|
|
|
|
56
|
0
|
|
|
|
|
|
my $mech = $self->_mech; |
57
|
0
|
|
|
|
|
|
my $response = $mech->get($uri); |
58
|
0
|
0
|
|
|
|
|
if ( $response->is_success ) { |
59
|
0
|
|
|
|
|
|
return $self->last_list( $self->_parse_list( $mech->content ) ); |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
else { |
62
|
0
|
|
|
|
|
|
return $self->_set_error( $response, 'net' ); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub list_scheduled { |
67
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
68
|
|
|
|
|
|
|
|
69
|
0
|
|
|
|
|
|
my $list_ref = $self->last_list; |
70
|
|
|
|
|
|
|
|
71
|
0
|
0
|
|
|
|
|
$list_ref = $self->fetch_list |
72
|
|
|
|
|
|
|
unless ref $list_ref eq 'HASH'; |
73
|
|
|
|
|
|
|
|
74
|
0
|
0
|
|
|
|
|
return unless defined $list_ref; |
75
|
|
|
|
|
|
|
|
76
|
0
|
|
|
|
|
|
my @scheduled_keys = grep { |
77
|
0
|
|
|
|
|
|
$list_ref->{$_}{status} =~ /Scheduled for deletion/ |
78
|
|
|
|
|
|
|
} keys %$list_ref; |
79
|
|
|
|
|
|
|
|
80
|
0
|
0
|
|
|
|
|
return sort @scheduled_keys |
81
|
|
|
|
|
|
|
if wantarray; |
82
|
|
|
|
|
|
|
|
83
|
0
|
|
|
|
|
|
return { map { $_ => $list_ref->{$_} } @scheduled_keys }; |
|
0
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
sub list_old { |
87
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
88
|
|
|
|
|
|
|
|
89
|
0
|
|
|
|
|
|
my $list_ref = $self->last_list; |
90
|
|
|
|
|
|
|
|
91
|
0
|
0
|
|
|
|
|
$list_ref = $self->fetch_list |
92
|
|
|
|
|
|
|
unless ref $list_ref eq 'HASH'; |
93
|
|
|
|
|
|
|
|
94
|
0
|
0
|
|
|
|
|
return unless defined $list_ref; |
95
|
|
|
|
|
|
|
|
96
|
0
|
|
|
|
|
|
my @suf = qw(.meta .readme .tar.gz .tgz .tar .gz .zip .bz2 .bz ); |
97
|
0
|
|
|
|
|
|
my $scheduled_re = qr/Scheduled for deletion/; |
98
|
0
|
|
|
|
|
|
my $extracted_re = qr/\.(?:readme|meta)$/; |
99
|
0
|
0
|
0
|
|
|
|
my %files = map { (fileparse $_, @suf )[0,2] } |
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
grep { |
101
|
0
|
|
|
|
|
|
$_ ne 'CHECKSUMS' |
102
|
|
|
|
|
|
|
and $_ !~ /$extracted_re/ |
103
|
|
|
|
|
|
|
and $list_ref->{$_}{status} !~ /$scheduled_re/ |
104
|
|
|
|
|
|
|
} keys %$list_ref; |
105
|
|
|
|
|
|
|
|
106
|
0
|
|
|
|
|
|
my @files = sort { |
107
|
0
|
|
|
|
|
|
my ($na, $va) = $a =~ /(.+)-(\d.+)/; |
108
|
0
|
|
|
|
|
|
my ($nb, $vb) = $b =~ /(.+)-(\d.+)/; |
109
|
0
|
0
|
|
|
|
|
$na cmp $nb || versioncmp($va, $vb); |
110
|
|
|
|
|
|
|
} keys %files; |
111
|
0
|
|
|
|
|
|
my @old; |
112
|
0
|
|
|
|
|
|
my $re = qr/([^.]+)-/; |
113
|
0
|
|
|
|
|
|
for ( 0 .. $#files-1) { |
114
|
0
|
|
|
|
|
|
my $name = ($files[ $_ ] =~ /$re/)[0]; |
115
|
0
|
|
|
|
|
|
my $next_name = ($files[ $_+1 ] =~ /$re/)[0]; |
116
|
|
|
|
|
|
|
next |
117
|
0
|
0
|
0
|
|
|
|
unless defined $name and defined $next_name; |
118
|
|
|
|
|
|
|
|
119
|
0
|
0
|
|
|
|
|
push @old, $files[$_] |
120
|
|
|
|
|
|
|
if $name eq $next_name; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
0
|
0
|
|
|
|
|
return sort @old |
124
|
|
|
|
|
|
|
if wantarray; |
125
|
|
|
|
|
|
|
|
126
|
0
|
|
|
|
|
|
return { map { $_ => $files{$_} } @old }; |
|
0
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub clean_up { |
130
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
131
|
0
|
|
|
|
|
|
my $only_these_ref = shift; |
132
|
|
|
|
|
|
|
|
133
|
0
|
|
|
|
|
|
$self->$_(undef) for qw(last_list deleted_list list_old); |
134
|
|
|
|
|
|
|
# make sure ->list_old reloads the page to avoid surprises with mech |
135
|
|
|
|
|
|
|
|
136
|
0
|
|
|
|
|
|
my $to_delete_ref = $self->list_old; |
137
|
0
|
0
|
0
|
|
|
|
if ( defined $only_these_ref and @$only_these_ref ) { |
138
|
0
|
|
|
|
|
|
$to_delete_ref = { |
139
|
0
|
|
|
|
|
|
map { $_ => $to_delete_ref->{$_} } |
140
|
|
|
|
|
|
|
@$only_these_ref |
141
|
|
|
|
|
|
|
}; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
0
|
|
|
|
|
|
my @files = map +("$_$to_delete_ref->{$_}", "$_.meta", "$_.readme"), |
145
|
|
|
|
|
|
|
sort keys %$to_delete_ref; |
146
|
|
|
|
|
|
|
|
147
|
0
|
0
|
|
|
|
|
return $self->_set_error('No files to delete') |
148
|
|
|
|
|
|
|
unless @files; |
149
|
|
|
|
|
|
|
|
150
|
0
|
|
|
|
|
|
my $mech = $self->_mech; |
151
|
0
|
|
|
|
|
|
$mech->form_number(1); # we already loaded the page from ->list_old |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
$mech->tick('pause99_delete_files_FILE', $_ ) |
154
|
0
|
|
|
|
|
|
for @files; |
155
|
|
|
|
|
|
|
|
156
|
0
|
|
|
|
|
|
my $response = $mech->click('SUBMIT_pause99_delete_files_delete'); |
157
|
|
|
|
|
|
|
|
158
|
0
|
0
|
|
|
|
|
if ( $response->is_success ) { |
159
|
0
|
|
|
|
|
|
$self->last_list(undef); # reset list again it's too old now |
160
|
|
|
|
|
|
|
|
161
|
0
|
|
|
|
|
|
return $self->deleted_list( \@files ); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
else { |
164
|
0
|
|
|
|
|
|
return $self->_set_error( $response, 'net' ); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub undelete { |
169
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
170
|
0
|
|
|
|
|
|
my $only_these_ref = shift; |
171
|
|
|
|
|
|
|
|
172
|
0
|
0
|
|
|
|
|
my @files = @{ $self->deleted_list || [] }; |
|
0
|
|
|
|
|
|
|
173
|
0
|
0
|
0
|
|
|
|
if ( defined $only_these_ref and @$only_these_ref ) { |
174
|
0
|
|
|
|
|
|
@files = @$only_these_ref; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
0
|
0
|
|
|
|
|
return $self->_set_error('No files to undelete') |
178
|
|
|
|
|
|
|
unless @files; |
179
|
|
|
|
|
|
|
|
180
|
0
|
0
|
|
|
|
|
my $uri = |
181
|
|
|
|
|
|
|
URI->new( |
182
|
|
|
|
|
|
|
($self->_is_use_http ? 'http' : 'https') |
183
|
|
|
|
|
|
|
. '://pause.perl.org/pause/authenquery?ACTION=delete_files' |
184
|
|
|
|
|
|
|
); |
185
|
|
|
|
|
|
|
|
186
|
0
|
|
|
|
|
|
my $mech = $self->_mech; |
187
|
0
|
|
|
|
|
|
my $response = $mech->get($uri); |
188
|
0
|
0
|
|
|
|
|
return $self->_set_error( $response, 'net' ) |
189
|
|
|
|
|
|
|
unless $mech->success; |
190
|
|
|
|
|
|
|
|
191
|
0
|
|
|
|
|
|
$mech->form_number(1); # we already loaded the page from ->list_old |
192
|
|
|
|
|
|
|
$mech->tick('pause99_delete_files_FILE', $_) |
193
|
0
|
|
|
|
|
|
for @files; |
194
|
|
|
|
|
|
|
|
195
|
0
|
|
|
|
|
|
$response = $mech->click('SUBMIT_pause99_delete_files_undelete'); |
196
|
|
|
|
|
|
|
|
197
|
0
|
0
|
|
|
|
|
if ( $response->is_success ) { |
198
|
0
|
|
|
|
|
|
$self->deleted_list(undef); # we successfully undeleted all these |
199
|
|
|
|
|
|
|
|
200
|
0
|
|
|
|
|
|
return \@files; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
else { |
203
|
0
|
|
|
|
|
|
return $self->_set_error( $response, 'net' ); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub _parse_list { |
208
|
0
|
|
|
0
|
|
|
my ( $self, $content ) = @_; |
209
|
|
|
|
|
|
|
|
210
|
0
|
|
|
|
|
|
my $parser = HTML::TokeParser::Simple->new( \$content ); |
211
|
|
|
|
|
|
|
|
212
|
0
|
|
|
|
|
|
my %data; |
213
|
|
|
|
|
|
|
my %nav; |
214
|
0
|
|
|
|
|
|
my $current_line = 0; |
215
|
0
|
|
|
|
|
|
@nav{ qw(level start get_text) } = (0) x 3; |
216
|
0
|
|
|
|
|
|
while ( my $t = $parser->get_token ) { |
217
|
0
|
0
|
0
|
|
|
|
if ( $t->is_start_tag('pre') ) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
218
|
0
|
|
|
|
|
|
@nav{ qw(level start) } = ( 1, 1 ); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
elsif ( $t->is_end_tag('pre') ) { |
221
|
0
|
|
|
|
|
|
@nav{ qw(level start is_success) } = ( 2, 0, 1); |
222
|
0
|
|
|
|
|
|
last; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
elsif ( $nav{start} == 1 and $t->is_start_tag('span') ) { |
225
|
0
|
|
|
|
|
|
$current_line = $t->get_attr('class'); |
226
|
0
|
|
|
|
|
|
@nav{ qw(level get_text) } = ( 3, 1 ); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
elsif ( $nav{get_text} == 1 and $t->is_text ) { |
229
|
0
|
0
|
|
|
|
|
if ( my ( $name, $size, $status ) = $t->as_is |
230
|
|
|
|
|
|
|
=~ /^\s*(\S+)\s+(\d+)\s+(.+)/s |
231
|
|
|
|
|
|
|
) { |
232
|
0
|
|
|
|
|
|
$data{$name} = { |
233
|
|
|
|
|
|
|
size => $size, |
234
|
|
|
|
|
|
|
status => $status, |
235
|
|
|
|
|
|
|
}; |
236
|
|
|
|
|
|
|
|
237
|
0
|
|
|
|
|
|
@nav{ qw(level get_text) } = ( 4, 0 ); |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
} |
241
|
0
|
0
|
|
|
|
|
croak "Parser error! (level: $nav{level}) Content: $content" |
242
|
|
|
|
|
|
|
unless $nav{is_success}; |
243
|
|
|
|
|
|
|
|
244
|
0
|
|
|
|
|
|
return \%data; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub _set_error { |
248
|
0
|
|
|
0
|
|
|
my ( $self, $error, $type ) = @_; |
249
|
0
|
0
|
0
|
|
|
|
if ( defined $type and $type eq 'net' ) { |
250
|
0
|
|
|
|
|
|
$self->error( 'Network error: ' . $error->status_line ); |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
else { |
253
|
0
|
|
|
|
|
|
$self->error( $error ); |
254
|
|
|
|
|
|
|
} |
255
|
0
|
|
|
|
|
|
return; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
1; |
259
|
|
|
|
|
|
|
__END__ |