File Coverage

blib/lib/Labyrinth/Plugin/Metabase/Parser.pm
Criterion Covered Total %
statement 36 85 42.3
branch 0 22 0.0
condition n/a
subroutine 12 15 80.0
pod 1 1 100.0
total 49 123 39.8


line stmt bran cond sub pod time code
1             package Labyrinth::Plugin::Metabase::Parser;
2              
3 4     4   35249 use strict;
  4         13  
  4         114  
4 4     4   21 use warnings;
  4         10  
  4         105  
5              
6 4     4   19 use vars qw($VERSION);
  4         9  
  4         171  
7             $VERSION = '3.59';
8              
9             =head1 NAME
10              
11             Labyrinth::Plugin::Metabase::Parser - Plugin to parse Metabase Report pages.
12              
13             =cut
14              
15             #----------------------------------------------------------------------------
16             # Libraries
17              
18 4     4   21 use base qw(Labyrinth::Plugin::Base);
  4         15  
  4         674  
19              
20 4     4   901191 use Labyrinth::Audit;
  4         9  
  4         451  
21 4     4   25 use Labyrinth::DBUtils;
  4         7  
  4         71  
22 4     4   17 use Labyrinth::DTUtils;
  4         8  
  4         277  
23 4     4   411 use Labyrinth::Plugin::CPAN;
  4         11407  
  4         26  
24 4     4   111 use Labyrinth::Variables;
  4         9  
  4         466  
25 4     4   25 use Labyrinth::Writer;
  4         9  
  4         191  
26              
27 4     4   437 use CPAN::Testers::Common::Article;
  4         7586  
  4         27  
28 4     4   1766 use Data::FlexSerializer;
  4         5748166  
  4         57  
29              
30             #----------------------------------------------------------------------------
31             # Variables
32              
33             my $serializer = Data::FlexSerializer->new( detect_compression => 1 );
34              
35             #----------------------------------------------------------------------------
36             # Public Interface Functions
37              
38             =head1 METHODS
39              
40             =head2 Public Interface Methods
41              
42             =over 4
43              
44             =item View
45              
46             View a specific report.
47              
48             =back
49              
50             =cut
51              
52             sub View {
53 0 0   0 1   if($cgiparams{id} =~ /^\d+$/) {
    0          
54 0           _parse_nntp_report();
55             } elsif($cgiparams{id} =~ /^[-\w]+$/) {
56 0           _parse_guid_report();
57             } else {
58 0           $tvars{errcode} = 'NEXT';
59 0           $tvars{command} = 'cpan-distunk';
60             }
61              
62 0 0         if($cgiparams{raw}) {
63 0           $tvars{article}{raw} = $cgiparams{raw};
64 0           $tvars{realm} = 'popup';
65             }
66             }
67              
68             #----------------------------------------------------------------------------
69             # Private Interface Functions
70              
71             sub _parse_nntp_report {
72 0     0     my @rows = $dbi->GetQuery('hash','GetArticle',$cgiparams{id});
73 0 0         unless(@rows) {
74 0           $tvars{article}{id} = $cgiparams{id};
75 0           return;
76             }
77              
78 0           $tvars{article} = $rows[0];
79 0           ($tvars{article}{head},$tvars{article}{body}) = split(/\n\n/,$rows[0]->{article},2);
80              
81 0           my $object = CPAN::Testers::Common::Article->new($rows[0]->{article});
82 0 0         return unless($object);
83              
84 0           $tvars{article}{body} = $object->body;
85 0           $tvars{article}{subject} = $object->subject;
86 0           $tvars{article}{from} = $object->from;
87 0           $tvars{article}{from} =~ s/\@.*//;
88 0           $tvars{article}{post} = $object->postdate;
89 0           $tvars{article}{date} = $object->date;
90              
91 0 0         return if($tvars{article}{subject} =~ /Re:/i);
92 0 0         return unless($tvars{article}{subject} =~ /(CPAN|FAIL|PASS|NA|UNKNOWN)\s+/i);
93              
94 0           my $state = lc $1;
95              
96 0 0         if($state eq 'cpan') {
97 0 0         if($object->parse_upload()) {
98 0           $tvars{article}{dist} = $object->distribution;
99 0           $tvars{article}{version} = $object->version;
100 0           $tvars{article}{author} = $object->author;
101 0           $tvars{article}{letter} = substr($tvars{article}{dist},0,1);
102             }
103             } else {
104 0 0         if($object->parse_report()) {
105 0           $tvars{article}{dist} = $object->distribution;
106 0           $tvars{article}{version} = $object->version;
107 0           $tvars{article}{author} = $object->from;
108 0           $tvars{article}{letter} = substr($tvars{article}{dist},0,1);
109             }
110             }
111             }
112              
113             sub _parse_guid_report {
114 0     0     my @rows = $dbi->GetQuery('hash','GetMetabaseByGUID',$cgiparams{id});
115 0 0         return unless(@rows);
116              
117 0           $tvars{article}{data} = $serializer->deserialize($rows[0]->{report});
118              
119 0           my $object = Labyrinth::Plugin::Metabase::Parser->new($tvars{article}{data});
120              
121 0           $tvars{article}{subject} = $object->subject;
122 0           $tvars{article}{from} = $object->from;
123 0           $tvars{article}{from} =~ s/\@.*//;
124 0           $tvars{article}{post} = $object->postdate;
125 0           $tvars{article}{date} = $object->date;
126              
127 0           $tvars{article}{dist} = $object->distribution;
128 0           $tvars{article}{version} = $object->version;
129 0           $tvars{article}{author} = $object->from;
130 0           $tvars{article}{letter} = substr($tvars{article}{dist},0,1);
131             }
132              
133             1;
134              
135             __END__
136              
137             =head1 SEE ALSO
138              
139             Labyrinth
140              
141             =head1 AUTHOR
142              
143             Barbie, <barbie@missbarbell.co.uk> for
144             Miss Barbell Productions, L<http://www.missbarbell.co.uk/>
145              
146             =head1 COPYRIGHT & LICENSE
147              
148             Copyright (C) 2010-2017 Barbie for Miss Barbell Productions
149             All Rights Reserved.
150              
151             This module is free software; you can redistribute it and/or
152             modify it under the Artistic License 2.0.
153              
154             =cut