File Coverage

blib/lib/WWW/AUR/Login.pm
Criterion Covered Total %
statement 28 105 26.6
branch 0 40 0.0
condition 0 8 0.0
subroutine 9 20 45.0
pod 2 4 50.0
total 39 177 22.0


line stmt bran cond sub pod time code
1             package WWW::AUR::Login;
2              
3 1     1   20580 use warnings 'FATAL' => 'all';
  1         2  
  1         52  
4 1     1   7 use strict;
  1         1  
  1         34  
5              
6 1     1   171014 use HTTP::Cookies qw();
  1         331115  
  1         29  
7 1     1   10 use Carp qw();
  1         2  
  1         18  
8              
9 1     1   887 use WWW::AUR::Maintainer qw();
  1         3  
  1         23  
10 1     1   6 use WWW::AUR::URI qw( pkg_uri pkgsubmit_uri );
  1         1  
  1         165  
11 1     1   5 use WWW::AUR qw( _category_index _useragent );
  1         2  
  1         1020  
12              
13             our @ISA = qw(WWW::AUR::Maintainer);
14              
15             my $COOKIE_NAME = 'AURSID';
16             my $BAD_LOGIN_MSG = 'Bad username or password.';
17             my $PKG_EXISTS_MSG = ( 'You are not allowed to overwrite the '
18             . '.*? package.' );
19             my $PKG_EXISTS_ERR = 'You tried to submit a package you do not own';
20             my $COMMADD_MSG = quotemeta 'Comment has been added.';
21              
22             my $PKGOUTPUT_MATCH = qr{

( [^<]+ )

}xms;
23              
24             sub _new_cookie_jar
25             {
26 0     0   0 my $jar = HTTP::Cookies->new();
27              
28 0         0 my ($domain, $port) = split /:/, $WWW::AUR::HOST;
29 0   0     0 $port ||= 443; # we use https for logins
30              
31             # This REALLY should take a hash as argument...
32 0         0 $jar->set_cookie( 0, 'AURLANG' => 'en', # version, key, val
33             '/', $domain, $port, # path, domain, port
34             0, 0, # path_spec, secure
35             0, 0, # maxage, discard
36             {} ); # rest
37              
38 0         0 return $jar;
39             }
40              
41             sub new
42             {
43 0     0 0 0 my $class = shift;
44              
45 0 0       0 Carp::croak 'You must supply a name and password as argument'
46             unless @_ >= 2;
47 0         0 my ($name, $password) = @_;
48              
49 0         0 my $ua = _useragent( 'cookie_jar' => _new_cookie_jar());
50 0         0 $ua->InitTLS;
51 0         0 my $resp = $ua->post( "https://$WWW::AUR::HOST/login",
52             [ user => $name, passwd => $password ] );
53              
54 0 0       0 Carp::croak 'Failed to login to AUR: bad username or password'
55             if $resp->content =~ /$BAD_LOGIN_MSG/;
56              
57 0 0       0 unless ( $resp->code == 302 ) {
58 0 0       0 Carp::croak 'Failed to login to AUR: ' . $resp->status_line
59             unless $resp->is_success;
60             }
61              
62 0         0 my $self = $class->SUPER::new( $name );
63 0         0 $self->{'useragent'} = $ua;
64 0 0       0 $self->{'sid'} = _sidcookie($ua)
65             or Carp::croak 'Failed to read session cookie from login';
66              
67 0         0 return $self;
68             }
69              
70             sub _sidcookie
71             {
72 0     0   0 my ($ua) = @_;
73 0         0 my $jar = $ua->cookie_jar;
74 0         0 my $sid;
75 0 0   0   0 $jar->scan(sub { $sid = $_[2] if($_[1] eq 'AURSID') });
  0         0  
76 0         0 return $sid;
77             }
78              
79             my %_PKG_ACTIONS = map { ( lc $_ => "do_$_" ) }
80             qw{ Adopt Disown Vote UnVote Notify UnNotify Flag UnFlag Delete };
81              
82             sub _do_pkg_action
83             {
84 0     0   0 my ($self, $act, $pkg, @params) = @_;
85              
86 0 0       0 Carp::croak 'Please provide a proper package ID/name/obj argument'
87             unless $pkg;
88              
89 0 0       0 my $action = $_PKG_ACTIONS{ $act }
90             or Carp::croak "$act is not a valid action for a package";
91              
92 0         0 my $id = _pkgid( $pkg );
93 0         0 my $ua = $self->{'useragent'};
94 0         0 my $uri = pkg_uri( 'https' => 1, 'ID' => $id );
95 0         0 my $resp = $ua->post( $uri, [ "IDs[$id]" => 1,
96             'ID' => $id,
97             'token' => $self->{'sid'},
98             $action => 1,
99             @params ] );
100              
101 0 0       0 Carp::croak 'Failed to send package action: ' . $resp->status_line
102             unless $resp->is_success;
103              
104 0         0 my ($pkgoutput) = $resp->content =~ /$PKGOUTPUT_MATCH/;
105 0 0       0 Carp::confess 'Failed to parse package action response'
106             unless $pkgoutput;
107              
108 0         0 return $pkgoutput;
109             }
110              
111             #---HELPER FUNCTION---
112             sub _pkgid
113             {
114 0     0   0 my $pkg = shift;
115              
116 0 0       0 if ( ! ref $pkg ) {
117 0 0       0 return $pkg if $pkg =~ /\A\d+\z/;
118              
119 0         0 require WWW::AUR::Package;
120 0         0 my $pkgobj = WWW::AUR::Package->new( $pkg );
121 0         0 return $pkgobj->id;
122             }
123              
124             Carp::croak 'You must provide a package name, id, or object'
125 0 0       0 unless eval { $pkg->isa( 'WWW::AUR::Package' ) };
  0         0  
126              
127 0         0 return $pkg->id;
128             }
129              
130             #---HELPER FUNCTION---
131             # If provided pkg is an object, call its name method, otherwise pass through.
132             sub _pkgdesc
133             {
134 0     0   0 my ($pkg) = @_;
135 0         0 my $name;
136 0 0       0 return $name if $name = eval { $pkg->name };
  0         0  
137 0         0 return $pkg;
138             }
139              
140             sub _def_action_method
141             {
142 8     8   10 my ($name, $goodmsg) = @_;
143            
144 1     1   6 no strict 'refs';
  1         2  
  1         712  
145 8         26 *{ $name } = sub {
146 0     0   0 my ($self, $pkg) = @_;
147              
148 0         0 my $txt = $self->_do_pkg_action( $name => $pkg );
149 0 0       0 unless ( $txt =~ /\A$goodmsg/ ) {
150 0         0 Carp::confess sprintf qq{%s action on "%s" failed:\n%s\n},
151             ucfirst $name, _pkgdesc( $pkg ), $txt;
152             }
153 0         0 return $txt;
154 8         36 };
155              
156 8         42 return;
157             }
158              
159             my %_ACTIONS = ( 'adopt' => 'The selected packages have been adopted.',
160             'disown' => 'The selected packages have been disowned.',
161              
162             'vote' => ( 'Your votes have been cast for the selected '
163             . 'packages.' ),
164             'unvote' => ( 'Your votes have been removed from the '
165             . 'selected packages.' ),
166              
167             'notify' => ( 'You have been added to the comment '
168             . 'notification list for' ),
169             'unnotify' => ( 'You have been removed from the comment '
170             . 'notification list for' ),
171              
172             'flag' => ( 'The selected packages have been flagged '
173             . 'out-of-date.' ),
174             'unflag' => 'The selected packages have been unflagged.',
175             );
176              
177             while ( my ($name, $goodmsg) = each %_ACTIONS ) {
178             _def_action_method( $name, $goodmsg );
179             }
180              
181             sub delete
182             {
183 0     0 1   my ($self, $pkg) = @_;
184              
185 0           my $txt = $self->_do_pkg_action( 'delete' => $pkg,
186             'confirm_Delete' => 1 );
187              
188 0 0         unless ( $txt =~ /\AThe selected packages have been deleted[.]/ ) {
189 0           my $msg = sprintf q{Failed to perform the delete action on }
190             . q{package "%s"}, _pkgdesc( $pkg );
191 0           Carp::croak $msg;
192             }
193              
194 0           return $txt;
195              
196             }
197              
198             sub upload
199             {
200 0     0 1   my ($self, $path, $catname) = @_;
201 0 0         unless ( -f $path ) {
202 0           Carp::croak "Given file path ($path) does not exist";
203             }
204              
205 0           my $catidx = _category_index( $catname );
206 0           my $form = [
207             'category' => $catidx,
208             'submit' => 'Upload',
209             'token' => $self->{'sid'},
210             'pkgsubmit' => 1,
211              
212             # The AUR does not use the provided filename or mimetype.
213             # Specify dummy values to prevent LWP from detecting them.
214             'pfile' => [ $path, 'ignored-filename', 'ignored-mimetype' ],
215             ];
216 0           my $resp = $self->{'useragent'}->post(
217             pkgsubmit_uri(),
218             'Content-Type' => 'form-data',
219             'Content' => $form
220             );
221              
222 0 0         Carp::croak $PKG_EXISTS_ERR if $resp->content =~ /$PKG_EXISTS_MSG/;
223 0           return;
224             }
225              
226             sub comment
227             {
228 0     0 0   my ($self, $pkg, $com) = @_;
229              
230 0 0 0       Carp::croak 'comment text cannot be empty' unless
231             ( defined $com && length $com );
232              
233 0           my $id = _pkgid($pkg);
234 0           my $ua = $self->{'useragent'};
235 0           my $uri = pkg_uri('https' => 1, 'ID' => $id); # GET & POST params... meh
236 0           my $prms = [ 'ID' => $id, 'comment' => $com, 'submit' => 'Submit',
237             'token' => $self->{'sid'}, ];
238 0           my $resp = $ua->post($uri, $prms);
239              
240 0 0 0       Carp::croak "failed to post comment to package #$id"
241             unless $resp->is_success && $resp->content =~ /$COMMADD_MSG/;
242              
243 0           return;
244             }
245              
246             # Create a nifty alias, to match the "My Packages" AUR link...
247             *my_packages = \&WWW::AUR::Maintainer::packages;
248              
249             1;
250