view release on metacpan or  search on metacpan

lib/Log/Info.pm  view on Meta::CPAN

sub set_channel_out_level {
  my ($chan, $level) = @_;

  my $logger = Log::Log4perl->get_logger($chan)
    or croak "Channel does not exist: $chan\n";
  if ( defined $level ) {
    $logger->level(LOG4PERL_LEVELS->{$level} // _generate_l4p_level($level));
  } else {
    $logger->level('ALL');
  }
  $logger->set_output_methods;
}

# -------------------------------------

=head2 add_chan_trans

Add a translator to a channel.

=over 4

=item ARGUMENTS

=over 4

=item chan

The channel to add the translator to.

=item trans

The translator to add.  The translator will be called in order after any
previously added translators, and will be given the results of the log string
having been through those translators.  The results of the translation
provided by this translator will be passed to any translators installed after
this one, and to any sink-specific translators.

=back

=back

=cut

sub add_chan_trans {
  my ($chan, $trans, $name) = @_;

  state $trans_name = 'aaa';
  $name //= join ':', qw( trans chan ), $chan, $trans_name++;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  croak sprintf("Translator for channel %s not a subroutine: %s\n",
                $chan, ref $trans || $trans)
    unless UNIVERSAL::isa ($trans, 'CODE');

  push @{$channel{$chan}{trans}}, $trans;
  our %chan_trans;
  $chan_trans{$chan}->{$name} = +{ pos  => $#{$channel{$chan}{trans}},
                                   tran => $trans,
                                   create_line => join(':', (caller)[1,2]),
                                 };
  return $name;
}

sub remove_chan_trans {
  my ($chan, $name) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  our %chan_trans;
  croak "translator '$name' is not on channel '$chan'"
    unless my $trans_info = delete $chan_trans{$chan}->{$name};
  splice @{$channel{$chan}{trans}}, $trans_info->{pos}, 1;
  $_->{pos}--
    for grep $_->{pos} > $trans_info->{pos}, values %{$chan_trans{$chan}};
  return;
}

# Sinks ----------------------------------------------------------------------

=head2 SINKS

=cut

# -------------------------------------

=head2 add_sink

=over 4

=item PRECONDITIONS

  $chan is an existing channel name

  $sink =~ /^[\w-]+$/;

=item ARGUMENTS

=over 4

=item chan

channel to add sink to

=item name

name of sink

=item type

sink type as string.  See L<params|"params"> for acceptable types.

=item level

Output cutoff level.  Set to 'undef' to accept any messages accepted by the
channel.  This level is checked after the channel level; therefore, if this
level is higher than the channel level, it will have no effect.

=item params

lib/Log/Info.pm  view on Meta::CPAN

      if ( exists $redef_subr{$subrname}             or
           ( index($subrname,':') == -1 and
             exists $redef_subr{"main::$subrname"} ) or
           ( $subrname =~ /^(?:main|CORE::GLOBAL)::([a-z_]\w+)$/ and
             exists $redef_subr{$1} )
         ) {
        return;
      }
    }
    my $message = join '', grep defined, @_;
    Log(CHAN_INFO, LOG_WARNING, $message);
    $warnhook->(@_)
      if defined $warnhook and UNIVERSAL::isa($warnhook, 'CODE');
  };

  my $save;

  my $diehook = $SIG{__DIE__};
  # Carp doesn't call die directly.  I know not how or why.  So this traps
  # calls to carp that didn't make it via the override
  $SIG{__DIE__} = sub {
    my $message = join '', grep defined, @_;

    if ( $message !~ /\A[\s\n]*\Z/ ) {
      Log(CHAN_INFO, LOG_ERR, $message)
        unless $dying or $message eq $lastmessage;
    }
    local $dying = 1;
    if ( defined $diehook and UNIVERSAL::isa($diehook, 'CODE') ) {
      $diehook->(@_);
    }
    $! = $save
      if $save;
  };

  # Override Carp messages if present
  for (qw( croak confess )) {
    no strict 'refs';
    my $subr_name = defined $package ? "${package}::$_" : "main::$_";
    my $subr = \&{$subr_name};
    if ( defined $subr ) {
      $redef_subr{$subr_name} = $redef_subr{$_} = 1;
      *{"$subr_name"} = sub {
        $save = $!+0;
        $subr->(@_);
      };
    }
  }

  *CORE::GLOBAL::die =
    sub {
      local $dying = 1;
      $save = $! + 0;
      my $message = join '', grep defined, @_;
      if ( $message !~ /\A[\s\n]*\Z/ ) {
        # Always terminate with a newline.  This ensures conformity of message
        # with that checked in SIG{__DIE__}, which otherwise may have an
        # "\n  at line..." appended.
        # If we want such appendages, we can add them ourselves
        $message =~
          s/([^\n])\z/sprintf("%s at %s line %d", $1, (caller)[1,2]) . "\n"/e;
        $message =~ s/\n+\z/\n/;
        Log(CHAN_INFO, LOG_ERR, "$message")
          unless $message eq $lastmessage;
        $lastmessage = $message;
      }
      $! = $save
        if $save;
      # this causes the message to percolate to the default die handler, which
      # typically writes it to stderr.  So the message may get output twice.
      # That is unfortunate, but we need to do this to ensure that $@ is still
      # set to the message after we exit.  Merely setting $@=$message doesn't
      # do it.
      CORE::die($message);
    };

}

# -------------------------------------

=head2 enable_file_channel

Set up output channel (for string based command-line options).

=over 4

=item ARGUMENTS

=over 4

=item channel_name

name of the channel to log to.

=item fn

value of option presented by user.  If this option looks like a simple number,
it is treated as a log level (see below).  If this option looks like a simple
file name (C<m!^[A-Za-z0-9_.\\/-]+$>), it will be treated as an output file
(but output with the 'FH' type, so no auto-rotate, and special files will
work).  If this option looks like C<m!^:\d+!>, the numeric value will be
treated as a file descriptor, and output sent there.  If this value is
defined, but a blank string, then output will be sent to stderr.

If a value of the form C<\+\d+> precedes a file descriptor, or succeeds a
filename, then the numeric value is used to set the log level of the output
sink.  If not set, it defaults to C<LOG_INFO>, which is equivalent to C<+1>.
Hence, C<+0> is equivalent to C<LOG_INFO - 1>.

If this value is not defined, then no action is taken (this is to allow
compatibility with options processors, where a value is left undefined if its
option is never invoked).

If this value is defined but empty (C<''>), then the log level is set to
LOG_INFO (first time), and the output sent to STDERR.  If the option is seen
again, still with an empty string value, and with the same channel & sink
names, then the log level is increased one place.  This is to allow C<-v -v
-v>(or C<-vvv>)-style options.

=item option_name