[Bps-public-commit] test-log4perl branch, master, updated. 7ab00ce2aa0e0d5ddc336e4d3e1e1b72c85653fa
clkao at bestpractical.com
clkao at bestpractical.com
Tue Nov 10 09:08:01 EST 2009
The branch, master has been updated
via 7ab00ce2aa0e0d5ddc336e4d3e1e1b72c85653fa (commit)
via cd365e64e68132172180b377c31d4e2a8468ae43 (commit)
from c2e76c1ce58e63dfac98bfec23144427cf2fde5a (commit)
Summary of changes:
Build.PL | 22 ++
MANIFEST | 10 +
META.yml | 28 +++
Makefile.PL | 21 ++
README | 198 +++++++++++++++++
lib/Test/Log4perl.pm | 573 ++++++++++++++++++++++++++++++++++++++++++++++++++
t/01basic.t | 143 +++++++++++++
t/02ignore.t | 254 ++++++++++++++++++++++
t/03match.t | 45 ++++
t/04re.t | 49 +++++
10 files changed, 1343 insertions(+), 0 deletions(-)
create mode 100644 Build.PL
create mode 100644 MANIFEST
create mode 100644 META.yml
create mode 100644 Makefile.PL
create mode 100644 README
create mode 100644 lib/Test/Log4perl.pm
create mode 100644 t/01basic.t
create mode 100644 t/02ignore.t
create mode 100644 t/03match.t
create mode 100644 t/04re.t
- Log -----------------------------------------------------------------
commit cd365e64e68132172180b377c31d4e2a8468ae43
Author: Fotango Ltd <cpan at fotango.com>
Date: Mon Aug 7 00:00:00 2006 +0800
initial import of Test::Log4perl 0.1001 from CPAN
git-cpan-module: Test::Log4perl
git-cpan-version: 0.1001
diff --git a/Build.PL b/Build.PL
new file mode 100644
index 0000000..f91c313
--- /dev/null
+++ b/Build.PL
@@ -0,0 +1,22 @@
+#!/usr/bin/perl
+use Module::Build;
+
+Module::Build->new(
+ module_name => 'Test::Log4perl',
+ license => 'perl',
+ create_readme => 1,
+ create_makefile_pl => 'traditional',
+ requires => {
+ 'Lingua::EN::Numbers::Ordinate' => 0,
+ 'Log::Log4perl' => 0,
+ 'Test::Builder' => 0,
+ 'Class::Accessor::Chained' => 0,
+ 'Scalar::Util' => 0,
+ 'Carp' => 0,
+ },
+ build_requires => {
+ 'Test::Builder::Tester' => "0.9",
+ 'Test::More' => 0,
+ 'Test::Exception' => 0,
+ },
+)->create_build_script();
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..477bdec
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,10 @@
+Build.PL
+lib/Test/Log4perl.pm
+t/01basic.t
+t/02ignore.t
+t/03match.t
+t/04re.t
+MANIFEST
+README
+META.yml
+Makefile.PL
\ No newline at end of file
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..c2a9621
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,28 @@
+---
+name: Test-Log4perl
+version: 0.1001
+author: ~
+abstract: test log4perl
+license: perl
+requires:
+ Carp: 0
+ Class::Accessor::Chained: 0
+ Lingua::EN::Numbers::Ordinate: 0
+ Log::Log4perl: 0
+ Scalar::Util: 0
+ Test::Builder: 0
+build_requires:
+ Test::Builder::Tester: 0.9
+ Test::Exception: 0
+ Test::More: 0
+provides:
+ Log::Log4perl::Logger::IgnoreAll:
+ file: lib/Test/Log4perl.pm
+ version: 0.1001
+ Log::Log4perl::Logger::Interception:
+ file: lib/Test/Log4perl.pm
+ version: 0.1001
+ Test::Log4perl:
+ file: lib/Test/Log4perl.pm
+ version: 0.1001
+generated_by: Module::Build version 0.2609
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..54e413a
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,21 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'PL_FILES' => {},
+ 'INSTALLDIRS' => 'site',
+ 'NAME' => 'Test::Log4perl',
+ 'VERSION_FROM' => 'lib/Test/Log4perl.pm',
+ 'PREREQ_PM' => {
+ 'Scalar::Util' => 0,
+ 'Test::Exception' => 0,
+ 'Lingua::EN::Numbers::Ordinate' => 0,
+ 'Test::Builder::Tester' => '0.9',
+ 'Carp' => 0,
+ 'Test::More' => 0,
+ 'Class::Accessor::Chained' => 0,
+ 'Test::Builder' => 0,
+ 'Log::Log4perl' => 0
+ }
+ )
+;
diff --git a/README b/README
new file mode 100644
index 0000000..5517173
--- /dev/null
+++ b/README
@@ -0,0 +1,198 @@
+NAME
+ Test::Log4perl - test log4perl
+
+SYNOPSIS
+ use Test::More tests => 1;
+
+ # setup l4p
+ use Log::Log4Perl;
+ # do your normal Log::Log4Perl setup here
+ use Test::Log4perl;
+
+ # get the loggers
+ my $logger = Log::Log4perl->get_logger("Foo::Bar");
+ my $tlogger = Test::Log4perl->get_logger("Foo::Bar");
+
+ # test l4p
+ Test::Log4perl->start();
+
+ # declare we're going to log something
+ $tlogger->error("This is a test");
+
+ # log that something
+ $logger->error("This is a test");
+
+ # test that those things matched
+ Test::Log4perl->end("Test that that logs okay");
+
+ # we also have a simplified version:
+ {
+ my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ # ... do something that should log 'hello'
+ }
+ # $foo goes out of scope; this triggers the test.
+
+DESCRIPTION
+ This module can be used to test that you're logging the right thing with
+ Log::Log4perl. It checks that we get what, and only what, we expect
+ logged by your code.
+
+ The basic process is very simple. Within your test script you get one or
+ more loggers from Test::Log4perl with the "get_logger" method just like
+ you would with Log::Log4perl. You're going to use these loggers to
+ declare what you think the code you're going to test should be logging.
+
+ # declare a bunch of test loggers
+ my $tlogger = Test::Log4perl->get_logger("Foo::Bar");
+
+ Then, for each test you want to do you need to start up the module.
+
+ # start the test
+ Test::Log4perl->start();
+
+ This diverts all subsequent attempts Log::Log4perl makes to log stuff
+ and records them internally rather than passing them though to the
+ Log4perl appenders as normal.
+
+ You then need to declare with the loggers we created earlier what we
+ hope Log4perl will be asked to log. This is the same syntax as
+ Test::Log4perl uses, except if you want you can use regular expressions:
+
+ $tlogger->debug("fish");
+ $tlogger->warn(qr/bar/);
+
+ You then need to run your code that you're testing.
+
+ # call some code that hopefully will call the log4perl methods
+ # 'debug' with "fish" and 'warn' with something that contains 'bar'
+ some_code();
+
+ We finally need to tell Test::Log4Perl that we're done and it should do
+ the comparisons.
+
+ # start the test
+ Test::Log4perl->end("test name");
+
+ Methods
+ get_logger($category)
+ Returns a new instance of Test::Logger that can be used to log
+ expected messages in the category passed.
+
+ Test::Logger->expect(['dotted.path', 'warn' => qr'this', 'warn' =>
+ qr'that'], ..)
+ Class convenience method. Used like this:
+
+ { # start local scope
+ my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ # ... do something that should log 'hello'
+ } # $foo goes out of scope; this triggers the test.
+
+ start
+ Class method. Start logging. When you call this method it temporarly
+ redirects all logging from the standard logging locations to the
+ internal logging routine until end is called. Takes parameters to
+ change the behavior of this (and only this) test. See below.
+
+ debug(@what)
+ info(@what)
+ warn(@what)
+ error(@what)
+ fatal(@what)
+ Instance methods. String of things that you're expecting to log, at
+ the level you're expecting them, in what class.
+
+ end()
+ end($name)
+ Ends the test and compares what we've got with what we expected.
+ Switches logging back from being captured to going to wherever it
+ was originally directed in the config.
+
+ Ignoring All Logging Messages
+ Sometimes you're going to be testing something that generates a load of
+ spurious log messages that you simply want to ignore without testing
+ their contents, but you don't want to have to reconfigure your log file.
+ The simpliest way to do this is to do:
+
+ use Test::Log4perl;
+ Test::Log4perl->suppress_logging;
+
+ All logging functions stop working. Do not alter the Logging classes
+ (for example, by changing the config file and use Log4perl's
+ "init_and_watch" functionality) after this call has been made.
+
+ This function will be effectivly a no-op if the enviromental variable
+ "NO_SUPRESS_LOGGING" is set to a true value (so if your code is behaving
+ weirdly you can turn all the logging back on from the command line
+ without changing any of the code)
+
+ Selectivly Ignoring Logging Messages By Priority
+ It's a bad idea to completely ignore all messages. What you probably
+ want to do is ignore some of the trivial messages that you don't care
+ about, and just test that there aren't any unexpected messages of a set
+ priority.
+
+ You can temporarly ignore any logging messages that are made by passing
+ parameters to the "start" routine
+
+ # for this test, just ignore DEBUG, INFO, and WARN
+ Test::Log4perl->start( ignore_priority => "warn" );
+
+ # you can use the levels constants to do the same thing
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->start( ignore_priority => $WARN );
+
+ You might want to ignore all logging events at all (this can be used as
+ quick way to not test the actual log messages, but just ignore the
+ output.
+
+ # for this test, ignore everything
+ Test::Log4perl->start( ignore_priority => "everything" );
+
+ # contary to readability, the same thing (try not to write this)
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->start( ignore_priority => $OFF );
+
+ Or you might want to not ignore anything (which is the default, unless
+ you've played with the method calls mentioned below:)
+
+ # for this test, ignore nothing
+ Test::Log4perl->start( ignore_priority => "nothing" );
+
+ # contary to readability, the same thing (try not to write this)
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->start( ignore_priority => $ALL );
+
+ You can also perminatly effect what things are ignored with the
+ "ignore_priority" method call. This persists between tests and isn't
+ autoically reset after each call to "start".
+
+ # ignore DEBUG, INFO and WARN for all future tests
+ Test::Log4perl->ignore_priority("warn");
+
+ # you can use the levels constants to do the same thing
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->ignore_priority($WARN);
+
+ # ignore everything (no log messages will be logged)
+ Test::Log4perl->ignore_priority("everything");
+
+ # ignore nothing (messages will be logged reguardless of priority)
+ Test::Log4perl->ignore_priority("nothing");
+
+ Obviously, you may temporarly override whatever perminant
+
+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 /
+ supressing everything will probably break everything. As will creating
+ new appenders, etc...
+
+AUTHOR
+ Mark Fowler <mark at twoshortplanks.com>
+
+COPYRIGHT
+ Copyright 2005 Fotango Ltd all rights reserved.
+ Licensed under the same terms as Perl itself.
+
diff --git a/lib/Test/Log4perl.pm b/lib/Test/Log4perl.pm
new file mode 100644
index 0000000..9cd183d
--- /dev/null
+++ b/lib/Test/Log4perl.pm
@@ -0,0 +1,564 @@
+package Test::Log4perl;
+use base qw(Class::Accessor::Chained);
+__PACKAGE__->mk_accessors(qw(category));
+
+use strict;
+use warnings;
+
+use Test::Builder;
+my $Tester = Test::Builder->new();
+
+use Lingua::EN::Numbers::Ordinate;
+use Carp qw(croak);
+use Scalar::Util qw(blessed);
+use Log::Log4perl qw(:levels);
+
+our $VERSION = '0.1001';
+
+=head1 NAME
+
+Test::Log4perl - test log4perl
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 1;
+
+ # setup l4p
+ use Log::Log4Perl;
+ # do your normal Log::Log4Perl setup here
+ use Test::Log4perl;
+
+ # get the loggers
+ my $logger = Log::Log4perl->get_logger("Foo::Bar");
+ my $tlogger = Test::Log4perl->get_logger("Foo::Bar");
+
+ # test l4p
+ Test::Log4perl->start();
+
+ # declare we're going to log something
+ $tlogger->error("This is a test");
+
+ # log that something
+ $logger->error("This is a test");
+
+ # test that those things matched
+ Test::Log4perl->end("Test that that logs okay");
+
+ # we also have a simplified version:
+ {
+ my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ # ... do something that should log 'hello'
+ }
+ # $foo goes out of scope; this triggers the test.
+
+=head1 DESCRIPTION
+
+This module can be used to test that you're logging the right thing
+with Log::Log4perl. It checks that we get what, and only what, we
+expect logged by your code.
+
+The basic process is very simple. Within your test script you get
+one or more loggers from B<Test::Log4perl> with the C<get_logger> method
+just like you would with B<Log::Log4perl>. You're going to use these
+loggers to declare what you think the code you're going to test should
+be logging.
+
+ # declare a bunch of test loggers
+ my $tlogger = Test::Log4perl->get_logger("Foo::Bar");
+
+Then, for each test you want to do you need to start up the module.
+
+ # start the test
+ Test::Log4perl->start();
+
+This diverts all subsequent attempts B<Log::Log4perl> makes to log
+stuff and records them internally rather than passing them though to
+the Log4perl appenders as normal.
+
+You then need to declare with the loggers we created earlier what
+we hope Log4perl will be asked to log. This is the same syntax as
+Test::Log4perl uses, except if you want you can use regular expressions:
+
+ $tlogger->debug("fish");
+ $tlogger->warn(qr/bar/);
+
+You then need to run your code that you're testing.
+
+ # call some code that hopefully will call the log4perl methods
+ # 'debug' with "fish" and 'warn' with something that contains 'bar'
+ some_code();
+
+We finally need to tell B<Test::Log4Perl> that we're done and it
+should do the comparisons.
+
+ # start the test
+ Test::Log4perl->end("test name");
+
+=head2 Methods
+
+=over
+
+=item get_logger($category)
+
+Returns a new instance of Test::Logger that can be used to log
+expected messages in the category passed.
+
+=cut
+
+sub get_logger
+{
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->category(shift);
+ return $self;
+}
+
+=item Test::Logger->expect(['dotted.path', 'warn' => qr'this', 'warn' => qr'that'], ..)
+
+Class convenience method. Used like this:
+
+ { # start local scope
+ my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ # ... do something that should log 'hello'
+ } # $foo goes out of scope; this triggers the test.
+
+=cut
+
+sub expect {
+ my ($class, @expects) = @_;
+ my @loggers;
+ $class->start(ignore_priority => "info");
+ for (@expects) {
+ my $name = shift @$_;
+ my $tlogger = $class->get_logger($name);
+ # XXX: respect current loglevel
+ while (my ($level, $what) = splice(@$_, 0, 2)) {
+ $tlogger->$level($what);
+ }
+ push @loggers, $tlogger;
+ }
+ return \@loggers;
+}
+
+
+=item start
+
+Class method. Start logging. When you call this method it temporarly
+redirects all logging from the standard logging locations to the
+internal logging routine until end is called. Takes parameters to
+change the behavior of this (and only this) test. See below.
+
+=cut
+
+# convet a string priority into a digit one
+sub _to_d($)
+{
+ my $priority = shift;
+
+ # check the priority is all digits
+ if ($priority =~ /\D/)
+ {
+ if (lc($priority) eq "everything") { $priority = $OFF }
+ elsif (lc($priority) eq "nothing") { $priority = $ALL }
+ else { $priority = Log::Log4perl::Level::to_priority(uc $priority) }
+ }
+
+ return $priority;
+}
+
+# the list of things we've stored so far
+our @expected;
+our @logged;
+
+sub start
+{
+ my $class = shift;
+ my %args = @_;
+
+ # empty the record
+ @logged = ();
+ @expected = ();
+ $class->interception_class->reset_temp;
+
+ # the priority
+ if ($args{ignore_everything})
+ { $args{ignore_priority} = "everything" }
+ if ($args{ignore_nothing})
+ { $args{ignore_priority} = "nothing" }
+ if (exists $args{ignore_priority})
+ { $class->interception_class->set_temp("ignore_priority",_to_d $args{ignore_priority}) }
+
+ # turn on the interception code
+ foreach (values %$Log::Log4perl::Logger::LOGGERS_BY_NAME)
+ { bless $_, $class->interception_class }
+}
+
+=item debug(@what)
+
+=item info(@what)
+
+=item warn(@what)
+
+=item error(@what)
+
+=item fatal(@what)
+
+Instance methods. String of things that you're expecting to log, at
+the level you're expecting them, in what class.
+
+=cut
+
+sub _log_at_level
+{
+ my $self = shift;
+ my $priority = shift;
+ my $message = shift;
+
+ push @expected, {
+ category => $self->category,
+ priority => $priority,
+ message => $message,
+ };
+}
+
+foreach my $level (qw(debug info warn error fatal))
+{
+ no strict 'refs';
+ *{$level} = sub {
+ my $class = shift;
+ $class->_log_at_level($level, @_)
+ }
+}
+
+=item end()
+
+=item end($name)
+
+Ends the test and compares what we've got with what we expected.
+Switches logging back from being captured to going to wherever
+it was originally directed in the config.
+
+=cut
+
+# eeek, the hard bit
+sub end
+{
+ my $class = shift;
+ my $name = shift || "Log4perl test";
+
+ $class->interception_class->set_temp("ended", 1);
+ # turn off the interception code
+ foreach (values %$Log::Log4perl::Logger::LOGGERS_BY_NAME)
+ { bless $_, $class->original_class }
+
+ my $no;
+ while (@logged)
+ {
+ $no++;
+
+ my $logged = shift @logged;
+ my $expected = shift @expected;
+
+ # not expecting anything?
+ unless ($expected)
+ {
+ $Tester->ok(0,$name);
+ $Tester->diag("Unexpected $logged->{priority} of type '$logged->{category}':\n");
+ $Tester->diag(" '$logged->{message}'");
+ return 0;
+ }
+
+ # was this message what we expected?
+ # ...
+ my %wrong = map { $_ => 1 }
+ grep { !_matches($logged->{ $_ }, $expected->{ $_ }) }
+ qw(category message priority);
+ if (%wrong)
+ {
+ $Tester->ok(0, $name);
+ $Tester->diag(ordinate($no)." message logged wasn't what we expected:");
+ foreach my $thingy (qw(category priority message))
+ {
+ if ($wrong{ $thingy })
+ {
+ $Tester->diag(sprintf(q{ %8s was '%s'}, $thingy, $logged->{ $thingy }));
+ if (ref($expected->{ $thingy }) && ref($expected->{ $thingy }) eq "Regexp")
+ { $Tester->diag(" not like '$expected->{$thingy}'") }
+ else
+ { $Tester->diag(" not '$expected->{$thingy}'") }
+ }
+ }
+ $Tester->diag(" (Offending log call from line $logged->{line} in $logged->{filename})");
+
+ return 0
+
+ }
+ }
+
+ # expected something but didn't get it?
+ if (@expected)
+ {
+ $Tester->ok(0, $name);
+ $Tester->diag("Ended logging run, but still expecting ". at expected." more log(s)");
+ $Tester->diag("Expecting $expected[0]{priority} of type '$expected[0]{category}' next:");
+ $Tester->diag(" '$expected[0]{message}'");
+ return 0;
+ }
+
+ $Tester->ok(1,$name);
+ return 1;
+}
+
+# this is essentially a trivial implementation of perl 6's smart match operator
+sub _matches
+{
+ my $got = shift;
+ my $expected = shift;
+
+ my $ref = ref($expected);
+
+ # compare as a string
+ unless ($ref)
+ { return $expected eq $got }
+
+ # compare a regex?
+ if (ref($expected) eq "Regexp")
+ { return $got =~ $expected }
+
+ # check if it's a reference to something, and die
+ if (!blessed($expected))
+ { croak "Don't know how to compare a reference to a $ref" }
+
+ # it's an object. Is that overloaded in some way?
+ # (note we avoid calling overload::Overloaded unless someone has used
+ # the module first)
+ if (defined(&overload::Overloaded) && overload::Overloaded($expected))
+ { return $expected eq $got }
+
+ croak "Don't know how to compare object $ref";
+}
+
+=back
+
+=head2 Ignoring All Logging Messages
+
+Sometimes you're going to be testing something that generates a load
+of spurious log messages that you simply want to ignore without
+testing their contents, but you don't want to have to reconfigure
+your log file. The simpliest way to do this is to do:
+
+ use Test::Log4perl;
+ Test::Log4perl->suppress_logging;
+
+All logging functions stop working. Do not alter the Logging classes
+(for example, by changing the config file and use Log4perl's
+C<init_and_watch> functionality) after this call has been made.
+
+This function will be effectivly a no-op if the enviromental variable
+C<NO_SUPRESS_LOGGING> is set to a true value (so if your code is
+behaving weirdly you can turn all the logging back on from the command
+line without changing any of the code)
+
+=cut
+
+# TODO: What if someone calls ->start() after this then, eh?
+# currently it'll test the logs and then stop supressing logging
+# is that what we want? Because that's what'll happen.
+
+# I canna spell
+sub supress_logging { my $class = shift; $class->supress_logging(@_) }
+
+sub suppress_logging
+{
+ my $class = shift;
+
+ return if $ENV{NO_SUPRESS_LOGGING};
+
+ # tell this to ignore everything.
+ foreach (values %$Log::Log4perl::Logger::LOGGERS_BY_NAME)
+ { bless $_, $class->ignore_all_class }
+}
+
+=head2 Selectivly Ignoring Logging Messages By Priority
+
+It's a bad idea to completely ignore all messages. What you probably
+want to do is ignore some of the trivial messages that you don't
+care about, and just test that there aren't any unexpected messages
+of a set priority.
+
+You can temporarly ignore any logging messages that are made by
+passing parameters to the C<start> routine
+
+ # for this test, just ignore DEBUG, INFO, and WARN
+ Test::Log4perl->start( ignore_priority => "warn" );
+
+ # you can use the levels constants to do the same thing
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->start( ignore_priority => $WARN );
+
+You might want to ignore all logging events at all (this can be used
+as quick way to not test the actual log messages, but just ignore the
+output.
+
+ # for this test, ignore everything
+ Test::Log4perl->start( ignore_priority => "everything" );
+
+ # contary to readability, the same thing (try not to write this)
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->start( ignore_priority => $OFF );
+
+Or you might want to not ignore anything (which is the default, unless
+you've played with the method calls mentioned below:)
+
+ # for this test, ignore nothing
+ Test::Log4perl->start( ignore_priority => "nothing" );
+
+ # contary to readability, the same thing (try not to write this)
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->start( ignore_priority => $ALL );
+
+You can also perminatly effect what things are ignored with the
+C<ignore_priority> method call. This persists between tests and isn't
+autoically reset after each call to C<start>.
+
+ # ignore DEBUG, INFO and WARN for all future tests
+ Test::Log4perl->ignore_priority("warn");
+
+ # you can use the levels constants to do the same thing
+ use Log::Log4perl qw(:levels);
+ Test::Log4perl->ignore_priority($WARN);
+
+ # ignore everything (no log messages will be logged)
+ Test::Log4perl->ignore_priority("everything");
+
+ # ignore nothing (messages will be logged reguardless of priority)
+ Test::Log4perl->ignore_priority("nothing");
+
+Obviously, you may temporarly override whatever perminant
+
+=cut
+
+sub ignore_priority
+{
+ my $class = shift;
+ my $p = _to_d shift;
+ $class->interception_class->set_temp("ignore_priority", $p);
+ $class->interception_class->set_perm("ignore_priority", $p);
+}
+
+sub ignore_everything
+{
+ my $class = shift;
+ $class->ignore_priority($OFF);
+}
+
+sub ignore_nothing
+{
+ my $class = shift;
+ $class->ignore_priority($ALL);
+}
+
+sub interception_class { "Log::Log4perl::Logger::Interception" }
+sub ignore_all_class { "Log::Log4perl::Logger::IgnoreAll" }
+sub original_class { "Log::Log4perl::Logger" }
+
+sub DESTROY {
+ return if $_[0]->interception_class->ended;
+ goto $_[0]->can('end');
+}
+
+###################################################################################################
+
+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(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));
+ *{$level} = sub {
+ my $self = shift;
+ $self->log($level_int, @_)
+ }
+}
+
+sub log
+{
+ my $self = shift;
+ my $priority = shift;
+ my $message = shift;
+
+ # 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::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(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
+/ supressing everything will probably break everything. As will
+creating new appenders, etc...
+
+=head1 AUTHOR
+
+ Mark Fowler <mark at twoshortplanks.com>
+
+=head1 COPYRIGHT
+
+ Copyright 2005 Fotango Ltd all rights reserved.
+ Licensed under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/t/01basic.t b/t/01basic.t
new file mode 100644
index 0000000..97cc3e6
--- /dev/null
+++ b/t/01basic.t
@@ -0,0 +1,143 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Log::Log4perl;
+# do some setup here...honest guv
+
+use Test::More tests => 9;
+use Test::Builder::Tester;
+use Test::Log4perl;
+use Test::Exception;
+
+my $logger = Log::Log4perl->get_logger("Foo");
+my $tlogger = Test::Log4perl->get_logger("Foo");
+my $t2logger = Test::Log4perl->get_logger("Bar");
+
+########################################################
+
+test_out("ok 1 - Log4perl test");
+
+Test::Log4perl->start();
+$tlogger->error("my hair is on fire!");
+$logger->error("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("basic ok test");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+6);
+test_diag("Unexpected error of type 'Foo':");
+test_diag(" 'my hair is on fire!'");
+
+Test::Log4perl->start();
+$logger->error("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("not expecting anything");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+7);
+test_diag("Ended logging run, but still expecting 1 more log(s)");
+test_diag("Expecting error of type 'Foo' next:");
+test_diag(" 'my hair is on fire!'");
+
+Test::Log4perl->start();
+$tlogger->error("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("expecting but not getting anything");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+9);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" message was 'your hair is on fire!'");
+test_diag(" not 'my hair is on fire!'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+
+Test::Log4perl->start();
+$tlogger->error("my hair is on fire!");
+$logger->error("your hair is on fire!");
+Test::Log4perl->end();
+
+test_test("getting wrong message");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+9);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" priority was 'warn'");
+test_diag(" not 'error'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+
+Test::Log4perl->start();
+$tlogger->error("my hair is on fire!");
+$logger->warn("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("getting wrong priority");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+9);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" category was 'Foo'");
+test_diag(" not 'Bar'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+
+Test::Log4perl->start();
+$t2logger->error("my hair is on fire!");
+$logger->error("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("getting wrong category");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+13);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" category was 'Foo'");
+test_diag(" not 'Bar'");
+test_diag(" priority was 'warn'");
+test_diag(" not 'error'");
+test_diag(" message was 'your hair is on fire!'");
+test_diag(" not 'my hair is on fire!'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+
+Test::Log4perl->start();
+$t2logger->error("my hair is on fire!");
+$logger->warn("your hair is on fire!");
+Test::Log4perl->end();
+
+test_test("getting it all wrong");
+
+########################################################
+
+Test::Log4perl->start();
+$tlogger->fatal("my hair is on fire!");
+
+throws_ok {
+ $logger->logdie("my hair is on fire!");
+} qr/my hair is on fire!/, "logdie dies";
+
+test_out("ok 1 - Log4perl test");
+Test::Log4perl->end();
+test_test("logdie");
+
+##################################
+##################################
+
+sub filename
+{
+ return (caller)[1];
+}
diff --git a/t/02ignore.t b/t/02ignore.t
new file mode 100644
index 0000000..b95c1cf
--- /dev/null
+++ b/t/02ignore.t
@@ -0,0 +1,254 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Log::Log4perl;
+# do some setup here...honest guv
+
+use Test::More tests => 2;
+use Test::Builder::Tester;
+use Test::Log4perl;
+use Test::Exception;
+
+my $logger = Log::Log4perl->get_logger("Foo");
+my $tlogger = Test::Log4perl->get_logger("Foo");
+my $t2logger = Test::Log4perl->get_logger("Bar");
+
+########################################################
+
+# test that we ignore some priorities
+
+test_out("ok 1 - Log4perl test");
+
+Test::Log4perl->start(
+ ignore_priority => "warn",
+);
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+# but they go back at the start of the next thing
+
+test_out("not ok 2 - Log4perl test");
+test_fail(+15);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" priority was 'debug'");
+test_diag(" not 'error'");
+test_diag(" message was 'ignore me'");
+test_diag(" not 'my hair is on fire!'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+Test::Log4perl->start();
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+# test that we can ignore everything
+
+test_out("ok 3 - Log4perl test");
+
+Test::Log4perl->start(
+ ignore_priority => "everything",
+);
+
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("ignore with pleasure");
+$logger->fatal("ignore this finally");
+
+Test::Log4perl->end();
+
+# but they go back at the start of the next thing
+
+test_out("not ok 4 - Log4perl test");
+test_fail(+15);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" priority was 'debug'");
+test_diag(" not 'error'");
+test_diag(" message was 'ignore me'");
+test_diag(" not 'my hair is on fire!'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+Test::Log4perl->start();
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+test_test("ignoring priority");
+
+########################################################
+
+# test that we ignore some priorities forever
+
+test_out("ok 1 - Log4perl test");
+
+Test::Log4perl->start(
+ # this should be overriden
+ ignore_priority => "error",
+);
+
+Test::Log4perl->ignore_priority("warn");
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+# and they don't go back, the ignore priority
+# should still be set
+
+test_out("ok 2 - Log4perl test");
+
+Test::Log4perl->start();
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+# though we can turn them off with ignore nothing
+
+Test::Log4perl->start();
+
+Test::Log4perl->ignore_priority("nothing");
+
+test_out("not ok 3 - Log4perl test");
+test_fail(+15);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" priority was 'debug'");
+test_diag(" not 'error'");
+test_diag(" message was 'ignore me'");
+test_diag(" not 'my hair is on fire!'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+Test::Log4perl->start();
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+# and that's still set next time
+
+Test::Log4perl->start();
+
+test_out("not ok 4 - Log4perl test");
+test_fail(+16);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" priority was 'debug'");
+test_diag(" not 'error'");
+test_diag(" message was 'ignore me'");
+test_diag(" not 'my hair is on fire!'");
+test_diag(" (Offending log call from line ".(__LINE__+5)." in ".filename().")");
+
+Test::Log4perl->start();
+
+$tlogger->error("my hair is on fire!");
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("my hair is on fire!");
+
+Test::Log4perl->end();
+
+# and we can ignore everything
+
+Test::Log4perl->start();
+Test::Log4perl->ignore_priority("everything");
+
+test_out("ok 5 - Log4perl test");
+
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("ignore with pleasure");
+$logger->fatal("ignore this finally");
+
+Test::Log4perl->end();
+
+# and things are still ignored
+
+Test::Log4perl->start();
+Test::Log4perl->ignore_priority("everything");
+
+test_out("ok 6 - Log4perl test");
+
+$logger->debug("ignore me");
+$logger->info("ignore me too");
+$logger->warn("ignore me as well");
+$logger->error("ignore with pleasure");
+$logger->fatal("ignore this finally");
+
+Test::Log4perl->end();
+
+# and we can ignore nothing
+
+Test::Log4perl->start();
+Test::Log4perl->ignore_priority("nothing");
+
+test_out("ok 7 - Log4perl test");
+
+$tlogger->debug("don't ignore me");
+$tlogger->info("don't ignore me too");
+$tlogger->warn("don't ignore me as well");
+$tlogger->error("don't ignore with pleasure");
+$tlogger->fatal("don't ignore this finally");
+$logger->debug("don't ignore me");
+$logger->info("don't ignore me too");
+$logger->warn("don't ignore me as well");
+$logger->error("don't ignore with pleasure");
+$logger->fatal("don't ignore this finally");
+
+Test::Log4perl->end();
+
+# and that remains set too
+
+Test::Log4perl->start();
+
+test_out("ok 8 - Log4perl test");
+
+$tlogger->debug("don't ignore me");
+$tlogger->info("don't ignore me too");
+$tlogger->warn("don't ignore me as well");
+$tlogger->error("don't ignore with pleasure");
+$tlogger->fatal("don't ignore this finally");
+$logger->debug("don't ignore me");
+$logger->info("don't ignore me too");
+$logger->warn("don't ignore me as well");
+$logger->error("don't ignore with pleasure");
+$logger->fatal("don't ignore this finally");
+
+Test::Log4perl->end();
+
+test_test("ignoring priority forever");
+
+##################################
+##################################
+
+sub filename
+{
+ return (caller)[1];
+}
diff --git a/t/03match.t b/t/03match.t
new file mode 100644
index 0000000..3da8dc6
--- /dev/null
+++ b/t/03match.t
@@ -0,0 +1,45 @@
+#!/usr/bin/perl
+
+####################################################################
+# Description of what this test does:
+# Checks to see if _match does the right thing
+####################################################################
+
+use strict;
+use warnings;
+
+# useful diagnostic modules that's good to have loaded
+use Data::Dumper;
+use Devel::Peek;
+
+# colourising the output if we want to
+use Term::ANSIColor qw(:constants);
+$Term::ANSIColor::AUTORESET = 1;
+
+###################################
+# user editable parts
+
+use Test::Exception;
+
+# start the tests
+use Test::More tests => 8;
+
+use Test::Log4perl;
+
+ok(Test::Log4perl::_matches("foo", "foo"), "foo foo");
+ok(!Test::Log4perl::_matches("foo", "bar"), "foo bar");
+
+ok(Test::Log4perl::_matches("foo", qr/foo/), "foo qr/foo/");
+ok(!Test::Log4perl::_matches("foo", qr/bar/), "foo qr/bar/");
+
+dies_ok { Test::Log4perl::_matches("foo", {}) } "hash";
+dies_ok { Test::Log4perl::_matches("foo", bless({}, "bar"))} "object";
+
+package Wibble;
+use overload '""' => "as_string", fallback => 1;
+sub as_string { "foo" };
+
+package main;
+
+ok(Test::Log4perl::_matches("foo", bless({}, "Wibble")), "foo foo object");
+ok(!Test::Log4perl::_matches("bar", bless({}, "Wibble")), "bar foo object ");
\ No newline at end of file
diff --git a/t/04re.t b/t/04re.t
new file mode 100644
index 0000000..f235587
--- /dev/null
+++ b/t/04re.t
@@ -0,0 +1,49 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Log::Log4perl;
+# do some setup here...honest guv
+
+use Test::More tests => 2;
+use Test::Builder::Tester;
+use Test::Log4perl;
+use Test::Exception;
+
+my $logger = Log::Log4perl->get_logger("Foo");
+my $tlogger = Test::Log4perl->get_logger("Foo");
+
+########################################################
+
+test_out("ok 1 - Log4perl test");
+
+Test::Log4perl->start();
+$tlogger->error(qr/hair/);
+$logger->error("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("basic qr test");
+
+########################################################
+
+test_out("not ok 1 - Log4perl test");
+test_fail(+9);
+test_diag("1st message logged wasn't what we expected:");
+test_diag(" message was 'my hair is on fire!'");
+test_diag(" not like '(?-xism:tree)'");
+test_diag(" (Offending log call from line ".(__LINE__+4)." in ".filename().")");
+
+Test::Log4perl->start();
+$tlogger->error(qr/tree/);
+$logger->error("my hair is on fire!");
+Test::Log4perl->end();
+
+test_test("getting wrong message");
+
+########################################################
+
+sub filename
+{
+ return (caller)[1];
+}
commit 7ab00ce2aa0e0d5ddc336e4d3e1e1b72c85653fa
Author: Chia-liang Kao <clkao at clkao.org>
Date: Sat May 2 16:46:12 2009 +0800
- s/Test::Logger/Test::Log4perl/;
- allow the expect helper to pass arguments to Test::Log4perl->start
diff --git a/README b/README
index 5517173..1231cc5 100644
--- a/README
+++ b/README
@@ -24,13 +24,13 @@ SYNOPSIS
# test that those things matched
Test::Log4perl->end("Test that that logs okay");
-
- # we also have a simplified version:
+
+ # we also have a simplified version:
{
- my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ my $foo = Test::Log4perl->expect(['foo.bar.quux', warn => qr/hello/ ]);
# ... do something that should log 'hello'
}
- # $foo goes out of scope; this triggers the test.
+ # $foo goes out of scope; this triggers the test.
DESCRIPTION
This module can be used to test that you're logging the right thing with
@@ -75,15 +75,15 @@ DESCRIPTION
Methods
get_logger($category)
- Returns a new instance of Test::Logger that can be used to log
+ Returns a new instance of Test::Log4perl that can be used to log
expected messages in the category passed.
- Test::Logger->expect(['dotted.path', 'warn' => qr'this', 'warn' =>
- qr'that'], ..)
+ Test::Log4perl->expect(%start_args, ['dotted.path', 'warn' => qr'this',
+ 'warn' => qr'that'], ..)
Class convenience method. Used like this:
{ # start local scope
- my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ my $foo = Test::Log4perl->expect(['foo.bar.quux', warn => qr/hello/ ]);
# ... do something that should log 'hello'
} # $foo goes out of scope; this triggers the test.
diff --git a/lib/Test/Log4perl.pm b/lib/Test/Log4perl.pm
index 9cd183d..bbeecc4 100644
--- a/lib/Test/Log4perl.pm
+++ b/lib/Test/Log4perl.pm
@@ -13,7 +13,7 @@ use Carp qw(croak);
use Scalar::Util qw(blessed);
use Log::Log4perl qw(:levels);
-our $VERSION = '0.1001';
+our $VERSION = '0.1002';
=head1 NAME
@@ -46,7 +46,7 @@ Test::Log4perl - test log4perl
# we also have a simplified version:
{
- my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ my $foo = Test::Log4perl->expect(['foo.bar.quux', warn => qr/hello/ ]);
# ... do something that should log 'hello'
}
# $foo goes out of scope; this triggers the test.
@@ -100,7 +100,7 @@ should do the comparisons.
=item get_logger($category)
-Returns a new instance of Test::Logger that can be used to log
+Returns a new instance of Test::Log4perl that can be used to log
expected messages in the category passed.
=cut
@@ -113,21 +113,30 @@ sub get_logger
return $self;
}
-=item Test::Logger->expect(['dotted.path', 'warn' => qr'this', 'warn' => qr'that'], ..)
+=item Test::Log4perl->expect(%start_args, ['dotted.path', 'warn' => qr'this', 'warn' => qr'that'], ..)
Class convenience method. Used like this:
{ # start local scope
- my $foo = Test::Logger->expect(['foo.bar.quux', warn => qr/hello/ ]);
+ my $foo = Test::Log4perl->expect(['foo.bar.quux', warn => qr/hello/ ]);
# ... do something that should log 'hello'
} # $foo goes out of scope; this triggers the test.
=cut
sub expect {
- my ($class, @expects) = @_;
+ my $class = shift;
+ my (@start_args, @expects);
+ for (@_) {
+ if (ref($_) eq 'ARRAY') {
+ push @expects, $_;
+ }
+ else {
+ push @start_args, $_;
+ }
+ }
+ $class->start(@start_args);
my @loggers;
- $class->start(ignore_priority => "info");
for (@expects) {
my $name = shift @$_;
my $tlogger = $class->get_logger($name);
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list