File Coverage

blib/lib/Labyrinth/Plugin/CPAN/Monitor.pm
Criterion Covered Total %
statement 28 30 93.3
branch n/a
condition n/a
subroutine 10 10 100.0
pod n/a
total 38 40 95.0


line stmt bran cond sub pod time code
1             package Labyrinth::Plugin::CPAN::Monitor;
2              
3 4     4   11668 use strict;
  4         11  
  4         117  
4 4     4   21 use warnings;
  4         9  
  4         121  
5              
6 4     4   21 use vars qw($VERSION);
  4         10  
  4         202  
7             $VERSION = '3.60';
8              
9             =head1 NAME
10              
11             Labyrinth::Plugin::CPAN::Monitor - Plugin to monitor actions and tables
12              
13             =cut
14              
15             #----------------------------------------------------------------------------
16             # Libraries
17              
18 4     4   24 use base qw(Labyrinth::Plugin::Base);
  4         10  
  4         294  
19              
20 4     4   25 use Labyrinth::Audit;
  4         10  
  4         501  
21 4     4   27 use Labyrinth::DTUtils;
  4         9  
  4         3508  
22 4     4   27 use Labyrinth::Variables;
  4         11  
  4         553  
23              
24 4     4   30 use Labyrinth::Plugin::CPAN;
  4         9  
  4         31  
25              
26 4     4   125 use Data::Dumper;
  4         10  
  4         174  
27 4     4   2018 use GD::Graph::lines;
  0            
  0            
28             use GD::Graph::colour qw(:colours :convert);
29             use WWW::Mechanize;
30              
31             #----------------------------------------------------------------------------
32             # Variables
33              
34             my $HOURS24 = 60 * 60 * 24;
35             my $WEEKS1 = 60 * 60 * 24 * 7;
36             my $WEEKS4 = 60 * 60 * 24 * 7 * 4;
37              
38             my $mech = WWW::Mechanize->new();
39             $mech->agent_alias( 'Linux Mozilla' );
40              
41             my $chart_api = 'http://chart.apis.google.com/chart?chs=640x300&cht=lc';
42             my $chart_titles = 'chtt=%s&chdl=%s';
43             my $chart_labels = 'chxt=x,x,y,r&chxl=0:|%s|1:|%s|2:|%s|3:|%s';
44             my $chart_data = 'chd=t:%s';
45             my $chart_colour = 'chco=%s';
46             my $chart_filler = 'chf=bg,s,dddddd';
47              
48             my %COLOURS = (
49             white => 'FFFFFF',
50             black => '000000',
51             red => 'FF0000',
52             blue => '0000FF',
53             green => '00FF00',
54             orange => 'E76300',
55             purple => '800080',
56             cyan => '00FFFF',
57             cream => 'C8C8F0',
58             yellow => 'FFFF00',
59             brown => '987654',
60             violet => '8A2BE2',
61             torch => 'FD0E35',
62             );
63              
64             # predefine colours in GD::Chart::colours:
65             # white, lgray, gray, dgray, black, lblue, blue, dblue, gold, lyellow, yellow,
66             # dyellow, lgreen, green, dgreen, lred, red, dred, lpurple, purple, dpurple,
67             # lorange, orange, pink, dpink, marine, cyan, lbrown, dbrown.
68              
69             #my @COLOURS = qw(violet blue cyan green orange red torch brown cream yellow purple);
70             my @COLOURS = qw(purple blue cyan green orange red dred brown cream yellow dpurple);
71             #my @COLOURS = map {$COLOURS{$_}} qw(violet blue cyan green orange red torch brown cream yellow purple);
72              
73             #----------------------------------------------------------------------------
74             # Public Interface Functions
75              
76             =head1 METHODS
77              
78             =head2 Public Interface Methods
79              
80             =over 4
81              
82             =item Snapshot
83              
84             Generate a new snapshot in the database.
85              
86             =item Graphs
87              
88             Provide monitor graphs
89              
90             =back
91              
92             =cut
93              
94             sub Snapshot {
95             my ($self,$progress) = @_;
96             $progress->( "Create START" ) if(defined $progress);
97              
98             my @rows = $dbi->GetQuery('array','CountRequests');
99             my $sql = $rows[0]->[0] > 0 ? 'CreateSnapshot' : 'CreateSnapshot0';
100             my $next = $dbi->Iterator('array',$sql);
101             while(my $row = $next->()) {
102             $dbi->DoQuery('InsertSnapshot',@$row);
103             }
104              
105             $progress->( "Create STOP" ) if(defined $progress);
106             }
107              
108             sub Graphs {
109             my ($self,$progress) = @_;
110             $progress->( "Update START" ) if(defined $progress);
111              
112             my @date = localtime(time - $HOURS24);
113             my $timestamp = sprintf "%04d-%02d-%02d %02d:%02d:%02d",
114             $date[5]+1900,$date[4]+1,$date[3],$date[2],$date[1],$date[0];
115              
116             my (%data,%days);
117             my @rows = $dbi->GetQuery('hash','GetSnapshots',{timestamp => $timestamp});
118             for my $row (@rows) {
119             my $date = sprintf "%04d%02d%02d", $row->{year}, $row->{month}, $row->{day};
120             $data{$row->{now}}{$date} = $row;
121             $days{$date} = sprintf "%02d/%02d/%04d", $row->{day}, $row->{month}, $row->{year};;
122             }
123              
124             _make_graphs(\%days,\%data,'-1d',$progress);
125              
126             @date = localtime(time - $WEEKS1);
127             $timestamp = sprintf "%04d-%02d-%02d %02d:%02d:%02d",
128             $date[5]+1900,$date[4]+1,$date[3],$date[2],$date[1],$date[0];
129              
130             (%data,%days) = ();
131             @rows = $dbi->GetQuery('hash','GetSnapshots',{timestamp => $timestamp});
132             for my $row (@rows) {
133             my $date = sprintf "%04d%02d%02d", $row->{year}, $row->{month}, $row->{day};
134             $data{$row->{now}}{$date} = $row;
135             $days{$date} = sprintf "%02d/%02d/%04d", $row->{day}, $row->{month}, $row->{year};;
136             }
137              
138             my $r = 0;
139             for my $d (keys %data) {
140             next if($r++ % 4 == 0);
141             delete $data{$d};
142             }
143              
144             _make_graphs(\%days,\%data,'-1w',$progress);
145             }
146              
147             #----------------------------------------------------------------------------
148             # Private Interface Functions
149              
150             sub _make_graphs {
151             my ($days,$data,$suffix,$progress) = @_;
152              
153             my $y = 0;
154             my (@name_count,@page_count,@page_weight,%seen);
155             my ($max_name_count,$max_page_count,$max_page_weight) = (0,0,0);
156             for my $now (sort keys %$data) {
157             my (@now) = $now =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
158             if($suffix eq '-1d') {
159             push @{ $name_count[0] }, $y % 4 == 0 ? "$4:$5" : '';
160             push @{ $page_count[0] }, $y % 4 == 0 ? "$4:$5" : '';
161             push @{ $page_weight[0] }, $y % 4 == 0 ? "$4:$5" : '';
162             } else {
163             push @{ $name_count[0] }, !$seen{"$3/$2"} ? "$3/$2" : '';
164             push @{ $page_count[0] }, !$seen{"$3/$2"} ? "$3/$2" : '';
165             push @{ $page_weight[0] }, !$seen{"$3/$2"} ? "$3/$2" : '';
166             $seen{"$3/$2"} = 1;
167             }
168             $y++;
169              
170             my $inx = 1;
171             for my $day (sort {$b <=> $a} keys %$days) {
172             if(defined $data->{$now}{$day}) {
173             push @{ $name_count[$inx] }, $data->{$now}{$day}->{name_count};
174             push @{ $page_count[$inx] }, $data->{$now}{$day}->{page_count};
175             push @{ $page_weight[$inx] }, $data->{$now}{$day}->{page_weight};
176              
177             $max_name_count = $data->{$now}{$day}->{name_count} if($max_name_count < $data->{$now}{$day}->{name_count});
178             $max_page_count = $data->{$now}{$day}->{page_count} if($max_page_count < $data->{$now}{$day}->{page_count});
179             $max_page_weight = $data->{$now}{$day}->{page_weight} if($max_page_weight < $data->{$now}{$day}->{page_weight});
180             } else {
181             push @{ $name_count[$inx] }, 0;
182             push @{ $page_count[$inx] }, 0;
183             push @{ $page_weight[$inx] }, 0;
184             }
185             $inx++;
186             }
187             }
188            
189             _write_image($max_name_count, 'Unique Page Requests',$days,\@name_count, "name_count$suffix", $progress);
190             _write_image($max_page_count, 'Total Page Requests', $days,\@page_count, "page_count$suffix", $progress);
191             _write_image($max_page_weight,'Total Page Weight', $days,\@page_weight,"page_weight$suffix",$progress);
192              
193             $progress->( "Update STOP" ) if(defined $progress);
194             }
195              
196             sub _write_image {
197             my ($m,$title,$days,$data,$filename,$progress) = @_;
198             my $max = _set_max($m);
199             my $range = _set_range(0,$max);
200              
201             #$progress->( "DATA = [".(scalar(@$data))."] ".Dumper($data) ) if(defined $progress);
202              
203             #my $grey = add_colour(grey => hex2rgb('#eeeeee'));
204             my $graph = GD::Graph::lines->new(640, 300);
205             #add_colour($_ => hex2rgb($COLOURS{$_})) for(@COLOURS);
206              
207             $graph->set(
208             title => $title,
209              
210             x_label => 'Timestamp',
211             x_label_position => 0.5,
212             x_labels_vertical => 1,
213             x_label_skip => $filename =~ /-1d$/ ? 1 : 1,
214             x_tick_length => -2,
215              
216             y_label => '',
217             y_max_value => $max,
218             y_tick_length => -2,
219             y_number_format => \&_y_format,
220              
221             line_width => 2,
222             axis_space => 4,
223              
224             legend_placement => 'RC',
225             dclrs => [qw(lpurple blue cyan green orange red dred lbrown pink yellow dpurple)],
226             #dclrs => [@COLOURS],
227             boxclr => '#eeeeee',
228             labelclr => 'dgray',
229             axislabelclr => 'dgray',
230             legendclr => 'dgray',
231             valuesclr => 'dgray',
232             textclr => 'dgray'
233            
234             ) or die $graph->error;
235             my @days = map {$days->{$_}} sort {$b <=> $a} keys %$days;
236             $graph->set_legend(@days);
237              
238             #my $font = '/usr/share/fonts/truetype/ttf-dejavu/DejaVuSans.ttf';
239             my $font = '/usr/share/fonts/truetype/freefont/FreeSans.ttf';
240              
241             $graph->set_title_font( $font,10);
242             $graph->set_legend_font( $font,10);
243             $graph->set_x_label_font($font,8);
244             $graph->set_y_label_font($font,8);
245             $graph->set_x_axis_font( $font,8);
246             $graph->set_y_axis_font( $font,8);
247             $graph->set_values_font( $font,8);
248              
249              
250             my $gd = $graph->plot($data) or die $graph->error;
251              
252             my $file = "$settings{webdir}/static/$filename.png";
253             my $fh = IO::File->new($file, 'w+') or die "Couldn't write to file [$file]: $!\n";
254             binmode $fh;
255             print $fh $gd->png;
256             $fh->close;
257             }
258              
259             sub _make_graph_url {
260             my ($m,$title,$days,$data) = @_;
261             my $max = _set_max($m);
262             my $range = _set_range(0,$max);
263              
264             my (@d,@c,@l);
265             my @colours = @COLOURS;
266             for my $inx (3 .. scalar(@$data)) {
267             # data needs to be expressed as a percentage of the max
268             for(@{$data->[$inx-1]}) {
269             #print "pcent = $_ / $max * 100 = ";
270             $_ = $_ / $max * 100;
271             #print "$_ = ";
272             $_ = int($_ * 1) / 1;
273             #print "$_\n";
274             }
275              
276             push @c, shift @colours;
277             push @d, join(',',@{$data->[$inx-1]});
278             push @l, ($inx-3) . ' day' . ($inx-3==1 ? '' : 's') . ' old';
279             }
280              
281             @l = map {$days->{$_}} sort {$b <=> $a} keys %$days;
282              
283             my $xaxis1 = join('|', @{$data->[0]});
284             my $xaxis2 = join('|', @{$data->[1]});
285             my $datum = sprintf $chart_data, join('|',reverse @d);
286             my $colour = sprintf $chart_colour, join(',',@c);
287             my $titles = sprintf $chart_titles, $title, join('|',@l);
288             my $labels = sprintf $chart_labels, $xaxis1, $xaxis2, $range, $range;
289             $titles =~ s/ /+/g;
290             $labels =~ s/ /+/g;
291             return join('&', $chart_api, $titles, $labels, $colour, $chart_filler, $datum);
292             }
293              
294             sub _set_max {
295             my $max = shift;
296             my $lmt = 10;
297              
298             return $lmt if($max <= $lmt);
299              
300             my $len = length("$max") - 1;
301             my $num = substr("$max",0,1);
302              
303             if($max < 100_000) {
304             my $lmt1 = (10**$len) * $num;
305             my $lmt2 = ((10**$len) * $num) + ((1**($len-1)) * 5);
306             my $lmt3 = (10**$len) * ($num + 1);
307              
308             return $lmt1 if($max <= $lmt1);
309             return $lmt2 if($max <= $lmt2);
310             return $lmt3 if($max <= $lmt3);
311             }
312              
313             $num += ($num % 2) ? 1 : 2;
314              
315             return (10**$len) * $num;
316             }
317              
318             sub _set_range {
319             my ($min,$max) = @_;
320              
321             my $len = length("$max") - 2;
322             my $pc0 = $max / 10;
323              
324             my $x1 = 10**$len * 1;
325             my $x2 = 10**$len * 2;
326             my $x5 = 10**$len * 5;
327             my $x0 = 10**$len * 10;
328              
329             my $step = $pc0 <= $x1 ? $x1 : $pc0 <= $x2 ? $x2 : $pc0 <= $x5 ? $x5 : $x0;
330              
331             my @r;
332             for(my $r = $min; $r < ($max+$step); $r += $step) {
333             my $x = $r < 1000 ? $r : $r < 1000000 ? ($r/1000) . 'k' : ($r/1000000) . 'm';
334             push @r, $x;
335             };
336              
337             return join('|',@r);
338             }
339              
340             sub _y_format {
341             my $num = shift || return '';
342             return '' unless(defined $num);
343             return $1.'k' if($num =~ /^(\d{1,3})000$/);
344             return $1.'m' if($num =~ /^(\d{1,3})000000$/);
345             return $num;
346             }
347              
348             1;
349              
350             __END__
351              
352             =head1 DATABASE SCHEMA
353              
354             DROP TABLE IF EXISTS `monitor`;
355             CREATE TABLE `monitor` (
356             now timestamp,
357             day int(2) not null default 0,
358             month int(2) not null default 0,
359             year int(4) not null default 0,
360             name_count int(10) not null default 0,
361             page_count int(10) not null default 0,
362             page_weight int(10) not null default 0,
363             PRIMARY KEY (now,day,month,year)
364             );
365              
366             =head1 SEE ALSO
367              
368             Labyrinth
369              
370             =head1 AUTHOR
371              
372             Barbie, <barbie@missbarbell.co.uk> for
373             Miss Barbell Productions, L<http://www.missbarbell.co.uk/>
374              
375             =head1 COPYRIGHT & LICENSE
376              
377             Copyright (C) 2008-2017 Barbie for Miss Barbell Productions
378             All Rights Reserved.
379              
380             This module is free software; you can redistribute it and/or
381             modify it under the Artistic License 2.0.
382              
383             =cut