File Coverage

blib/lib/Labyrinth/Plugin/CPAN/Tester.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::Tester;
2              
3 2     2   8649 use strict;
  2         5  
  2         84  
4 2     2   10 use warnings;
  2         3  
  2         103  
5              
6 2     2   10 use vars qw($VERSION);
  2         13  
  2         113  
7             $VERSION = '0.14';
8              
9             =head1 NAME
10              
11             Labyrinth::Plugin::CPAN::Tester - Tester Plugin for CPAN Testers Admin website.
12              
13             =cut
14              
15             #----------------------------------------------------------------------------
16             # Libraries
17              
18 2     2   8 use base qw(Labyrinth::Plugin::Base);
  2         2  
  2         756  
19              
20             use Labyrinth::Audit;
21             use Labyrinth::DBUtils;
22             use Labyrinth::DTUtils;
23             use Labyrinth::Mailer;
24             use Labyrinth::MLUtils;
25             use Labyrinth::Session;
26             use Labyrinth::Support;
27             use Labyrinth::Users;
28             use Labyrinth::Variables;
29              
30             use Labyrinth::Plugin::CPAN;
31              
32             use Data::Dumper;
33             use Digest::SHA qw(sha1_hex);
34             use Time::Local;
35              
36             #----------------------------------------------------------------------------
37             # Variables
38              
39             my %date_fields = (
40             y => { type => 1, html => 1 },
41             m => { type => 1, html => 1 },
42             d => { type => 1, html => 1 },
43             );
44              
45             my (@date_man,@date_all);
46             for(keys %date_fields) {
47             push @date_man, $_ if($date_fields{$_}->{type});
48             push @date_all, $_;
49             }
50              
51             my %months = (
52             1 => 'January',
53             2 => 'February',
54             3 => 'March',
55             4 => 'April',
56             5 => 'May',
57             6 => 'June',
58             7 => 'July',
59             8 => 'August',
60             9 => 'September',
61             10 => 'October',
62             11 => 'November',
63             12 => 'December',
64             );
65              
66             # type: 0 = optional, 1 = mandatory
67             # html: 0 = none, 1 = text, 2 = textarea
68              
69             my %fields = (
70             nickname => { type => 0, html => 1 },
71             realname => { type => 1, html => 1 },
72             email => { type => 1, html => 1 },
73             );
74              
75             my (@mandatory,@allfields);
76             for(keys %fields) {
77             push @mandatory, $_ if($fields{$_}->{type});
78             push @allfields, $_;
79             }
80              
81             #----------------------------------------------------------------------------
82             # Public Interface Functions
83              
84             =head1 METHODS
85              
86             =over 4
87              
88             =item Browse
89              
90             List dates for which tester
91              
92             =item Reports
93              
94             List reports for given day
95              
96             =item Find
97              
98             Find a report by ID.
99              
100             =item List
101              
102             List marked reports
103              
104             =item Mark
105              
106             Request report removal
107              
108             =item Unmark
109              
110             Remove request report removal
111              
112             =item Delete
113              
114             Remove marked reports from the cpanstats reports listings.
115              
116             Note that reports are not truly deleted, they are merely filtered out of any
117             cpanstats reports processing.
118              
119             =item Dist
120              
121             List reports that the tester has submitted reports for.
122              
123             =back
124              
125             =cut
126              
127             sub Browse {
128             return unless RealmCheck('tester','admin');
129              
130             my $userid = $tvars{'loginid'};
131             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
132             #my @addrs = $dbi->GetQuery('hash','GetTesterAddressIndex',$userid);
133             #return unless(@addrs);
134              
135             #my $addrs = join('|', map {$_->{email}} @addrs);
136             #my $ids = join(',', map {$_->{id}} @addrs);
137              
138             my %dates;
139             my $cpan = Labyrinth::Plugin::CPAN->new();
140             my $dbx = $cpan->DBX('cpanstats');
141              
142             #my $dates = $dbx->Iterator('hash','XGetReportDates',{ids => $ids});
143             my $next = $dbx->Iterator('hash','GetReportDates',$userid);
144             while(my $row = $next->()) {
145             my ($y,$m,$d) = $row->{fulldate} =~ /(\d{4,4})(\d{2,2})(\d{2,2})/;
146             #$m = int($m);
147             $dates{$y}{year} = $y;
148             $dates{$y}{months}->{$m}{month} = $months{int($m)};
149             $dates{$y}{months}->{$m}{days}->{$d}{day} = int($d);
150             }
151              
152             LogDebug(Dumper(\%dates));
153              
154             my @y;
155             for my $y (sort {$b <=> $a } keys %dates) {
156             my @m;
157             for my $m ( sort {$b <=> $a } keys %{$dates{$y}{months}} ) {
158             my @d = sort {$a <=> $b } keys %{$dates{$y}{months}{$m}{days}};
159             push @m, {days => \@d, month => $months{int($m)}, mon => $m};
160             }
161             push @y, {months => \@m, year => $y};
162             }
163              
164             $tvars{data}{dates} = \@y if(@y);
165             #$tvars{data}{dates} = \%dates if(keys %dates);
166             }
167              
168             sub Reports {
169             return unless RealmCheck('tester','admin');
170              
171             for(keys %date_fields) {
172             if($date_fields{$_}->{html} == 1) { $cgiparams{$_} = CleanHTML($cgiparams{$_}); }
173             elsif($date_fields{$_}->{html} == 2) { $cgiparams{$_} = SafeHTML($cgiparams{$_}); }
174             }
175              
176             return if FieldCheck(\@date_all,\@date_man);
177              
178             my $userid = $tvars{'loginid'};
179             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
180             # my @addrs = $dbi->GetQuery('hash','GetTesterAddress',$userid);
181             # return unless(@addrs);
182              
183             # my $addrs = join('|', map {$_->{email}} @addrs);
184              
185             my $cpan = Labyrinth::Plugin::CPAN->new();
186             my $dbx = $cpan->DBX('cpanstats');
187             my $date = sprintf "%04d%02d%02d\%", $tvars{data}{y},$tvars{data}{m},$tvars{data}{d};
188             # my @rows = $dbx->GetQuery('hash','GetReportList',{addrs => $addrs},$date);
189             my @rows = $dbx->GetQuery('hash','GetReportList',$userid,$date);
190             for my $row (@rows) {
191             my @report = $dbx->GetQuery('hash','GetReport',$row->{id});
192             $row->{$_} = $report[0]->{$_} for(keys %{$report[0]});
193             my @author = $dbx->GetQuery('hash','GetAuthor',$report[0]->{dist},$report[0]->{version});
194             $row->{$_} = $author[0]->{$_} for(keys %{$author[0]});
195              
196             next unless($row->{fulldate});
197             $row->{fulldate} = _parse_date($row->{fulldate});
198             }
199             $tvars{data}{reports} = \@rows if(@rows);
200              
201             $date = timelocal(0,0,12,$tvars{data}{d},$tvars{data}{m}-1,$tvars{data}{y});
202             $tvars{data}{date} = formatDate(10,$date);
203             }
204              
205             sub Find {
206             return unless RealmCheck('tester','admin');
207             $tvars{searched} = 1;
208              
209             my $cpan = Labyrinth::Plugin::CPAN->new();
210             my $dbx = $cpan->DBX('cpanstats');
211             my @rows = $dbx->GetQuery('hash','FindReport',$cgiparams{guid});
212             if(@rows) {
213             $tvars{data}{reports} = \@rows;
214             SetCommand('tester-report');
215             }
216             }
217              
218             sub List {
219             return unless RealmCheck('tester','admin');
220             my $cpan = Labyrinth::Plugin::CPAN->new();
221             my $dbx = $cpan->DBX('cpanstats');
222             my @rows;
223              
224             if($tvars{realm} eq 'admin' && !$tvars{user}{tester}) {
225             @rows = $dbi->GetQuery('hash','ListAllMarkedReports');
226             } else {
227             my $userid = $tvars{'loginid'};
228             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
229             @rows = $dbi->GetQuery('hash','ListMarkedReports',$userid);
230             }
231              
232             for my $row (@rows) {
233             next unless($row->{fulldate});
234             $row->{fulldate} = _parse_date($row->{fulldate});
235             $row->{profile} = $cpan->GetTesterProfile($row->{guid},$row->{tester});
236             }
237              
238             $tvars{data}{reports} = \@rows if(@rows);
239             }
240              
241             sub Mark {
242             return unless RealmCheck('tester','admin');
243              
244             my @data;
245              
246             $tvars{body}{success} = 0;
247             $tvars{body}{result} = 'failed';
248              
249             my $cpan = Labyrinth::Plugin::CPAN->new();
250             my $dbx = $cpan->DBX('cpanstats');
251             my @rows = $dbx->GetQuery('hash','GetReports',{ids => join(',',CGIArray('DELETE'))});
252             for my $row (@rows) {
253             # now mark the report
254             $dbi->DoQuery('MarkReport',$row->{id},$row->{addressid},$row->{tester},$row->{author},time());
255             push @data, $row->{id};
256             }
257              
258             $tvars{body}{success} = 1;
259             $tvars{body}{result} = 'marked';
260             $tvars{body}{data} = join(',',@data);
261             $tvars{realm} = 'json';
262             }
263              
264             sub Unmark {
265             return unless RealmCheck('tester','admin');
266              
267             $tvars{body}{success} = 0;
268             $tvars{body}{result} = 'failed';
269              
270             my @ids = CGIArray('DELETE');
271             my $userid = $tvars{'loginid'};
272             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
273              
274             my $cpan = Labyrinth::Plugin::CPAN->new();
275             my $dbx = $cpan->DBX('cpanstats');
276             my @rows = $dbx->GetQuery('hash','GetReports',{ids => join(',',@ids)});
277              
278             my @data;
279             if($tvars{realm} eq 'admin' && !$tvars{user}{tester}) {
280             @data = @ids;
281             } else {
282             @data = grep {$_} map { my (undef,undef,$uid) = $cpan->FindTester($_->{tester}); $uid = $userid ? $_->{id} : 0 } @rows;
283             }
284              
285             # unmark the reports
286             $dbi->DoQuery('UnmarkTesterReports',{ids => join(',',@data)});
287              
288             $tvars{body}{success} = 1;
289             $tvars{body}{result} = 'unmarked';
290             $tvars{body}{data} = join(',',@data);
291             $tvars{realm} = 'json';
292              
293             # LogDebug("body=".Dumper($tvars{body}));
294             }
295              
296             sub Delete {
297             return unless RealmCheck('tester','admin');
298              
299             my @ids = CGIArray('DELETE');
300             my $userid = $tvars{'loginid'};
301             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
302              
303             my $cpan = Labyrinth::Plugin::CPAN->new();
304             my $dbx = $cpan->DBX('cpanstats');
305             my @rows = $dbx->GetQuery('hash','GetReports',{ids => join(',',@ids)});
306              
307             my @data;
308             if($tvars{realm} eq 'admin' && !$tvars{user}{tester}) {
309             @data = @ids;
310             } else {
311             @data = grep {$_} map { my (undef,undef,$uid) = $cpan->FindTester($_->{tester}); $uid = $userid ? $_->{id} : 0 } @rows;
312             }
313              
314             for my $row (@rows) {
315             next if($row->{type} == 3);
316             $dbx->DoQuery('UpdateGrade',3,$row->{id});
317              
318             # for the reports builder
319             $dbx->DoQuery('PageRequest','rmdist',$row->{dist},$row->{id});
320             $dbx->DoQuery('PageRequest','rmauth',$row->{dist},$row->{id});
321              
322             # for the statistics scripts
323             $dbx->DoQuery('DeleteReportHistory',$row->{id},$row->{state},$row->{postdate},$row->{dist},$row->{version},$row->{type},3);
324             }
325              
326             # remove marked reports
327             $dbi->DoQuery('UnmarkTesterReports',{ids => join(',',@data)});
328              
329             $tvars{body}{success} = 1;
330             $tvars{body}{result} = 'deleted';
331             $tvars{body}{data} = join(',',@data);
332             $tvars{realm} = 'json';
333             }
334              
335             sub Dist {
336             return unless RealmCheck('tester','admin');
337              
338             SetTester();
339              
340             $cgiparams{dist} =~ s/::/-/g;
341              
342             my $cpan = Labyrinth::Plugin::CPAN->new();
343             my $dbx = $cpan->DBX('cpanstats');
344             my @rows = $dbx->GetQuery('hash','FindDistro',$cgiparams{dist});
345             unless(@rows) {
346             SetCommand('tester-distro');
347             $tvars{errmess} = 'Sorry, no such distribution found. Please try again.';
348             return;
349             }
350              
351             my ($prev,$next,$order) = ('','','DESC');
352             @rows = $dbx->GetQuery('hash','ListReports2',{'prev'=>$prev,'next'=>$next,'order'=>$order},$cgiparams{userid},$cgiparams{dist});
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             $tvars{data}{reports} = \@rows;
359              
360             my @prev = $dbx->GetQuery('hash','CountReports2',{'prev'=>"AND x.guid > '$rows[0]->{guid}'"},$cgiparams{userid},$cgiparams{dist});
361             my @next = $dbx->GetQuery('hash','CountReports2',{'next'=>"AND x.guid < '$rows[-1]->{guid}'"},$cgiparams{userid},$cgiparams{dist});
362              
363             $tvars{pager}{prev} = $rows[0]->{guid} if(@prev && $prev[0]->{count} > 0);
364             $tvars{pager}{next} = $rows[-1]->{guid} if(@next && $next[-1]->{count} > 0);
365             }
366             }
367              
368             =head2 Tester Email Interface Methods
369              
370             =over 4
371              
372             =item CheckLock
373              
374             Checks whether the specified user account is currently locked.
375              
376             =item Lock
377              
378             Tester has just registered on the site, lock the user profile until email is
379             confirmed.
380              
381             =item UnLock
382              
383             Tester has clicked registration confirmation link, and logged in successfully,
384             unlock the user profile.
385              
386             =item Submit
387              
388             Tester has submitted an email address used to submit a test report. Save as
389             unconfirmed and send email confirmation.
390              
391             =item Email
392              
393             Send email to tester to confirm email address.
394              
395             =item Remove
396              
397             Remove registered email from this user profile.
398              
399             =item Confirm
400              
401             Tester has clicked the confirmation link, provide login to finalise
402             confirmation.
403              
404             =item Confirmed
405              
406             Tester has confirmed login, mark email as confirmed, and map email to
407             addressid.
408              
409             =item Verify
410              
411             Allow admin to verify and confirm a tester's email address.
412              
413             =item Verified
414              
415             List verified email addresses for specified tester.
416              
417             =back
418              
419             =cut
420              
421             sub CheckLock {
422             my $userid = $tvars{'loginid'};
423             my @row = $dbi->GetQuery('hash','GetUserByID',$userid);
424             return if(@row && !$row[0]->{locked});
425              
426             Labyrinth::Session::Logout();
427              
428             $tvars{redirect} = '';
429             SetCommand('tester-locked');
430             }
431              
432             sub Lock {
433             return unless RealmCheck('public','tester','admin');
434             my $userid = $cgiparams{'userid'};
435             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
436             $dbi->DoQuery('LockUser',$userid);
437             $dbi->DoQuery('SetRealm','tester',$userid);
438              
439             my $user = GetUser($userid);
440              
441             $tvars{data}{realname} = $user->{realname};
442             $tvars{data}{email} = $user->{email};
443             $tvars{data}{template} = 'mailer/user-confirm.eml';
444             }
445              
446             sub UnLock {
447             return unless RealmCheck('tester','admin','public');
448            
449             my $email;
450             my ($code,$userid) = split('/',$cgiparams{code});
451              
452             if($tvars{realm} eq 'admin' && $tvars{user}{tester}) {
453             $userid = $tvars{user}{tester};
454             $email = $cgiparams{confirm};
455             } else {
456             my @confirm = $dbi->GetQuery('hash','CheckConfirmedCode',$code);
457             return unless(@confirm && $confirm[0]->{userid} == $userid);
458             $email = $confirm[0]->{email};
459             }
460              
461             $dbi->DoQuery('UnLockUser',$userid);
462             $dbi->DoQuery('ConfirmedEmail',$userid,$email,$code);
463             }
464              
465             sub Submit {
466             return unless RealmCheck('tester','admin');
467             my $userid = $tvars{'loginid'};
468             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
469              
470             $cgiparams{'userid'} = $userid;
471              
472             $tvars{data}{realname} = UserName($userid);
473             $tvars{data}{email} = $cgiparams{email};
474             $tvars{data}{template} = 'mailer/tester-confirm.eml';
475             $tvars{thanks} = 1;
476             }
477              
478             sub Email {
479             return unless RealmCheck('public','tester','admin');
480              
481             my $userid = $cgiparams{userid};
482             my $code;
483              
484             my @email = $dbi->GetQuery('hash','CheckConfirmedEmail',$userid,$tvars{data}{'email'});
485             if(@email) {
486             $code = $email[0]->{confirm};
487             } else {
488             my $data = $tvars{data}{'email'} . $$ . time . 'ajfpfgjalkshj';
489             $code = sha1_hex($data);
490             $dbi->DoQuery('UnConfirmedEmail',$userid,$tvars{data}{'email'},$code);
491             }
492              
493             MailSend( template => $tvars{data}{'template'},
494             name => $tvars{data}{'realname'},
495             recipient_email => $tvars{data}{'email'},
496             code => "$code/$userid",
497             webpath => "$tvars{docroot}$tvars{webpath}",
498             nowrap => 1
499             );
500              
501             if(!MailSent()) {
502             $tvars{errcode} = 'BADMAIL';
503             }
504             }
505              
506             sub Remove {
507             return unless RealmCheck('tester','admin');
508              
509             return SetCommand('tester-verify') if($cgiparams{confirm});
510              
511             my $userid = $tvars{'loginid'};
512             $userid = $cgiparams{testerid} if($tvars{realm} eq 'admin' && $cgiparams{testerid});
513             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
514              
515             if($cgiparams{confirm} && $tvars{realm} eq 'admin') {
516             my $cpan = Labyrinth::Plugin::CPAN->new();
517             my $dbx = $cpan->DBX('cpanstats');
518             my @rows = $dbx->GetQuery('hash','FindAddresses',$cgiparams{confirm});
519             for(@rows) {
520             $dbi->DoQuery('MapAddresses',$userid,$_->{addressid});
521             }
522              
523             $dbi->DoQuery('ConfirmedEmail',$userid,$cgiparams{confirm});
524             return;
525             }
526              
527             my @mails = CGIArray('MAILS');
528             return unless @mails;
529              
530             $dbi->DoQuery('RemoveEmail',{mails => "'" . join("','",@mails) . "'"},$userid);
531             }
532              
533             sub Confirm {
534             my ($code,$userid) = split('/',$cgiparams{code});
535              
536             my @confirm = $dbi->GetQuery('hash','CheckConfirmedCode',$code);
537             return unless(@confirm && $confirm[0]->{userid} == $userid);
538            
539             return SetCommand('tester-unconfirmed') unless(@confirm && $confirm[0]->{userid} == $userid);
540              
541             # confirm this email
542             $dbi->DoQuery('ConfirmedEmail',$userid,$confirm[0]->{email},$code);
543              
544             # map emails to addresses
545             my $cpan = Labyrinth::Plugin::CPAN->new();
546             my $dbx = $cpan->DBX('cpanstats');
547             my @rows = $dbx->GetQuery('hash','FindAddresses',$confirm[0]->{email});
548             for(@rows) {
549             $dbi->DoQuery('MapAddresses',$userid,$_->{addressid});
550             }
551             }
552              
553             sub Confirmed {
554             return unless RealmCheck('tester');
555             $dbi->DoQuery('ConfirmedEmail',$tvars{'loginid'},$cgiparams{email},$cgiparams{code});
556             }
557              
558             sub Verify {
559             return unless RealmCheck('admin');
560             my $userid = $tvars{'loginid'};
561             $userid = $cgiparams{testerid} if($tvars{realm} eq 'admin' && $cgiparams{testerid});
562             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
563              
564             my @confirm = $dbi->GetQuery('hash','CheckConfirmedEmail',$userid,$cgiparams{confirm});
565             return unless(@confirm);
566              
567             $dbi->DoQuery('ConfirmedEmail',$userid,$cgiparams{confirm},$confirm[0]->{confirm});
568             }
569              
570             sub Verified {
571             return unless RealmCheck('tester','admin');
572             my $userid = $tvars{data}{'userid'} || $tvars{'loginid'};
573             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
574             my @rows = $dbi->GetQuery('hash','GetTesterAddress',$userid);
575             $tvars{data}{confirmed} = \@rows if(@rows);
576             }
577              
578             =head2 Admin Interface Methods
579              
580             =over 4
581              
582             =item Admin
583              
584             Prepare Admin login as tester.
585              
586             =item Imposter
587              
588             Allow Admin to login as named tester.
589              
590             =item Clear
591              
592             Clear Imposter status and return to Admin.
593              
594             =item Merge
595              
596             Merge Testers Profiles in testers database.
597              
598             =item Assign
599              
600             Assign tester addresses to a given profile in the testers database.
601              
602             =item Edit
603              
604             Edit Tester Profile in testers database.
605              
606             =back
607              
608             =cut
609              
610             sub Admin {
611             return unless RealmCheck('admin');
612             $tvars{where} = "AND u.realm='tester' AND u.userid > 3";
613             }
614              
615             sub Imposter {
616             return unless RealmCheck('admin');
617             UpdateSession('name' => 'imposter:' . $cgiparams{userid});
618             $tvars{user}{tester} = $cgiparams{userid};
619             }
620              
621             sub Clear {
622             return unless RealmCheck('admin');
623             UpdateSession('name' => 'Admin');
624             $tvars{user}{name} = 'Admin';
625             delete $tvars{user}{tester};
626             delete $tvars{user}{fakename};
627             }
628              
629             sub Merge {
630             return unless RealmCheck('admin');
631              
632             my $cpan = Labyrinth::Plugin::CPAN->new();
633             my $dbx = $cpan->DBX('cpanstats');
634              
635             $cgiparams{$_} ||= '' for(qw(remp rems merge));
636              
637             # list primaries
638             my (@ids,$ids);
639             if($cgiparams{primary}) {
640             @ids = ($cgiparams{primary});
641             } else {
642             @ids = grep {$_ ne "$cgiparams{remp}"} CGIArray('PRIMARY');
643             }
644             if(@ids) {
645             my $ids = join(",",@ids);
646             my @rows = $dbx->GetQuery('hash','ListTestersbyID',{ids=>$ids});
647             $tvars{primary} = \@rows if(@rows);
648             }
649             my %ids = map {$_ => 1} @ids, $cgiparams{rems};
650              
651             # list secondaries
652             @ids = grep {!$ids{$_}} CGIArray('SECONDARY');
653             if($cgiparams{secondary} && !$ids{$cgiparams{secondary}}) {
654             push @ids, $cgiparams{secondary};
655             }
656             if(@ids) {
657             my $ids = join(",",@ids);
658             my @rows = $dbx->GetQuery('hash','ListTestersbyID',{ids=>$ids});
659             $tvars{secondary} = \@rows if(@rows);
660             }
661              
662             if($cgiparams{merge} eq 'merge') {
663             my $ids = join(",",map {$_->{testerid}} @{$tvars{secondary}});
664             $dbx->DoQuery('MergeTesters',{ids=>$ids},$tvars{primary}[0]->{testerid});
665             $dbx->DoQuery('DeleteProfile',{ids=>$ids});
666             delete $tvars{secondary};
667             }
668              
669             # search for name, pause or email
670             if($cgiparams{name}) {
671             my @testers = $dbx->GetQuery('hash','FindTesters',"\%$cgiparams{name}\%","\%$cgiparams{name}\%","\%$cgiparams{name}\%");
672             $tvars{results} = \@testers if(@testers);
673             $tvars{search} = $cgiparams{name};
674             }
675             }
676              
677             sub Assign {
678             return unless RealmCheck('admin');
679              
680             my $cpan = Labyrinth::Plugin::CPAN->new();
681             my $dbx = $cpan->DBX('cpanstats');
682              
683             $cgiparams{$_} ||= '' for(qw(remp rems assign));
684              
685             # list primaries
686             my (@ids,$ids,%primary,%secondary);
687             if($cgiparams{primary}) {
688             @ids = ($cgiparams{primary});
689             } else {
690             @ids = grep {$_ ne "$cgiparams{remp}"} CGIArray('PRIMARY');
691             }
692             if(@ids) {
693             $primary{$_} = 1 for(@ids);
694             my $ids = join(",",@ids);
695             my @rows = $dbx->GetQuery('hash','ListTestersbyID',{ids=>$ids});
696             $tvars{primary} = \@rows if(@rows);
697             }
698             my %ids = map {$_ => 1} @ids, $cgiparams{rems};
699              
700             # list secondaries
701             @ids = grep {!$ids{$_}} CGIArray('SECONDARY');
702             if($cgiparams{secondary} && !$ids{$cgiparams{secondary}}) {
703             push @ids, $cgiparams{secondary};
704             }
705             if(@ids) {
706             $secondary{$_} = 1 for(@ids);
707             my $ids = join(",",@ids);
708             my @rows = $dbx->GetQuery('hash','ListAddressbyID',{ids=>$ids});
709             $tvars{secondary} = \@rows if(@rows);
710             }
711              
712             if($cgiparams{assign} eq 'assign') {
713             my $ids = join(",",map {$_->{addressid}} @{$tvars{secondary}});
714             $dbx->DoQuery('AssignTesters',{ids=>$ids},$tvars{primary}[0]->{testerid});
715             # delete $tvars{secondary};
716              
717             # reset secondary addresses
718             my @rows = $dbx->GetQuery('hash','ListAddressbyID',{ids=>$ids});
719             $tvars{secondary} = \@rows if(@rows);
720             }
721              
722             # search for name, pause or email
723             if($cgiparams{name}) {
724             my @rows = $dbx->GetQuery('hash','FindTesters',"\%$cgiparams{name}\%","\%$cgiparams{name}\%","\%$cgiparams{name}\%");
725             my @profiles = grep { ! $primary{$_->{testerid}} } @rows;
726             $tvars{profiles} = \@profiles if(@profiles);
727              
728             if($cgiparams{name} eq 'unassigned') {
729             @rows = $dbx->GetQuery('hash','FindAddressUnassigned');
730             } else {
731             @rows = $dbx->GetQuery('hash','FindAddress',"\%$cgiparams{name}\%");
732             }
733              
734             my @addresses = grep { ! $secondary{$_->{addressid}} } @rows;
735             $tvars{addresses} = \@addresses if(@addresses);
736             $tvars{search} = $cgiparams{name};
737             }
738             }
739              
740             sub Edit {
741             $tvars{body}{success} = 0;
742             $tvars{body}{result} = 'failed';
743              
744             #LogDebug("1.".$cgiparams{name});
745             #LogDebug("2.".join(' ', map {ord($_)} split(//,$cgiparams{name})));
746              
747             my $cpan = Labyrinth::Plugin::CPAN->new();
748             my $dbx = $cpan->DBX('cpanstats');
749              
750             if($cgiparams{testerid}) {
751             $dbx->DoQuery('UpdateProfile',$cgiparams{name},$cgiparams{pause},$cgiparams{testerid});
752             } else {
753             $dbx->DoQuery('CreateProfile',$cgiparams{name},$cgiparams{pause});
754             }
755              
756             $tvars{body}{success} = 1;
757             $tvars{body}{result} = 'saved';
758             $tvars{realm} = 'json';
759             }
760              
761             sub _parse_date {
762             my $date = shift;
763             my ($Y,$M,$D,$h,$m) = ($date =~ /(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/);
764             return $date unless($Y && $M && $D);
765              
766             $h ||= 0;
767             $m ||= 0;
768              
769             return sprintf "%02d/%02d/%04d %02d:%02d", $D,$M,$Y, $h,$m;
770             }
771              
772             =head2 Admin Interface Methods : Local Profiles
773              
774             =over 4
775              
776             =item SetTester
777              
778             Set the tester profile to be edited.
779              
780             =item RegisteredEmails
781              
782             Manage tester's registered emails.
783              
784             =item EditProfile
785              
786             Edit tester profile
787              
788             =item SaveProfile
789              
790             Save tester profile
791              
792             =item GetContact
793              
794             Retrieve the current contact address for the current user.
795              
796             =item SetContact
797              
798             Save contact address for te current user.
799              
800             =back
801              
802             =cut
803              
804             sub SetTester {
805             my $userid = $tvars{'loginid'};
806             $userid = $cgiparams{testerid} if($tvars{realm} eq 'admin' && $cgiparams{testerid});
807             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
808             $cgiparams{userid} = $userid;
809             }
810              
811             sub RegisteredEmails {
812             return unless RealmCheck('tester','admin');
813              
814             my $userid = $tvars{'loginid'};
815             $userid = $cgiparams{testerid} if($tvars{realm} eq 'admin' && $cgiparams{testerid});
816             $userid = $tvars{user}{tester} if($tvars{realm} eq 'admin' && $tvars{user}{tester});
817              
818             my @rows = $dbi->GetQuery('hash','RegisteredEmails',$userid);
819             $tvars{data}{confirmed} = \@rows if(@rows);
820             }
821              
822             sub EditProfile {
823             return unless RealmCheck('admin');
824              
825             $cgiparams{userid} = $tvars{user}{tester} or return;
826              
827             # return unless MasterCheck();
828             return unless AuthorCheck('GetUserByID','userid',ADMIN);
829              
830             $tvars{data}{admin} = Authorised(ADMIN);
831             }
832              
833             sub GetContact {
834             my ($row) = $dbi->GetQuery('hash','GetContact',$cgiparams{'userid'});
835             if($row && $row->{testerid}) {
836             $tvars{data}{contact} = $row->{contact};
837             $tvars{data}{testerid} = $row->{testerid};
838             }
839             }
840              
841             sub SaveProfile {
842             return unless RealmCheck('admin');
843              
844             $cgiparams{userid} = $tvars{user}{tester} or return;
845             return unless AuthorCheck('GetUserByID','userid',ADMIN);
846              
847             for(keys %fields) {
848             if($fields{$_}->{html} == 1) { $cgiparams{$_} = CleanHTML($cgiparams{$_}) }
849             elsif($fields{$_}->{html} == 2) { $cgiparams{$_} = CleanTags($cgiparams{$_}) }
850             elsif($fields{$_}->{html} == 3) { $cgiparams{$_} = CleanLink($cgiparams{$_}) }
851             }
852              
853             return if FieldCheck(\@allfields,\@mandatory);
854              
855             my @fields = ( $tvars{data}{'nickname'}, $tvars{data}{'realname'},
856             $tvars{data}{'email'}, 0
857             );
858              
859             $dbi->DoQuery('SaveUser',@fields,$cgiparams{'userid'});
860             }
861              
862             sub SetContact {
863             $dbi->DoQuery('SetContact',$cgiparams{'contact'},$cgiparams{'testerid'})
864             if($cgiparams{'contact'} && $cgiparams{'testerid'});
865             $dbi->DoQuery('UpdateProfile',$cgiparams{'realname'},$cgiparams{'nickname'},$cgiparams{'testerid'})
866             if($cgiparams{'realname'} && $cgiparams{'testerid'});
867             }
868              
869             1;
870              
871             __END__