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