SL/BackgroundJob/SelfTest.pm

   1 package SL::BackgroundJob::SelfTest;
   2
   3 use strict;
   4
   5 use parent qw(SL::BackgroundJob::Base);
   6
   7 use Test::Builder;
   8 use TAP::Parser;
   9 use TAP::Parser::Aggregator;
  10 use Sys::Hostname;
  11 use FindBin;
  12
  13 use SL::DB::AuthUser;
  14 use SL::Common;
  15
  16 use Rose::Object::MakeMethods::Generic (
  17   array => [
  18    'modules'     => {},
  19    'add_modules' => { interface => 'add', hash_key => 'modules' },
  20    'errors'      => {},
  21    'add_errors'  => { interface => 'add', hash_key => 'errors' },
  22    'full_diag'      => {},
  23    'add_full_diag'  => { interface => 'add', hash_key => 'full_diag' },
  24   ],
  25   scalar => [
  26    qw(diag tester config aggreg),
  27   ],
  28 );
  29
  30 sub create_job {
  31   $_[0]->create_standard_job('20 2 * * *'); # every day at 2:20 am
  32 }
  33
  34 sub setup {
  35   my ($self) = @_;
  36
  37   $self->config($::lx_office_conf{self_test} || {});
  38
  39   $self->tester(Test::Builder->new);
  40   $self->tester->reset; # stupid Test::Builder mplementation uses class variables
  41   $self->aggreg(TAP::Parser::Aggregator->new);
  42
  43   $self->modules(split /\s+/, $self->config->{modules});
  44 }
  45
  46 sub run {
  47   my $self        = shift;
  48   $self->setup;
  49
  50   return 1 unless $self->modules;
  51
  52   foreach my $module ($self->modules) {
  53     $self->run_module($module);
  54   }
  55
  56   $self->log(
  57     sprintf "SelfTest status: %s, passed: %s, failed: %s, unexpectedly succeeded: %s",
  58              $self->aggreg->get_status,
  59              $self->aggreg->passed,
  60              $self->aggreg->failed,
  61              $self->aggreg->todo_passed,
  62   );
  63
  64   if (!$self->aggreg->all_passed || $self->config->{send_email_on_success}) {
  65     $self->_send_email;
  66   }
  67
  68   return 1;
  69 }
  70
  71 sub run_module {
  72   my ($self, $module) = @_;
  73
  74   # TAP usually prints out to STDOUT and STDERR, capture those for TAP::Parser
  75   my $output;
  76
  77   $self->tester->output        (\$output);
  78   $self->tester->failure_output(\$output);
  79   $self->tester->todo_output   (\$output);
  80
  81   # sanitize module name;
  82   # this allows unicode package names, which are known to be buggy in 5.10, you should avoid them
  83   $module =~ s/[^\w:]//g;
  84   $module = "SL::BackgroundJob::SelfTest::$module";
  85
  86   # try to load module;
  87   (my $file = $module) =~ s|::|/|g;
  88   eval {
  89     require $file . '.pm';
  90     1
  91   } or $self->add_errors($::locale->text('Could not load class #1 (#2): "#3"', $module, $file, $@)) && return;
  92
  93   eval {
  94     my $worker = $module->new;
  95     $worker->tester($self->tester);
  96
  97     $worker->run;
  98     1;
  99   } or $self->add_errors($::locale->text('Could not load class #1, #2', $module, $@)) && return;
 100
 101   $self->add_full_diag($output);
 102   $self->{diag_per_module}{$module} = $output;
 103
 104   my $parser = TAP::Parser->new({ tap => $output});
 105   $parser->run;
 106
 107   $self->aggreg->add($module => $parser);
 108 }
 109
 110 sub _email_user {
 111   $_[0]{email_user} ||= SL::DB::Manager::AuthUser->find_by(login => $_[0]->config->{send_email_to});
 112 }
 113
 114 sub _send_email {
 115   my ($self) = @_;
 116
 117   return if !$self->config || !$self->config->{send_email_to};
 118
 119   my $user  = $self->_email_user;
 120   my $email = $user ? $user->get_config_value('email') : undef;
 121
 122   return unless $email;
 123
 124   my ($output, $content_type) = $self->_prepare_report;
 125
 126   my $mail              = Mailer->new(charset => $::locale->is_utf8 ? 'UTF-8' : Common->DEFAULT_CHARSET );
 127   $mail->{from}         = $self->config->{email_from};
 128   $mail->{to}           = $email;
 129   $mail->{subject}      = $self->config->{email_subject};
 130   $mail->{content_type} = $content_type;
 131   $mail->{message}      = $$output;
 132
 133   $mail->send;
 134 }
 135
 136 sub _prepare_report {
 137   my ($self) = @_;
 138
 139   my $user = $self->_email_user;
 140   my $template = Template->new({ 'INTERPOLATE' => 0,
 141                                  'EVAL_PERL'   => 0,
 142                                  'ABSOLUTE'    => 1,
 143                                  'CACHE_SIZE'  => 0,
 144                                });
 145
 146   return unless $template;
 147   my $email_template = $self->config->{email_template};
 148   my $filename       = $email_template || ( ($user->get_config_value('templates') || "templates/mails") . "/self_test/status_mail.txt" );
 149   my $content_type   = $filename =~ m/.html$/ ? 'text/html' : 'text/plain';
 150
 151
 152   my %params = (
 153     SELF     => $self,
 154     host     => hostname,
 155     database => $::myconfig{dbname},
 156     path     => $FindBin::Bin,
 157   );
 158
 159   my $output;
 160   $template->process($filename, \%params, \$output) || die $template->error;
 161
 162   return (\$output, $content_type);
 163 }
 164
 165 sub log {
 166   my $self = shift;
 167   $::lxdebug->message(0, "[" . __PACKAGE__ . "] @_") if $self->config->{log_to_file};
 168 }
 169
 170
 171 1;
 172
 173 __END__
 174
 175 =head1 NAME
 176
 177 SL::BackgroundJob::SelfTest - pluggable self testing
 178
 179 =head1 SYNOPSIS
 180
 181   use SL::BackgroundJob::SelfTest;
 182   SL::BackgroundJob::SelfTest->new->run;;
 183
 184 =head1 DESCRIPTION
 185
 186
 187
 188 =head1 FUNCTIONS
 189
 190 =head1 BUGS
 191
 192 =head1 AUTHOR
 193
 194 =cut