File Coverage

blib/lib/Labyrinth/Plugin/CPAN.pm
Criterion Covered Total %
statement 30 148 20.2
branch 0 66 0.0
condition 0 32 0.0
subroutine 10 20 50.0
pod 10 10 100.0
total 50 276 18.1


line stmt bran cond sub pod time code
1             package Labyrinth::Plugin::CPAN;
2              
3 6     6   1489583 use strict;
  6         16  
  6         161  
4 6     6   31 use warnings;
  6         12  
  6         302  
5              
6             our $VERSION = '3.55';
7              
8             =head1 NAME
9              
10             Labyrinth::Plugin::CPAN - CPAN Testers plugin for the Labyrinth framework
11              
12             =head1 DESCRIPTION
13              
14             Labyrinth is a Website Management Framework. This distribution enables Labyrinth
15             to manage access to the CPAN Testers databases and data about CPAN releases and
16             testers.
17              
18             =cut
19              
20             #----------------------------------------------------------------------------
21             # Libraries
22              
23 6     6   30 use base qw(Labyrinth::Plugin::Base);
  6         13  
  6         4971  
24 6     6   5637425 use base qw(Class::Accessor::Fast);
  6         15  
  6         4594  
25              
26 6     6   17777 use Labyrinth::Audit;
  6         14  
  6         1125  
27 6     6   37 use Labyrinth::DBUtils;
  6         15  
  6         140  
28 6     6   33 use Labyrinth::Variables;
  6         13  
  6         986  
29 6     6   36 use Labyrinth::Users;
  6         11  
  6         429  
30              
31 6     6   5023 use Email::Address;
  6         152854  
  6         366  
32 6     6   4948 use Sort::Versions;
  6         6807  
  6         11099  
33              
34             #----------------------------------------------------------------------------
35             # Variables
36              
37             my (%DBX,%TESTER,%TESTERS);
38              
39             #----------------------------------------------------------------------------
40             # Public Interface Functions
41              
42             __PACKAGE__->mk_accessors(qw( perls osnames exceptions symlinks merged ignore distindex ));
43              
44             =head1 METHODS
45              
46             =head1 General Methods
47              
48             =over 4
49              
50             =item DBX
51              
52             Creates a database connection to the cpanstats database.
53              
54             =item Configure
55              
56             Reads the CPAN configuration file and stores settings.
57              
58             =item GetTesterProfile
59              
60             Given the profile id of a tester, returns their credentials, if known.
61              
62             =item FindTester
63              
64             Given a tester string, determines who to record it as in the system.
65              
66             =item Rename
67              
68             Used by the preferences system to impersonate a user for administration
69             and/or purposes.
70              
71             =item OSName
72              
73             Given an operating system string, returns the values used in the system.
74              
75             =item DistIndex
76              
77             Given a distribution name and a version, returns the index value used by the
78             system.
79              
80             =item OnCPAN
81              
82             Given a distribution name and a version, returns whether stored on CPAN (1) or
83             not (0).
84              
85             =back
86              
87             =cut
88              
89             sub DBX {
90 0     0 1   my ($self,$prefix,$autocommit) = @_;
91 0   0       $autocommit ||= 0;
92              
93 0 0         return unless(defined $prefix);
94 0 0         return $DBX{$prefix.$autocommit} if(defined $DBX{$prefix.$autocommit});
95              
96 0           my %hash = map {$_ => $settings{"${prefix}_$_"}} grep {$settings{"${prefix}_$_"}} qw(dictionary driver database dbfile dbhost dbport dbuser dbpass);
  0            
  0            
97 0 0         return unless(%hash);
98              
99 0           $hash{$_} = $settings{$_} for(qw(logfile phrasebook));
100 0 0         $hash{autocommit} = $autocommit if($autocommit);
101              
102 0           $DBX{$prefix.$autocommit} = Labyrinth::DBUtils->new(\%hash);
103 0 0         die "Unable to connect to '$prefix' database\n" unless($DBX{$prefix.$autocommit});
104              
105 0           return $DBX{$prefix.$autocommit};
106             }
107              
108             sub Configure {
109 0     0 1   my $self = shift;
110 0           my $cfg;
111            
112             $cfg = Config::IniFiles->new( -file => $settings{cpan_config} )
113 0 0         if(-f $settings{cpan_config});
114              
115 0 0 0       if($cfg && $cfg->SectionExists('EXCEPTIONS')) {
116 0           my @values = $cfg->val('EXCEPTIONS','LIST');
117 0           $self->exceptions( join('|',@values) );
118             }
119              
120 0 0 0       if($cfg && $cfg->SectionExists('IGNORE')) {
121 0           my @values = $cfg->val('IGNORE','LIST');
122 0           my %IGNORE;
123 0           $IGNORE{$_} = 1 for(@values);
124 0           $self->ignore( \%IGNORE );
125             }
126              
127 0 0 0       if($cfg && $cfg->SectionExists('SYMLINKS')) {
128 0           my %SYMLINKS;
129 0           $SYMLINKS{$_} = $cfg->val('SYMLINKS',$_) for($cfg->Parameters('SYMLINKS'));
130 0           $self->symlinks( \%SYMLINKS );
131 0           my %MERGED;
132 0           push @{$MERGED{$SYMLINKS{$_}}}, $_ for(keys %SYMLINKS);
  0            
133 0           push @{$MERGED{$SYMLINKS{$_}}}, $SYMLINKS{$_} for(keys %SYMLINKS);
  0            
134 0           $self->merged( \%MERGED );
135             }
136              
137 0           my $OSNAMES = $self->osnames;
138 0           my @rows = $dbi->GetQuery('hash','AllOSNames');
139 0           for my $row (@rows) {
140 0           $OSNAMES->{lc $row->{osname}} = $row->{ostitle};
141             }
142 0           $self->osnames($OSNAMES);
143              
144 0           my $INDEX = {};
145 0           @rows = $dbi->GetQuery('hash','AllDistIndices');
146 0           for my $row (@rows) {
147 0           $INDEX->{$row->{dist}}{$row->{version}}{id} = $row->{uploadid};
148 0           $INDEX->{$row->{dist}}{$row->{version}}{type} = $row->{type};
149             }
150 0           $self->distindex($INDEX);
151             }
152              
153             #----------------------------------------------------------------------------
154             # Private Interface Functions
155              
156             sub GetTesterProfile {
157 0     0 1   my ($self,$guid,$addr) = @_;
158 0           my @rows;
159              
160 0 0         return unless($guid);
161 0 0         return $TESTERS{$guid} if($TESTERS{$guid});
162            
163             # check report mapping
164 0           @rows = $dbi->GetQuery('hash','GetTesterProfile',$guid);
165              
166             # check previous tester mapping
167 0 0 0       if(!@rows && $addr) {
168 0           @rows = $dbi->GetQuery('hash','FindTesterProfile',$addr);
169             }
170              
171 0 0         return unless(@rows);
172              
173 0 0         if($rows[0]->{name}) {
    0          
174 0           $rows[0]->{display} = $rows[0]->{name};
175 0 0         $rows[0]->{display} .= " ($rows[0]->{pause})" if($rows[0]->{pause});
176             } elsif($rows[0]->{email}) {
177 0           $rows[0]->{display} = $rows[0]->{email};
178             } else {
179 0           $rows[0]->{display} = $rows[0]->{address};
180             }
181            
182 0           $TESTERS{$guid} = $rows[0];
183 0           return $TESTERS{$guid};
184             }
185              
186             sub FindTester {
187 0     0 1   my ($self,$str) = @_;
188              
189 0           my ($addr) = Email::Address->parse($str);
190 0 0         return ('admin@cpantesters.org','CPAN Testers Admin',-1,0) unless($addr);
191 0           my $address = $addr->address;
192 0 0         return ('admin@cpantesters.org','CPAN Testers Admin',-1,0) unless($address);
193              
194 0 0         unless($TESTER{$address}) {
195 0           my @rows = $dbi->GetQuery('hash','FindTesterIndex',$address);
196 0 0         return ($address,'CPAN Tester',-1,0) unless(@rows);
197              
198 0           my @user = $dbi->GetQuery('hash','GetUserByID',$rows[0]->{userid});
199 0           $TESTER{$address}{userid} = $user[0]->{userid};
200 0           $TESTER{$address}{name} = $user[0]->{realname};
201 0   0       $TESTER{$address}{addressid} = $rows[0]->{addressid} || 0;
202             }
203              
204 0           return ($address,$TESTER{$address}{name},$TESTER{$address}{userid},$TESTER{$address}{addressid});
205             }
206              
207             sub Rename {
208 0     0 1   LogDebug("Rename: user=$tvars{user}{name}");
209 0 0         if($tvars{user}{name} =~ /pause:(\w+)/) {
    0          
    0          
210 0           $tvars{user}{author} = uc $1;
211 0           $tvars{user}{fakename} = $tvars{user}{author};
212 0           LogDebug("Rename: author=$tvars{user}{author}, fakename=$tvars{user}{fakename}");
213             } elsif($tvars{user}{name} =~ /imposter:(\d+)/) {
214 0           $tvars{user}{tester} = $1;
215 0           $tvars{user}{fakename} = UserName($tvars{user}{tester});
216 0           LogDebug("Rename: tester=$tvars{user}{tester}, fakename=$tvars{user}{fakename}");
217             } elsif($tvars{user}{name} =~ /imposter:([A-Z]+)/i) {
218 0           $tvars{user}{author} = uc $1;
219 0           $tvars{user}{fakename} = $tvars{user}{author};
220 0           LogDebug("Rename: author=$tvars{user}{author}, fakename=$tvars{user}{fakename}");
221             }
222             }
223              
224             sub OSName {
225 0     0 1   my ($self,$name) = @_;
226 0 0         return unless($name);
227              
228 0           my $code = lc $name;
229 0           $code =~ s/[^\w]+//g;
230 0           my $OSNAMES = $self->osnames;
231 0   0       return(($OSNAMES->{$code} || uc($name)), $code);
232             }
233              
234             sub DistIndex {
235 0     0 1   my ($self,$dist,$version) = @_;
236 0 0 0       return 0 unless(defined $dist && defined $version);
237              
238 0           my $INDEX = $self->distindex;
239 0   0       return $INDEX->{$dist}{$version}{id} || 0;
240             }
241              
242             sub OnCPAN {
243 0     0 1   my ($self,$dist,$version) = @_;
244 0 0 0       return unless(defined $dist && defined $version);
245              
246 0           my $INDEX = $self->distindex;
247 0   0       my $type = $INDEX->{$dist}{$version}{type} || undef;
248              
249 0 0         return 1 unless($type); # assume it's a new release
250 0 0         return 0 if($type eq 'backpan'); # on backpan only
251 0           return 1; # on cpan or new upload
252             }
253              
254             #----------------------------------------------------------------------------
255             # Private Interface Functions
256              
257             =head1 Private Methods
258              
259             =over 4
260              
261             =item check_oncpan
262              
263             Check whether a given distribution/version is on CPAN or in BACKPAN.
264              
265             =item mklist_perls
266              
267             Provides a list of the perl versions currently in the system.
268              
269             =back
270              
271             =cut
272              
273             sub check_oncpan {
274 0     0 1   my ($self,$dist,$vers) = @_;
275              
276 0           my @rows = $dbi->GetQuery('array','OnCPAN',$dist,$vers);
277 0 0         my $type = @rows ? $rows[0]->[0] : undef;
278              
279 0 0         return 1 unless($type); # assume it's a new release
280 0 0         return 0 if($type eq 'backpan'); # on backpan only
281 0           return 1; # on cpan or new upload
282             }
283              
284             sub mklist_perls {
285 0     0 1   my $self = shift;
286              
287 0           my @perls;
288 0           my $perls = $self->perls;
289 0 0         return $perls if($perls);
290              
291 0           my @rows = $dbi->GetQuery('array','GetPerls');
292              
293 0           for my $row (@rows) {
294 0 0 0       push @perls, $row->[0] if($row->[0] && $row->[0] !~ /patch|RC/i);
295             }
296              
297 0           @perls = sort { versioncmp($b,$a) } @perls;
  0            
298 0           $self->perls(\@perls);
299 0           return \@perls;
300             }
301              
302             1;
303              
304             __END__