view release on metacpan or  search on metacpan

lib/Test/Log/Log4perl.pm  view on Meta::CPAN

package Log::Log4perl::Logger::Interception;
use base qw(Log::Log4perl::Logger);
use Log::Log4perl qw(:levels);

our %temp;
our %perm;

sub reset_temp { %temp = () }
sub set_temp { my ($class, $key, $val) = @_; $temp{$key} = $val }
sub set_perm { my ($class, $key, $val) = @_; $perm{$key} = $val }
sub ended { my ($class) = @_; $temp{ended} }
# all the basic logging functions
foreach my $level (qw(trace debug info warn error fatal))
{
  no strict 'refs';

  # we need to pass the number to log
  my $level_int = Log::Log4perl::Level::to_priority(uc($level));
  *{"is_".$level} = sub { 1 };
  *{$level} = sub {
   my $self = shift;
   $self->log($level_int, @_)
  }
}

sub log
{
  my $self     = shift;
  my $priority = shift;
  my $message  = join '', grep defined, @_;

  # are we logging anything or what?
  if ($priority <= ($temp{ignore_priority} || 0) or
      $priority <= ($perm{ignore_priority} || 0))
    { return }

  # what's that priority called then?
  my $priority_name = lc( Log::Log4perl::Level::to_level($priority) );

  # find the filename and line
  my ($filename, $line);
  my $cur_filename = _cur_filename();
  my $level = 1;
  do {
    (undef, $filename, $line) = caller($level++);
  } while ($filename eq $cur_filename || $filename eq $INC{"Log/Log4perl/Logger.pm"});

  # log it
  push @Test::Log::Log4perl::logged, {
    category => $self->{category},  # oops, there goes encapsulation
    priority => $priority_name,
    message  => $message,
    filename => $filename,
    line     => $line,
  };

  return;
}

sub _cur_filename { (caller)[1] }

1;

package Log::Log4perl::Logger::IgnoreAll;
use base qw(Log::Log4perl::Logger);

# all the functions we don't want
foreach my $level (qw(trace debug info warn error fatal log))
{
  no strict 'refs';
  *{$level} = sub { return () }
}

=head1 BUGS

Logging methods don't return the number of appenders they've written
to (or rather, they do, as it's always zero.)

Changing the config file (if you're watching it) while this is testing
/ suppressing everything will probably break everything.  As will
creating new appenders, etc...

=head1 AUTHOR

  Chia-liang Kao <clkao@clkao.org>
  Mark Fowler <mark@twoshortplanks.com>

=head1 COPYRIGHT

  Copyright 2010 Chia-liang Kao all rights reserved.
  Copyright 2005 Fotango Ltd all rights reserved.

  Licensed under the same terms as Perl itself.

=cut

1;