lib/Object/Remote/LogRouter.pm

   1 package Object::Remote::LogRouter;
   2
   3 use Moo;
   4 use Scalar::Util qw(blessed);
   5
   6 with 'Object::Remote::Role::LogForwarder';
   7
   8 has subscriptions => ( is => 'ro', required => 1, default => sub { [] } );
   9 has description => ( is => 'rw', required => 1 );
  10
  11 sub before_import { }
  12 sub after_import {
  13   my ($self, $controller, $importer, $config) = @_;
  14   my $logger = $controller->arg_logger($config->{logger});
  15
  16 # TODO need to review this concept, ignore these configuration values for now
  17 #   my $package_logger = $controller->arg_package_logger($config->{package_logger});
  18 #   my $default_logger = $config->{default_logger};
  19 #
  20 #   #when installing a new selector this will be the default
  21 #   #logger invoked unless otherwise specified
  22 #   $self->{default_logger} = $default_logger;
  23 #
  24 #   #if the logger configuration value is specified
  25 #   #then all logs given to the router will also be
  26 #   #delivered to that logger
  27 #   if (defined($logger)) {
  28 #      $self->add_selector(sub { 1 }, $logger);
  29 #   }
  30 #
  31 #   #if the configuration specifies a package logger
  32 #   #build a selector that matches the package and
  33 #   #install it
  34 #   if (defined($package_logger)) {
  35 #      $self->add_selector( sub { $_->{package} eq $importer }, $package_logger );
  36 #   }
  37 }
  38
  39 sub subscribe {
  40   my ($self, $logger, $selector, $is_temp) = @_;
  41   my $subscription_list = $self->subscriptions;
  42
  43   if(ref $logger ne 'CODE') {
  44     die 'logger was not a CodeRef or a logger object.  Please try again.'
  45       unless blessed($logger);
  46     $logger = do { my $l = $logger; sub { $l } }
  47   }
  48
  49    my $subscription = [ $logger, $selector ];
  50
  51    $is_temp = 0 unless defined $is_temp;
  52    push(@$subscription_list, $subscription);
  53    if ($is_temp) {
  54      #weaken($subscription->[-1]);
  55    }
  56    return $subscription;
  57 }
  58
  59 #TODO turn this logic into a role
  60 sub handle_log_message {
  61   my ($self, $caller, $level, $log_meth, @values) = @_;
  62   my $should_clean = 0;
  63
  64   foreach(@{ $self->subscriptions }) {
  65     unless(defined($_)) {
  66       $should_clean = 1;
  67         next;
  68      }
  69      my ($logger, $selector) = @$_;
  70      #TODO this is not a firm part of the api but providing
  71      #this info to the selector is a good feature
  72      local($_) = { level => $level, package => $caller };
  73      if ($selector->(@values)) {
  74         #SOLVED resolve caller_level issues with routing
  75         #idea: the caller level will differ in distance from the
  76         #start of the call stack but it's a constant distance from
  77         #the end of the call stack - can that be exploited to calculate
  78         #the distance from the start right before it's used?
  79         #
  80         #newer idea: in order for log4perl to work right the logger
  81         #must be invoked in the exported log_* method directly
  82         #so by passing the logger down the chain of routers
  83         #it can be invoked in that location and the caller level
  84         #problem doesn't exist anymore
  85         $logger = $logger->($caller, { caller_level => -1 });
  86
  87         #TODO there is a known issue with the interaction of this
  88         #routed logging scheme and objects proxied with Object::Remote.
  89         #Specifically the loggers must be invoked with a calling
  90         #depth of 0 which isn't possible using a logger that has
  91         #been proxied which is what happens with routed logging
  92         #if the logger is created in one Perl interpreter and the
  93         #logging happens in another
  94         $logger->$level($log_meth->(@values))
  95           if $logger->${\"is_$level"};
  96      }
  97    }
  98
  99    if ($should_clean) {
 100      $self->_remove_dead_subscriptions;
 101    }
 102
 103    return;
 104 }
 105
 106 sub _remove_dead_subscriptions {
 107   my ($self) = @_;
 108   my @ok = grep { defined $_ } @{$self->subscriptions};
 109   @{$self->subscriptions} = @ok;
 110   return;
 111 }
 112
 113
 114 1;
 115