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
  14 sub subscribe {
  15   my ($self, $logger, $selector, $is_temp) = @_;
  16   my $subscription_list = $self->subscriptions;
  17
  18   if(ref $logger ne 'CODE') {
  19     die 'logger was not a CodeRef or a logger object.  Please try again.'
  20       unless blessed($logger);
  21     $logger = do { my $l = $logger; sub { $l } }
  22   }
  23
  24    my $subscription = [ $logger, $selector ];
  25
  26    $is_temp = 0 unless defined $is_temp;
  27    push(@$subscription_list, $subscription);
  28    if ($is_temp) {
  29      #weaken($subscription->[-1]);
  30    }
  31    return $subscription;
  32 }
  33
  34 #TODO turn this logic into a role
  35 sub handle_log_message {
  36   my ($self, $caller, $level, $log_meth, @values) = @_;
  37   my $should_clean = 0;
  38
  39   foreach(@{ $self->subscriptions }) {
  40     unless(defined($_)) {
  41       $should_clean = 1;
  42         next;
  43      }
  44      my ($logger, $selector) = @$_;
  45      #TODO this is not a firm part of the api but providing
  46      #this info to the selector is a good feature
  47      local($_) = { level => $level, package => $caller };
  48      if ($selector->(@values)) {
  49         #TODO issues with caller_level have not been resolved yet
  50         #when a logger crosses an object::remote::connection so
  51         $logger = $logger->($caller, { caller_level => -1 });
  52
  53         #TODO there is a known issue with the interaction of this
  54         #routed logging scheme and objects proxied with Object::Remote.
  55         #Specifically the loggers must be invoked with a calling
  56         #depth of 0 which isn't possible using a logger that has
  57         #been proxied which is what happens with routed logging
  58         #if the logger is created in one Perl interpreter and the
  59         #logging happens in another
  60         $logger->$level($log_meth->(@values))
  61           if $logger->${\"is_$level"};
  62      }
  63    }
  64
  65    if ($should_clean) {
  66      $self->_remove_dead_subscriptions;
  67    }
  68
  69    return;
  70 }
  71
  72 sub _remove_dead_subscriptions {
  73   my ($self) = @_;
  74   my @ok = grep { defined $_ } @{$self->subscriptions};
  75   @{$self->subscriptions} = @ok;
  76   return;
  77 }
  78
  79
  80 1;
  81