#!/usr/bin/perl -w
$|++;
my
$VERSION
=
'3.34'
;
my
$LABYRINTH
=
'5.00'
;
my
$BASE
;
BEGIN {
$BASE
=
'/var/www/reports'
;
}
use
lib
qw|../cgi-bin/lib ../cgi-bin/plugins|
;
my
$AUTHORS
=
'/var/www/reports/html/static/author'
;
my
$DISTROS
=
'/var/www/reports/html/static/distro'
;
my
$BACKPAN
=
'/opt/projects/BACKPAN/authors/id'
;
my
%osfix
= (
'3DMSWin32'
=>
'mswin32'
,
'darwiThis'
=>
'darwin'
,
'freeb'
=>
'freebsd'
,
'li'
=>
'linux'
,
'lin'
=>
'linux'
,
'linThis'
=>
'linux'
,
'linu'
=>
'linux'
,
'linuThis'
=>
'linux'
,
'linuxThis'
=>
'linux'
,
'lThis'
=>
'linux'
,
'netb'
=>
'netbsd'
,
'netbs'
=>
'netbsd'
,
'openThis'
=>
'openbsd'
,
'openosname=openbsd'
=>
'openbsd'
,
'osname=openosname=openbsd'
=>
'openbsd'
);
my
%options
;
if
(!GetOptions( \
%options
,
'update|u'
,
'verbose|v'
)) {
print
STDERR
"$0 [--update] [--verbose]\n"
;
exit
;
}
{
Labyrinth::Variables::init();
Labyrinth::Globals::LoadSettings(
"$BASE/cgi-bin/config/settings.ini"
);
Labyrinth::Globals::DBConnect();
SetLogFile(
FILE
=>
$settings
{
'logfile'
},
USER
=>
'labyrinth'
,
LEVEL
=> 0,
CLEAR
=> 1,
CALLER
=> 1);
my
$content
= Labyrinth::Plugin::Content->new();
$content
->GetVersion();
my
$cpan
= Labyrinth::Plugin::CPAN->new();
my
$dbx
=
$cpan
->DBX(
'cpanstats'
);
$cpan
->Configure();
_log(
"Start"
);
prep_hashes(
$cpan
,
$dbx
);
check_osname(
$cpan
,
$dbx
);
_log(
"Finish"
);
}
sub
prep_hashes {
my
(
$cpan
,
$dbx
) =
@_
;
my
@osname
=
$dbx
->GetQuery(
'hash'
,
'AllOSNames'
);
my
%osname
=
map
{
$_
->{osname} => 1 }
@osname
;
my
%oscode
=
map
{
$_
->{ostitle} =>
$_
->{osname} }
@osname
;
my
$osname
=
scalar
(
@osname
);
$cpan
->{data}{osname}{tote} =
$osname
;
$cpan
->{data}{osname}{list} = \
@osname
;
$cpan
->{data}{osname}{hash} = \
%osname
;
$cpan
->{data}{osname}{code} = \
%oscode
;
}
sub
check_osname {
my
(
$cpan
,
$dbx
) =
@_
;
my
$fixed
= 0;
my
$next
=
$dbx
->Iterator(
'hash'
,
'GetReportBlankOS'
);
while
(
my
$row
=
$next
->()) {
my
@meta
=
$dbx
->GetQuery(
'hash'
,
'GetMetabaseByGUID'
,
$row
->{guid});
if
(
@meta
) {
my
(
$osname
,
$archname
,
$report
) = _check_arch_os(
$meta
[0]);
if
(
$cpan
->{data}{osname}{hash}{
$osname
}) {
_log(
"UPDATE: $row->{id} => $osname"
);
$dbx
->DoQuery(
'SetReportOS'
,
$osname
,
$row
->{id})
if
(
$options
{update});
$fixed
++;
}
elsif
(
$cpan
->{data}{osname}{code}{
$osname
}) {
$osname
=
$cpan
->{data}{osname}{code}{
$osname
};
_log(
"UPDATE: $row->{id} => $osname"
);
$dbx
->DoQuery(
'SetReportOS'
,
$osname
,
$row
->{id})
if
(
$options
{update});
$fixed
++;
}
elsif
(
$cpan
->{data}{osname}{hash}{
lc
$osname
}) {
$osname
=
lc
$osname
;
_log(
"UPDATE: $row->{id} => $osname"
);
$dbx
->DoQuery(
'SetReportOS'
,
$osname
,
$row
->{id})
if
(
$options
{update});
$fixed
++;
}
elsif
(
$osfix
{
$osname
}) {
$osname
=
$osfix
{
$osname
};
_log(
"UPDATE: $row->{id} => $osname"
);
$dbx
->DoQuery(
'SetReportOS'
,
$osname
,
$row
->{id})
if
(
$options
{update});
$fixed
++;
}
else
{
_log(
"BAD OS: $row->{id} osname=$osname, archname=$archname, report=$report"
);
}
}
else
{
_log(
"MISSING: $row->{id}"
);
}
}
_log(
"Fix: fixed=$fixed"
);
}
sub
_check_arch_os {
my
$row
=
shift
;
my
$data
= decode_json(
$row
->{report});
my
$fact
= decode_json(
$data
->{
'CPAN::Testers::Fact::LegacyReport'
}{content});
my
$textreport
=
$fact
->{textreport};
my
$mail
=
<<EMAIL;
From: fake\@example.com
To: fake\@example.com
Subject: PASS Fake-0.01
Date: 01-01-2010 01:01:01 Z
$textreport
EMAIL
my
$object
= CPAN::Testers::Common::Article->new(
$mail
) or
return
;
$object
->parse_report();
return
$object
->osname(),
$object
->archname,
$textreport
;
}
sub
_log {
my
@date
=
localtime
(
time
);
my
$date
=
sprintf
"%04d/%02d/%02d %02d:%02d:%02d"
,
$date
[5]+1900,
$date
[4]+1,
$date
[3],
$date
[2],
$date
[1],
$date
[0];
print
"$date "
.
join
(
' '
,
@_
).
"\n"
;
}