lib/Object/Remote/Logging/Router.pm

   1 package Object::Remote::Logging::Router;
   2
   3 use Moo;
   4
   5 with 'Log::Contextual::Role::Router';
   6 with 'Object::Remote::Role::LogForwarder';
   7
   8 has _controller_package => ( is => 'rwp' );
   9 #lookup table for package names that should not
  10 #be forwarded across Object::Remote connections
  11 has _connections => ( is => 'ro', required => 1, default => sub { [] } );
  12 has _remote_metadata => ( is => 'rw' );
  13
  14 sub before_import {
  15   my ($self, $controller, $importer, $spec) = @_;
  16 }
  17
  18 sub after_import { }
  19
  20 sub _get_loggers {
  21   my ($self, %metadata) = @_;
  22   my $package = $metadata{package};
  23   my $level = $metadata{level};
  24   my $is_level = "is_$level";
  25   my $need_clean = 0;
  26   my @loggers;
  27
  28   foreach my $selector (@{$self->_connections}) {
  29     unless(defined $selector) {
  30       $need_clean = 1;
  31       next;
  32     }
  33
  34     foreach my $logger ($selector->($package, { %metadata })) {
  35       next unless defined $logger;
  36       my $method = $logger->can($is_level);
  37       next unless defined $method;
  38       next unless $logger->$method;
  39       push(@loggers, $logger);
  40     }
  41   }
  42
  43   $self->_clean_connections if $need_clean;
  44
  45   return @loggers;
  46 }
  47
  48 sub handle_log_request {
  49   my ($self, $metadata_in, $generator, @args) = @_;
  50   my %metadata = %{$metadata_in};
  51   my $level = $metadata{level};
  52   my $package = $metadata{package};
  53   my $need_clean = 0;
  54
  55   #caller_level is useless when log forwarding is in place
  56   #so we won't tempt people with using it for now - access
  57   #to caller level will be available in the future
  58   delete $metadata{caller_level};
  59   $metadata{object_remote} = $self->_remote_metadata;
  60   $metadata{timestamp} = time;
  61   foreach my $logger ($self->_get_loggers(%metadata)) {
  62     $logger->$level([ $generator->(@args) ], \%metadata);
  63   }
  64 }
  65
  66 sub connect {
  67   my ($self, $destination) = @_;
  68   my $wrapped;
  69
  70   if (ref($destination) ne 'CODE') {
  71     $wrapped = sub { $destination };
  72   } else {
  73     $wrapped = $destination;
  74   }
  75
  76   push(@{$self->_connections}, $wrapped);
  77 }
  78
  79 sub _clean_connections {
  80   my ($self) = @_;
  81   @{$self->{_connections}} = grep { defined } @{$self->{_connections}};
  82 }
  83
  84 1;