File Coverage

blib/lib/Labyrinth/Plugin/CPAN/Authors.pm
Criterion Covered Total %
statement 33 79 41.7
branch 0 22 0.0
condition 0 3 0.0
subroutine 11 15 73.3
pod 4 4 100.0
total 48 123 39.0


line stmt bran cond sub pod time code
1             package Labyrinth::Plugin::CPAN::Authors;
2              
3 4     4   915904 use strict;
  4         10  
  4         108  
4 4     4   18 use warnings;
  4         11  
  4         107  
5              
6 4     4   18 use vars qw($VERSION);
  4         8  
  4         180  
7             $VERSION = '3.59';
8              
9             =head1 NAME
10              
11             Labyrinth::Plugin::CPAN::Authors - Plugin to handle Author pages.
12              
13             =cut
14              
15             #----------------------------------------------------------------------------
16             # Libraries
17              
18 4     4   21 use base qw(Labyrinth::Plugin::Base);
  4         10  
  4         267  
19              
20 4     4   24 use Labyrinth::Audit;
  4         7  
  4         498  
21 4     4   24 use Labyrinth::DBUtils;
  4         9  
  4         78  
22 4     4   18 use Labyrinth::DTUtils;
  4         10  
  4         226  
23 4     4   24 use Labyrinth::Plugin::CPAN;
  4         7  
  4         33  
24 4     4   98 use Labyrinth::Variables;
  4         7  
  4         522  
25 4     4   28 use Labyrinth::Writer;
  4         9  
  4         204  
26              
27 4     4   598 use JSON::XS;
  4         3999  
  4         2253  
28              
29             #----------------------------------------------------------------------------
30             # Public Interface Functions
31              
32             =head1 METHODS
33              
34             =head2 Public Interface Methods
35              
36             =over 4
37              
38             =item Status
39              
40             Generate the status report
41              
42             =item Basic
43              
44             Provides basic components for pages.
45              
46             Currently creates a list of all known perl versions and operating systems.
47              
48             =item List
49              
50             List authors for a given letter.
51              
52             =item Reports
53              
54             List reports for authors dists.
55              
56             =back
57              
58             =cut
59              
60             sub Status {
61 0     0 1   my @rows = $dbi->GetQuery('hash','StatusRequest');
62 0 0         $tvars{status} = $rows[0] if(@rows);
63              
64 0           my @max = $dbi->GetQuery('array','MaxStatReport');
65 0 0         if(@max) {
66 0           my @rep = $dbi->GetQuery('hash','GetStatReport',$max[0]->[0]);
67 0 0         if(@rep) {
68 0           my @date = $rep[0]->{fulldate} =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/;
69 0           $rep[0]->{date} = sprintf "%04d-%02d-%02d %02d:%02d:00", @date;
70 0           $tvars{report} = $rep[0];
71             }
72             }
73             }
74              
75             sub Basic {
76 0     0 1   my $cpan = Labyrinth::Plugin::CPAN->new();
77 0           $cpan->Configure();
78              
79 0           $tvars{perlvers} = $cpan->mklist_perls;
80 0           $tvars{osnames} = $cpan->osnames;
81             }
82              
83             sub List {
84 0     0 1   ($tvars{letter}) = ($cgiparams{name} =~ /^([A-Z])/i);
85 0           $tvars{letter} = uc $tvars{letter};
86 0 0         return unless($tvars{letter});
87              
88 0           my @rows = $dbi->GetQuery('hash','GetAuthors',"$tvars{letter}%");
89 0           my @authors = map {$_->{author}} @rows;
  0            
90 0 0         $tvars{list} = \@authors if(@authors);
91             }
92              
93             sub Reports {
94 0     0 1   my $cpan = Labyrinth::Plugin::CPAN->new();
95 0           $cpan->Configure();
96              
97 0           $tvars{author} = $cgiparams{name};
98 0           $tvars{letter} = substr($cgiparams{name},0,1);
99              
100             # does author exist?
101 0           my @rows = $dbi->GetQuery('hash','FindAuthor',$cgiparams{name});
102 0 0         unless(@rows) {
103 0           $tvars{errcode} = 'NEXT';
104 0           $tvars{command} = 'cpan-authunk';
105 0           return;
106             }
107              
108             # get author summary
109 0           my @summary = $dbi->GetQuery('hash','GetAuthorSummary',$cgiparams{name});
110 0 0         unless(@summary) {
111 0 0         unless($settings{crawler}) {
112 0           $dbi->DoQuery('PushAuthor',$cgiparams{name});
113 0           $tvars{update} = 1;
114             }
115 0           $tvars{perlvers} = $cpan->mklist_perls;
116 0           $tvars{osnames} = $cpan->osnames;
117 0           return;
118             }
119              
120             # if existing page requests, add another to improve rebuild time
121 0           @rows = $dbi->GetQuery('array','GetAuthorRequests',$cgiparams{name});
122 0 0 0       if(@rows && $rows[0]->[0] > 0) {
123 0 0         unless($settings{crawler}) {
124 0           $dbi->DoQuery('PushAuthor',$cgiparams{name});
125 0           $tvars{update} = 1;
126             }
127             }
128              
129             # decode from JSON string
130 0           my $parms = decode_json($summary[0]->{dataset});
131 0           for my $key (keys %$parms) { $tvars{$key} = $parms->{$key}; }
  0            
132 0 0         $tvars{processed} = formatDate(8,$parms->{processed}) if($parms->{processed});
133             }
134              
135             1;
136              
137             __END__
138              
139             =head1 SEE ALSO
140              
141             Labyrinth
142              
143             =head1 AUTHOR
144              
145             Barbie, <barbie@missbarbell.co.uk> for
146             Miss Barbell Productions, L<http://www.missbarbell.co.uk/>
147              
148             =head1 COPYRIGHT & LICENSE
149              
150             Copyright (C) 2008-2017 Barbie for Miss Barbell Productions
151             All Rights Reserved.
152              
153             This module is free software; you can redistribute it and/or
154             modify it under the Artistic License 2.0.
155              
156             =cut