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             next unless $logger->$is_level;
  37             push(@loggers, $logger);
  38         }
  39     }
  40
  41     $self->_clean_connections if $need_clean;
  42
  43     return @loggers;
  44 }
  45
  46 sub handle_log_request {
  47     my ($self, $metadata_in, $generator, @args) = @_;
  48     my %metadata = %{$metadata_in};
  49     my $level = $metadata{level};
  50     my $package = $metadata{package};
  51     my $need_clean = 0;
  52
  53     #caller_level is useless when log forwarding is in place
  54     #so we won't tempt people with using it for now - access
  55     #to caller level will be available in the future
  56     delete $metadata{caller_level};
  57     $metadata{object_remote} = $self->_remote_metadata;
  58
  59     foreach my $logger ($self->_get_loggers(%metadata)) {
  60         $logger->$level([ $generator->(@args) ], \%metadata);
  61     }
  62 }
  63
  64 sub connect {
  65     my ($self, $destination) = @_;
  66     my $wrapped;
  67
  68     if (ref($destination) ne 'CODE') {
  69         $wrapped = sub { $destination };
  70     } else {
  71         $wrapped = $destination;
  72     }
  73
  74     push(@{$self->_connections}, $wrapped);
  75 }
  76
  77 sub _clean_connections {
  78     my ($self) = @_;
  79     @{$self->{_connections}} = grep { defined } @{$self->{_connections}};
  80 }
  81
  82 1;