File Coverage

blib/lib/Labyrinth/Plugin/CPAN/Author.pm
Criterion Covered Total %
statement 12 12 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 16 16 100.0


line stmt bran cond sub pod time code
1             package Labyrinth::Plugin::CPAN::Author;
2              
3 2     2   5444 use strict;
  2         3  
  2         111  
4 2     2   9 use warnings;
  2         2  
  2         107  
5              
6 2     2   9 use vars qw($VERSION);
  2         2  
  2         93  
7             $VERSION = '0.13';
8              
9             =head1 NAME
10              
11             Labyrinth::Plugin::CPAN::Author - Author Plugin for CPAN Testers Admin website.
12              
13             =cut
14              
15             #----------------------------------------------------------------------------
16             # Libraries
17              
18 2     2   7 use base qw(Labyrinth::Plugin::Base);
  2         3  
  2         781  
19              
20             use Labyrinth::Audit;
21             use Labyrinth::DTUtils;
22             use Labyrinth::MLUtils;
23             use Labyrinth::Mailer;
24             use Labyrinth::Session;
25             use Labyrinth::Support;
26             use Labyrinth::Variables;
27              
28             use Labyrinth::Plugin::CPAN;
29              
30             use Data::Dumper;
31             use LWP::UserAgent;
32             use MIME::Base64;
33             use Net::SSLeay qw(get_https make_headers);
34             use Sort::Versions;
35             use Time::Local;
36              
37             #----------------------------------------------------------------------------
38             # Variables
39              
40             my ($backpan,$oncpan);
41              
42             # The following distributions are considered exceptions from the norm and
43             # are to be added on a case by case basis.
44             my $EXCEPTIONS = 'Test.php|Net-ITE.pm|CGI.pm';
45              
46             my %date_fields = (
47             y => { type => 1, html => 1 },
48             m => { type => 1, html => 1 },
49             d => { type => 1, html => 1 },
50             );
51              
52             my (@date_man,@date_all);
53             for(keys %date_fields) {
54             push @date_man, $_ if($date_fields{$_}->{type});
55             push @date_all, $_;
56             }
57              
58             my %months = (
59             1 => 'January',
60             2 => 'February',
61             3 => 'March',
62             4 => 'April',
63             5 => 'May',
64             6 => 'June',
65             7 => 'July',
66             8 => 'August',
67             9 => 'September',
68             10 => 'October',
69             11 => 'November',
70             12 => 'December',
71             );
72              
73             #----------------------------------------------------------------------------
74             # Public Interface Functions
75              
76             =head1 METHODS
77              
78             =head2 Public Interface Methods
79              
80             =over 4
81              
82             =item Login
83              
84             Author Login mechanism. Uses the PAUSE authentication system.
85              
86             =item Logged
87              
88             Ensure correct user is logged in.
89              
90             =item Browse
91              
92             List authors dists which have reports.
93              
94             =item Distro
95              
96             List distributions released by the author.
97              
98             =item Dist
99              
100             List reports for the given distribution released by the author.
101              
102             =item Browser
103              
104             List dates for which author's distribution releases which have reports.
105              
106             =item Reports
107              
108             List reports for the given author's distribution releases.
109              
110             =item Testers
111              
112             List testers who have submitted reports for the author distributions.
113              
114             =item Tester
115              
116             List reports submitted by the given tester for the author distributions.
117              
118             =item Find
119              
120             Find a report by ID.
121              
122             =item Mark
123              
124             Request report removal
125              
126             =item Unmark
127              
128             Remove request report removal
129              
130             =item Marked
131              
132             List those reports the author has marked for removal.
133              
134             =back
135              
136             =cut
137              
138             sub Login {
139             my $result = LWP::UserAgent->new->get("https://pause.perl.org/pause/authenquery",
140             Authorization =>
141             'Basic ' . MIME::Base64::encode("$cgiparams{pause}:$cgiparams{eject}",'')
142             );
143              
144             if($result->code == 200) {
145             my @rows = $dbi->GetQuery('hash','CheckUser','PAUSE','PAUSE');
146              
147             # add entry to session table
148             my $session;
149             ( $session,
150             $tvars{user}{name},
151             $tvars{'loginid'},
152             $tvars{realm},
153             $tvars{langcode}
154             ) = Labyrinth::Session::_save_session(uc $cgiparams{pause},$rows[0]->{userid},$rows[0]->{realm},$rows[0]->{langcode});
155              
156             # set template variables
157             $tvars{'loggedin'} = 1;
158             $tvars{user}{folder} = 1;
159             $tvars{user}{option} = 0;
160             $tvars{user}{userid} = $tvars{'loginid'};
161             $tvars{user}{access} = VerifyUser($tvars{'loginid'});
162             $tvars{realm} ||= 'public';
163              
164             } else {
165             $tvars{errmess} = 'That username/password failed to be authenticated by PAUSE';
166             $tvars{errcode} = 'ERROR';
167             }
168             }
169              
170             sub Logged {
171             return unless RealmCheck('pause','admin');
172             }
173              
174             sub Browse {
175             return unless RealmCheck('pause','admin');
176              
177             my $author = $tvars{user}{name};
178             $author =~ s/^imposter://;
179              
180             # What distributions have been released by this author?
181             my $cpan = Labyrinth::Plugin::CPAN->new();
182             my $dbx = $cpan->DBX('cpanstats');
183             my @rows = $dbx->GetQuery('array','GetAuthorDists',$author);
184             my @dists = map {$_->[0]} @rows;
185              
186             my %dists;
187             for my $dist (@dists ) {
188             next unless($dist =~ /^[A-Za-z0-9][A-Za-z0-9\-_]*$/
189             || $dist =~ /$EXCEPTIONS/);
190             next if(defined $dists{$dist});
191             #print "... dist $dist\n";
192              
193             $dists{$dist} = 1;
194             }
195              
196             if(keys %dists) {
197             my @distros = sort keys %dists;
198             $tvars{data}{dists} = \@distros;
199             $tvars{hash}{dists} = \%dists;
200             }
201             }
202              
203             sub Distro {
204             return unless RealmCheck('pause','admin');
205              
206             my $author = $tvars{user}{name};
207             $author =~ s/^imposter://;
208              
209             my $cpan = Labyrinth::Plugin::CPAN->new();
210             my $dbx = $cpan->DBX('cpanstats');
211             my @rows = $dbx->GetQuery('hash','GetAuthorDists',$author);
212              
213             $tvars{data}{distros} = \@rows if(@rows);
214             }
215              
216             sub Dist {
217             return unless RealmCheck('pause','admin');
218              
219             my $dist = $cgiparams{dist};
220             my $version = $cgiparams{version};
221             my $author = $tvars{user}{name};
222             $author =~ s/^imposter://;
223              
224             my $cpan = Labyrinth::Plugin::CPAN->new();
225             my $dbx = $cpan->DBX('cpanstats');
226             my @rows = $dbx->GetQuery('array','GetAuthorDistVersions',$author,$dist);
227             my @versions = map {$_->[0]} @rows;
228              
229             my %versions = map {$_ => 1} @versions;
230             @versions = sort {versioncmp($b,$a)} keys %versions;
231             $version ||= $versions[0];
232              
233             $tvars{data}{distribution} = $dist;
234             $tvars{data}{version} = $version;
235             $tvars{data}{ddversions} = DropDownList($version,'version',@versions);
236              
237             @rows = $dbx->GetQuery('hash','GetAuthorReports',$dist,$version);
238             for my $row (@rows) {
239             next unless($row->{fulldate});
240             $row->{fulldate} = _parse_date($row->{fulldate});
241             $row->{profile} = $cpan->GetTesterProfile($row->{guid},$row->{tester});
242             }
243             $tvars{data}{reports} = \@rows if(@rows);
244             }
245              
246             sub Browser {
247             return unless RealmCheck('pause','admin');
248              
249             # get list of distributions for this author
250             Browse();
251             my $dists = "'" . join("','",@{$tvars{data}{dists}}) . "'";
252              
253             my %dates;
254             my $cpan = Labyrinth::Plugin::CPAN->new();
255             my $dbx = $cpan->DBX('cpanstats');
256             #my @dates = $dbx->GetQuery('hash','GetAuthorReportDates',{dists => $dists});
257             #for(@dates) {
258            
259             my $next = $dbx->Iterator('hash','GetAuthorReportDates',{dists => $dists});
260             while(my $row = $next->()) {
261             my ($y,$m,$d) = $row->{fulldate} =~ /(\d{4,4})(\d{2,2})(\d{2,2})/;
262             #$m = int($m);
263             $dates{$y}{year} = $y;
264             $dates{$y}{months}->{$m}{month} = $months{int($m)};
265             $dates{$y}{months}->{$m}{days}->{$d}{day} = int($d);
266             }
267              
268             #$tvars{data}{dates} = \%dates if(keys %dates);
269              
270             my @y;
271             for my $y (sort {$b <=> $a } keys %dates) {
272             my @m;
273             for my $m (sort {$b <=> $a } keys %{$dates{$y}{months}}) {
274             my @d = sort {$a <=> $b } keys %{$dates{$y}{months}{$m}{days}};
275             push @m, {days => \@d, month => $months{int($m)}, mon => $m};
276             }
277             push @y, {months => \@m, year => $y};
278             }
279              
280             $tvars{data}{dates} = \@y if(@y);
281             }
282              
283             sub Reports {
284             return unless RealmCheck('tester','admin');
285              
286             for(keys %date_fields) {
287             if($date_fields{$_}->{html} == 1) { $cgiparams{$_} = CleanHTML($cgiparams{$_}); }
288             elsif($date_fields{$_}->{html} == 2) { $cgiparams{$_} = SafeHTML($cgiparams{$_}); }
289             }
290              
291             return if FieldCheck(\@date_all,\@date_man);
292              
293             # get list of distributions for this author
294             Browse();
295             my $dists = "'" . join("','",@{$tvars{data}{dists}}) . "'";
296              
297             my $cpan = Labyrinth::Plugin::CPAN->new();
298             my $dbx = $cpan->DBX('cpanstats');
299             my $date = sprintf "%04d%02d%02d\%", $tvars{data}{y},$tvars{data}{m},$tvars{data}{d};
300             my @rows = $dbx->GetQuery('hash','GetAuthorReportList',{dists => $dists},$date);
301             for my $row (@rows) {
302             next unless($row->{fulldate});
303             $row->{fulldate} = _parse_date($row->{fulldate});
304             $row->{profile} = $cpan->GetTesterProfile($row->{guid},$row->{tester});
305             LogDebug("profile=".Dumper($row->{profile}));
306             }
307             $tvars{data}{reports} = \@rows if(@rows);
308              
309             $date = timelocal(0,0,12,$tvars{data}{d},$tvars{data}{m}-1,$tvars{data}{y});
310             $tvars{data}{date} = formatDate(10,$date);
311             }
312              
313             sub Testers {
314             return unless RealmCheck('pause','admin');
315              
316             my $letter = $cgiparams{letter} || 'A';
317              
318             my $cpan = Labyrinth::Plugin::CPAN->new();
319             my $dbx = $cpan->DBX('cpanstats');
320              
321             my @rows;
322             if($letter eq '9') {
323             @rows = $dbx->GetQuery('hash','ListTesters9');
324             } else {
325             @rows = $dbx->GetQuery('hash','ListTesters',{letter => $letter});
326             }
327              
328             $tvars{data}{testers} = \@rows if(@rows);
329             }
330              
331             sub Tester {
332             return unless RealmCheck('pause','admin');
333              
334             my $cpan = Labyrinth::Plugin::CPAN->new();
335             my $dbx = $cpan->DBX('cpanstats');
336              
337             my @tester = $dbx->GetQuery('hash','GetTesterByID',$cgiparams{testerid});
338             if(@tester) {
339             $tvars{data}{tester} = $tester[0];
340             $tvars{data}{letter} = uc substr($tester[0]->{name},0,1);
341             }
342              
343             my ($prev,$next,$order) = ('','','DESC');
344             if($cgiparams{'prev'}) {
345             $prev = "AND x.guid > '$cgiparams{prev}'";
346             $order = 'ASC';
347             } elsif($cgiparams{'next'}) {
348             $next = "AND x.guid < '$cgiparams{next}'";
349             $order = 'DESC';
350             }
351              
352             my @rows = $dbx->GetQuery('hash','ListReports',{'prev'=>$prev,'next'=>$next,'order'=>$order},$tvars{user}{author},$cgiparams{testerid});
353             if(@rows) {
354             for(@rows) {
355             my ($y,$m,$d) = $_->{fulldate} =~ /^(\d{4})(\d{2})(\d{2})/;
356             $_->{showdate} = sprintf "%04d-%02d-%02d", $y, $m, $d;
357             }
358             if($prev) {
359             my @revs = reverse @rows;
360             @rows = @revs;
361             }
362             $tvars{data}{reports} = \@rows;
363              
364             my @prev = $dbx->GetQuery('hash','CountReports',{'prev'=>"AND x.guid > '$rows[0]->{guid}'"},$cgiparams{testerid});
365             my @next = $dbx->GetQuery('hash','CountReports',{'next'=>"AND x.guid < '$rows[-1]->{guid}'"},$cgiparams{testerid});
366              
367             $tvars{pager}{prev} = $rows[0]->{guid} if(@prev && $prev[0]->{count} > 0);
368             $tvars{pager}{next} = $rows[-1]->{guid} if(@next && $next[-1]->{count} > 0);
369             }
370             }
371              
372             sub Find {
373             return unless RealmCheck('pause','admin');
374             $tvars{searched} = 1;
375              
376             my $cpan = Labyrinth::Plugin::CPAN->new();
377             my $dbx = $cpan->DBX('cpanstats');
378             my @rows = $dbx->GetQuery('hash','FindReport',$cgiparams{guid});
379             if(@rows) {
380             $tvars{data}{reports} = \@rows;
381             SetCommand('author-report');
382             }
383             }
384              
385             sub Mark {
386             return unless RealmCheck('pause','admin');
387              
388             $tvars{body}{success} = 0;
389             $tvars{body}{result} = 'failed';
390              
391             my $cpan = Labyrinth::Plugin::CPAN->new();
392             my $dbx = $cpan->DBX('cpanstats');
393             my @rows = $dbx->GetQuery('hash','GetReports',{ids => join(',',CGIArray('DELETE'))});
394              
395             # get list of distributions for this author
396             Browse();
397              
398             my $author = $tvars{user}{author};
399              
400             my (%done,@data);
401             for my $row (@rows) {
402             next unless($tvars{hash}{dists}{$row->{dist}});
403              
404             my ($email,$name,$userid,$addressid) = $cpan->FindTester($row->{tester});
405              
406             # mark the report
407             $dbi->DoQuery('MarkReport',$row->{id},$addressid,$email,$author,time());
408             push @data, $row->{id};
409              
410             # now email the tester to let them know
411             next if($done{mail}{$email});
412             next if($done{user}{$userid});
413             $done{mail}{$email} = 1;
414              
415             if($userid > 0) {
416             $done{user}{$userid} = 1;
417              
418             # send mail to tester
419             MailSend( template => 'mailer/marked.eml',
420             name => $name,
421             recipient_email => $email
422             );
423              
424             if(!MailSent()) {
425             $tvars{body}{errcode} = 'BADMAIL';
426             }
427             }
428             }
429              
430             $tvars{body}{success} = 1;
431             $tvars{body}{result} = 'marked';
432             $tvars{body}{data} = join(',',@data);
433             $tvars{realm} = 'json';
434              
435             LogDebug("body=".Dumper($tvars{body}));
436              
437             }
438              
439             sub Unmark {
440             return unless RealmCheck('pause','admin');
441              
442             $tvars{body}{success} = 0;
443             $tvars{body}{result} = 'failed';
444              
445             my $cpan = Labyrinth::Plugin::CPAN->new();
446             my $dbx = $cpan->DBX('cpanstats');
447             my @rows = $dbx->GetQuery('hash','GetReports',{ids => join(',',CGIArray('DELETE'))});
448             my @data = map {$_->{id}} @rows;
449              
450             my $author = $tvars{user}{author};
451              
452             # unmark the reports
453             $dbi->DoQuery('UnmarkAuthorReports',{ids => join(',',@data)},$author);
454              
455             $tvars{body}{success} = 1;
456             $tvars{body}{result} = 'unmarked';
457             $tvars{body}{data} = join(',',@data);
458             $tvars{realm} = 'json';
459              
460             # LogDebug("body=".Dumper($tvars{body}));
461             }
462              
463             sub Marked {
464             return unless RealmCheck('pause','admin');
465             my $cpan = Labyrinth::Plugin::CPAN->new();
466             my $dbx = $cpan->DBX('cpanstats');
467             my @rows;
468              
469             if($tvars{realm} eq 'admin' && !$tvars{user}{author}) {
470             @rows = $dbi->GetQuery('hash','ListAllMarkedReports');
471             } else {
472             my $userid = $tvars{'loginid'};
473             $userid = $tvars{user}{author} if($tvars{realm} eq 'admin' && $tvars{user}{author});
474             @rows = $dbi->GetQuery('hash','ListMarkedAuthorReports',$userid);
475             }
476              
477             for my $row (@rows) {
478             next unless($row->{fulldate});
479             $row->{fulldate} = _parse_date($row->{fulldate});
480             $row->{profile} = $cpan->GetTesterProfile($row->{guid},$row->{tester});
481             }
482              
483             $tvars{data}{reports} = \@rows if(@rows);
484             }
485              
486             =head2 Admin Interface Methods
487              
488             =over 4
489              
490             =item Admin
491              
492             Prepare Admin login as author.
493              
494             =item Imposter
495              
496             Clear Imposter status and return to Admin.
497              
498             =item Clear
499              
500             Return admin to normal admin state.
501              
502             =back
503              
504             =cut
505              
506             sub Admin {
507             return unless RealmCheck('admin');
508             $tvars{where} = "AND u.realm='author' AND u.userid > 3";
509             }
510              
511             sub Imposter {
512             return unless RealmCheck('admin');
513             UpdateSession('name' => 'imposter:' . $cgiparams{pause});
514             $tvars{user}{author} = $cgiparams{pause};
515             }
516              
517             sub Clear {
518             return unless RealmCheck('admin');
519             UpdateSession('name' => 'Admin');
520             $tvars{user}{name} = 'Admin';
521             delete $tvars{user}{author};
522             delete $tvars{user}{fakename};
523             }
524              
525             sub _parse_date {
526             my $date = shift;
527             my ($Y,$M,$D,$h,$m) = ($date =~ /(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/);
528             return $date unless($Y && $M && $D);
529              
530             $h ||= 0;
531             $m ||= 0;
532              
533             return sprintf "%02d/%02d/%04d %02d:%02d", $D,$M,$Y, $h,$m;
534             }
535              
536             1;
537              
538             __END__