$VERSION
=
'3.39'
;
sub
View {
if
(
$cgiparams
{id} =~ /^\d+$/) {
my
@rows
=
$dbi
->GetQuery(
'hash'
,
'GetStatReport'
,
$cgiparams
{id});
if
(
@rows
) {
if
(
$rows
[0]->{guid} =~ /^[0-9]+\-[-\w]+$/) {
my
$id
= guid_to_nntp(
$rows
[0]->{guid});
_parse_nntp_report(
$id
);
}
else
{
$cgiparams
{id} =
$rows
[0]->{guid};
_parse_guid_report();
}
}
else
{
}
}
else
{
my
$id
= guid_to_nntp(
$cgiparams
{id});
if
(
$id
) {
_parse_nntp_report(
$id
);
}
else
{
_parse_guid_report();
}
}
unless
(
$tvars
{article}{article}) {
if
(
$cgiparams
{id} =~ /^\d+$/) {
$tvars
{article}{id} =
$cgiparams
{id};
}
else
{
$tvars
{article}{guid} =
$cgiparams
{id};
}
}
if
(
$cgiparams
{raw}) {
$tvars
{article}{raw} =
$cgiparams
{raw};
$tvars
{realm} =
'popup'
;
}
else
{
$tvars
{realm} =
'wide'
;
}
}
sub
AuthorRSS { load_rss(
'author'
); }
sub
DistroRSS { load_rss(
'distro'
); }
sub
load_rss {
my
$type
=
shift
;
my
$nopass
= 0;
if
(
$cgiparams
{name} =~ /(.*)\-nopass/) {
$cgiparams
{name} = $1;
$nopass
= 1;
}
my
$cache
=
sprintf
"%s/static/%s/%s/%s"
,
$settings
{webdir},
$type
,
substr
(
$cgiparams
{name},0,1),
$cgiparams
{name};
if
(-f
"$cache.json"
) {
my
$json
= read_file(
"$cache.json"
);
my
$data
= decode_json(
$json
);
my
@reports
;
for
my
$row
(
sort
{
$b
->{fulldate} <=>
$a
->{fulldate}}
@$data
) {
next
if
(
$nopass
&&
$row
->{state} =~ /PASS/i);
push
@reports
,
$row
;
}
$type
=
'nopass'
if
(
$nopass
);
$tvars
{body} = make_rss(
$type
,
$cgiparams
{name}, \
@reports
);
}
else
{
my
$file
=
$nopass
?
"$cache-nopass.rss"
:
"$cache.rss"
;
$tvars
{body} = read_file(
"$cache.rss"
)
if
(-f
$file
);
}
$tvars
{realm} =
'rss'
;
}
sub
make_rss {
my
(
$type
,
$item
,
$data
) =
@_
;
my
(
$title
,
$link
,
$desc
);
if
(
$type
eq
'distro'
) {
$title
=
"$item CPAN Testers Reports"
;
$desc
=
"Automated test results for the $item distribution"
;
}
elsif
(
$type
eq
'recent'
) {
$title
=
"Recent CPAN Testers Reports"
;
$desc
=
"Recent CPAN Testers reports"
;
}
elsif
(
$type
eq
'author'
) {
$title
=
"Reports for distributions by $item"
;
$desc
=
"Reports for distributions by $item"
;
}
elsif
(
$type
eq
'nopass'
) {
$title
=
"Failing Reports for distributions by $item"
;
$desc
=
"Reports for distributions by $item"
;
}
my
@date
=
$data
->[0]->{fulldate} =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/;
my
$date
=
sprintf
"%04d-%02d-%02dT%02d:%02d+01:00"
,
@date
;
my
$rss
= XML::RSS->new(
version
=>
'2.0'
);
$rss
->channel(
title
=>
$settings
{rsstitle},
link
=>
$settings
{rsslink},
description
=>
$settings
{rssdesc},
language
=>
'en'
,
copyrights
=>
$settings
{copyright},
pubDate
=> formatDate(16),
managingEditor
=>
$settings
{rsseditor},
webMaster
=>
$settings
{rssmaster},
generator
=>
'Labyrinth v'
.
$tvars
{
'labversion'
},
);
for
my
$test
(
@$data
) {
my
@date
=
$test
->{fulldate} =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/;
my
$date
=
sprintf
"%04d-%02d-%02dT%02d:%02d+01:00"
,
@date
;
my
$title
=
sprintf
"%s %s-%s %s on %s %s (%s)"
,
map
{
$_
||
''
} @{
$test
}{
qw( status dist version perl osname osvers platform )
};
$rss
->add_item(
title
=>
$title
,
description
=>
$title
,
link
=>
"$settings{reportlink2}/"
. (
$test
->{guid} ||
$test
->{id}),
guid
=>
"$settings{reportlink2}/"
. (
$test
->{guid} ||
$test
->{id}),
pubDate
=>
$date
,
);
}
return
$rss
->as_string;
}
sub
AuthorYAML { load_yaml(
'author'
); }
sub
DistroYAML { load_yaml(
'distro'
); }
sub
load_yaml {
my
$type
=
shift
;
my
$cache
=
sprintf
"%s/static/%s/%s/%s"
,
$settings
{webdir},
$type
,
substr
(
$cgiparams
{name},0,1),
$cgiparams
{name};
if
(-f
"$cache.json"
) {
my
$json
= read_file(
"$cache.json"
);
my
$data
= decode_json(
$json
);
my
@reports
;
for
my
$row
(
@$data
) {
push
@reports
,
$row
;
}
$tvars
{body} = Dump( \
@reports
);
}
elsif
(-f
"$cache.yaml"
) {
$tvars
{body} = read_file(
"$cache.yaml"
);
}
$tvars
{realm} =
'yaml'
;
}
sub
_parse_nntp_report {
my
$nntpid
=
shift
;
my
@rows
;
unless
(
$nntpid
) {
@rows
=
$dbi
->GetQuery(
'hash'
,
'GetStatReport'
,
$cgiparams
{id});
return
unless
(
@rows
);
$nntpid
= guid_to_nntp(
$rows
[0]->{guid});
}
@rows
=
$dbi
->GetQuery(
'hash'
,
'GetArticle'
,
$nntpid
);
return
unless
(
@rows
);
$rows
[0]->{article} = SafeHTML(
$rows
[0]->{article});
$tvars
{article} =
$rows
[0];
(
$tvars
{article}{head},
$tvars
{article}{body}) =
split
(/\n\n/,
$rows
[0]->{article},2);
my
$object
= CPAN::Testers::Common::Article->new(
$rows
[0]->{article});
return
unless
(
$object
);
$tvars
{article}{nntp} = 1;
$tvars
{article}{id} =
$cgiparams
{id};
$tvars
{article}{body} =
$object
->body;
$tvars
{article}{subject} =
$object
->subject;
$tvars
{article}{from} =
$object
->from;
$tvars
{article}{from} =~ s/\@.*//;
$tvars
{article}{post} =
$object
->postdate;
my
@date
=
$object
->date =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/;
$tvars
{article}{date} =
sprintf
"%04d-%02d-%02dT%02d:%02d:00Z"
,
@date
;
return
if
(
$tvars
{article}{subject} =~ /Re:/i);
return
unless
(
$tvars
{article}{subject} =~ /(CPAN|FAIL|PASS|NA|UNKNOWN)\s+/i);
my
$state
=
lc
$1;
if
(
$state
eq
'cpan'
) {
if
(
$object
->parse_upload()) {
$tvars
{article}{dist} =
$object
->distribution;
$tvars
{article}{version} =
$object
->version;
$tvars
{article}{author} =
$object
->author;
$tvars
{article}{letter} =
substr
(
$tvars
{article}{dist},0,1);
}
}
else
{
if
(
$object
->parse_report()) {
$tvars
{article}{dist} =
$object
->distribution;
$tvars
{article}{version} =
$object
->version;
$tvars
{article}{author} =
$object
->from;
$tvars
{article}{letter} =
substr
(
$tvars
{article}{dist},0,1);
}
}
}
sub
_parse_guid_report {
my
$cpan
= Labyrinth::Plugin::CPAN->new();
$cpan
->Configure();
my
@rows
=
$dbi
->GetQuery(
'hash'
,
'GetMetabaseByGUID'
,
$cgiparams
{id});
return
unless
(
@rows
);
my
$data
= decode_json(
$rows
[0]->{report});
my
$fact
= CPAN::Testers::Fact::LegacyReport->from_struct(
$data
->{
'CPAN::Testers::Fact::LegacyReport'
} );
$tvars
{article}{article} = SafeHTML(
$fact
->{content}{textreport});
$tvars
{article}{guid} =
$rows
[0]->{guid};
my
$report
= CPAN::Testers::Fact::TestSummary->from_struct(
$data
->{
'CPAN::Testers::Fact::TestSummary'
} );
my
(
$osname
) =
$cpan
->OSName(
$report
->{content}{osname});
$tvars
{article}{state} =
lc
$report
->{content}{grade};
$tvars
{article}{platform} =
$report
->{content}{archname};
$tvars
{article}{osname} =
$osname
;
$tvars
{article}{osvers} =
$report
->{content}{osversion};
$tvars
{article}{perl} =
$report
->{content}{perl_version};
$tvars
{article}{created} =
$report
->{metadata}{core}{creation_time};
my
$dist
= Metabase::Resource->new(
$report
->{metadata}{core}{resource} );
$tvars
{article}{dist} =
$dist
->metadata->{dist_name};
$tvars
{article}{version} =
$dist
->metadata->{dist_version};
(
$tvars
{article}{author},
$tvars
{article}{from}) = _get_tester(
$report
->creator );
$tvars
{article}{author} =~ s/\@/ [at] /g;
$tvars
{article}{from} =~ s/\@/ [at] /g;
$tvars
{article}{from} =~ s/\./ [dot] /g;
if
(
$tvars
{article}{created}) {
my
@created
=
$tvars
{article}{created} =~ /(\d+)-(\d+)-(\d+)T(\d+):(\d+):(\d+)Z/;
$tvars
{article}{postdate} =
sprintf
"%04d%02d"
,
$created
[0],
$created
[1];
$tvars
{article}{fulldate} =
sprintf
"%04d%02d%02d%02d%02d"
,
$created
[0],
$created
[1],
$created
[2],
$created
[3],
$created
[4];
}
else
{
my
@created
=
localtime
(
time
);
$tvars
{article}{postdate} =
sprintf
"%04d%02d"
,
$created
[5]+1900,
$created
[4]+1;
$tvars
{article}{fulldate} =
sprintf
"%04d%02d%02d%02d%02d"
,
$created
[5]+1900,
$created
[4]+1,
$created
[3],
$created
[2],
$created
[1];
}
$tvars
{article}{letter} =
substr
(
$tvars
{article}{dist},0,1);
$tvars
{article}{subject} =
sprintf
"%s %s-%s %s %s"
,
uc
$tvars
{article}{state},
$tvars
{article}{dist},
$tvars
{article}{version},
$tvars
{article}{perl},
$tvars
{article}{osname};
}
sub
_get_tester {
my
$creator
=
shift
;
my
@rows
=
$dbi
->GetQuery(
'hash'
,
'GetTesterFact'
,
$creator
);
return
(
$creator
,
$creator
)
unless
(
@rows
);
$rows
[0]->{email} ||=
$creator
;
$rows
[0]->{email} =~ s/\
'/'
'/g
if
(
$rows
[0]->{email});
return
(
$rows
[0]->{fullname},
$rows
[0]->{email});
}
1;