our
$VERSION
=
'3.50'
;
my
(
%DBX
,
%TESTER
,
%TESTERS
);
__PACKAGE__->mk_accessors(
qw( perls osnames exceptions symlinks merged ignore )
);
sub
DBX {
my
(
$self
,
$prefix
,
$autocommit
) =
@_
;
if
(
defined
$prefix
) {
return
$DBX
{
$prefix
}
if
(
defined
$DBX
{
$prefix
});
my
%hash
=
map
{
$_
=>
$settings
{
"${prefix}_$_"
}}
qw(dictionary driver database dbfile dbhost dbport dbuser dbpass)
;
$hash
{
$_
} =
$settings
{
$_
}
for
(
qw(logfile phrasebook)
);
$hash
{autocommit} =
$autocommit
if
(
$autocommit
);
$DBX
{
$prefix
} = Labyrinth::DBUtils->new(\
%hash
);
die
"Unable to connect to '$prefix' database\n"
unless
(
$DBX
{
$prefix
});
return
$DBX
{
$prefix
};
}
}
sub
Configure {
my
$self
=
shift
;
my
$cfg
= Config::IniFiles->new(
-file
=>
$settings
{cpan_config} );
if
(
$cfg
->SectionExists(
'EXCEPTIONS'
)) {
my
@values
=
$cfg
->val(
'EXCEPTIONS'
,
'LIST'
);
$self
->exceptions(
join
(
'|'
,
@values
) );
}
if
(
$cfg
->SectionExists(
'IGNORE'
)) {
my
@values
=
$cfg
->val(
'IGNORE'
,
'LIST'
);
my
%IGNORE
;
$IGNORE
{
$_
} = 1
for
(
@values
);
$self
->ignore( \
%IGNORE
);
}
if
(
$cfg
->SectionExists(
'SYMLINKS'
)) {
my
%SYMLINKS
;
$SYMLINKS
{
$_
} =
$cfg
->val(
'SYMLINKS'
,
$_
)
for
(
$cfg
->Parameters(
'SYMLINKS'
));
$self
->symlinks( \
%SYMLINKS
);
my
%MERGED
;
push
@{
$MERGED
{
$SYMLINKS
{
$_
}}},
$_
for
(
keys
%SYMLINKS
);
push
@{
$MERGED
{
$SYMLINKS
{
$_
}}},
$SYMLINKS
{
$_
}
for
(
keys
%SYMLINKS
);
$self
->merged( \
%MERGED
);
}
my
$OSNAMES
=
$self
->osnames;
my
@rows
=
$dbi
->GetQuery(
'hash'
,
'AllOSNames'
);
for
my
$row
(
@rows
) {
$OSNAMES
->{
lc
$row
->{osname}} =
$row
->{ostitle};
}
$self
->osnames(
$OSNAMES
);
}
sub
GetTesterProfile {
my
(
$self
,
$guid
,
$addr
) =
@_
;
return
$TESTERS
{
$guid
}
if
(
$TESTERS
{
$guid
});
my
@rows
=
$dbi
->GetQuery(
'hash'
,
'GetTesterProfile'
,
$guid
);
if
(!
@rows
&&
$addr
) {
@rows
=
$dbi
->GetQuery(
'hash'
,
'FindTesterProfile'
,
$addr
);
}
return
unless
(
@rows
);
if
(
$rows
[0]->{name}) {
$rows
[0]->{display} =
$rows
[0]->{name};
$rows
[0]->{display} .=
" ($rows[0]->{pause})"
if
(
$rows
[0]->{pause});
}
elsif
(
$rows
[0]->{email}) {
$rows
[0]->{display} =
$rows
[0]->{email};
}
else
{
$rows
[0]->{display} =
$rows
[0]->{address};
}
$TESTERS
{
$guid
} =
$rows
[0];
return
$TESTERS
{
$guid
};
}
sub
FindTester {
my
$str
=
shift
;
my
(
$addr
) = Email::Address->parse(
$str
);
return
(
'admin@cpantesters.org'
,
'CPAN Testers Admin'
,-1,0)
unless
(
$addr
);
my
$address
=
$addr
->address;
return
(
'admin@cpantesters.org'
,
'CPAN Testers Admin'
,-1,0)
unless
(
$address
);
unless
(
$TESTER
{
$address
}) {
my
@rows
=
$dbi
->GetQuery(
'hash'
,
'FindTesterIndex'
,
$address
);
return
(
$address
,
'CPAN Tester'
,-1,0)
unless
(
@rows
);
my
@user
=
$dbi
->GetQuery(
'hash'
,
'GetUserByID'
,
$rows
[0]->{userid});
$TESTER
{
$address
}{userid} =
$user
[0]->{userid};
$TESTER
{
$address
}{name} =
$user
[0]->{realname};
$TESTER
{
$address
}{addressid} =
$user
[0]->{addressid} || 0;
}
return
(
$address
,
$TESTER
{
$address
}{name},
$TESTER
{
$address
}{userid},
$TESTER
{
$address
}{addressid});
}
sub
Rename {
LogDebug(
"Rename: user=$tvars{user}{name}"
);
if
(
$tvars
{user}{name} =~ /pause:(\d+)/) {
$tvars
{user}{author} =
uc
$1;
$tvars
{user}{fakename} =
$tvars
{user}{author};
LogDebug(
"Rename: author=$tvars{user}{author}, fakename=$tvars{user}{fakename}"
);
}
elsif
(
$tvars
{user}{name} =~ /imposter:(\d+)/) {
$tvars
{user}{tester} = $1;
LogDebug(
"Rename: tester=$tvars{user}{tester}, fakename=$tvars{user}{fakename}"
);
$tvars
{user}{fakename} = UserName(
$tvars
{user}{tester});
}
elsif
(
$tvars
{user}{name} =~ /imposter:([A-Z]+)/i) {
$tvars
{user}{author} =
uc
$1;
$tvars
{user}{fakename} =
$tvars
{user}{author};
LogDebug(
"Rename: author=$tvars{user}{author}, fakename=$tvars{user}{fakename}"
);
}
}
sub
OSName {
my
(
$self
,
$name
) =
@_
;
my
$code
=
lc
$name
;
$code
=~ s/[^\w]+//g;
my
$OSNAMES
=
$self
->osnames;
return
((
$OSNAMES
->{
$code
} ||
uc
(
$name
)),
$code
);
}
sub
check_oncpan {
my
(
$self
,
$dist
,
$vers
) =
@_
;
my
@rows
=
$dbi
->GetQuery(
'array'
,
'OnCPAN'
,
$dist
,
$vers
);
my
$type
=
@rows
?
$rows
[0]->[0] :
undef
;
return
1
unless
(
$type
);
return
0
if
(
$type
eq
'backpan'
);
return
1;
}
sub
mklist_perls {
my
$self
=
shift
;
my
@perls
;
my
$perls
=
$self
->perls;
return
$perls
if
(
$perls
);
my
@rows
=
$dbi
->GetQuery(
'array'
,
'GetPerls'
);
for
my
$row
(
@rows
) {
push
@perls
,
$row
->[0]
if
(
$row
->[0] &&
$row
->[0] !~ /patch|RC/i);
}
@perls
=
sort
{ versioncmp(
$b
,
$a
) }
@perls
;
$self
->perls(\
@perls
);
return
\
@perls
;
}
1;