/usr/share/perl5/Test/Log/Dispatch.pm is in libtest-log-dispatch-perl 0.03-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | package Test::Log::Dispatch;
use Data::Dumper;
use List::MoreUtils qw(first_index);
use Log::Dispatch::Array;
use Test::Builder;
use strict;
use warnings;
use base qw(Log::Dispatch);
our $VERSION = '0.03';
my $tb = Test::Builder->new();
sub new {
my $class = shift;
my $self = $class->SUPER::new();
$self->add(
Log::Dispatch::Array->new(
name => 'test',
min_level => 'debug',
@_
)
);
return $self;
}
sub clear {
my ($self) = @_;
$self->{outputs}{test}{array} = [];
}
sub msgs {
my ($self) = @_;
return $self->{outputs}{test}{array};
}
sub contains_ok {
my ( $self, $regex, $test_name ) = @_;
$test_name ||= "log contains '$regex'";
my $found = first_index { $_->{message} =~ /$regex/ } @{ $self->msgs };
if ( $found != -1 ) {
splice( @{ $self->msgs }, $found, 1 );
$tb->ok( 1, $test_name );
}
else {
$tb->ok( 0, $test_name );
$tb->diag( "could not find message matching $regex; log contains: "
. _dump_one_line( $self->msgs ) );
}
}
sub does_not_contain_ok {
my ( $self, $regex, $test_name ) = @_;
$test_name ||= "log does not contain '$regex'";
my $found = first_index { $_->{message} =~ /$regex/ } @{ $self->msgs };
if ( $found != -1 ) {
$tb->ok( 0, $test_name );
$tb->diag( "found message matching $regex: " . $self->msgs->[$found] );
}
else {
$tb->ok( 1, $test_name );
}
}
sub empty_ok {
my ( $self, $test_name ) = @_;
$test_name ||= "log is empty";
if ( !@{ $self->msgs } ) {
$tb->ok( 1, $test_name );
}
else {
$tb->ok( 0, $test_name );
$tb->diag(
"log is not empty; contains " . _dump_one_line( $self->msgs ) );
$self->clear();
}
}
sub contains_only_ok {
my ( $self, $regex, $test_name ) = @_;
$test_name ||= "log contains only '$regex'";
my $count = scalar( @{ $self->msgs } );
if ( $count == 1 ) {
local $Test::Builder::Level = $Test::Builder::Level + 1;
$self->contains_ok( $regex, $test_name );
}
else {
$tb->ok( 0, $test_name );
$tb->diag(
"log contains $count messages: " . _dump_one_line( $self->msgs ) );
}
}
sub _dump_one_line {
my ($value) = @_;
return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
->Terse(1)->Dump();
}
1;
__END__
=pod
=head1 NAME
Test::Log::Dispatch -- Test what you are logging
=head1 SYNOPSIS
use Test::More;
use Test::Log::Dispatch;
my $log = Test::Log::Dispatch->new();
# ...
# call something that logs to $log
# ...
# now test to make sure you logged the right things
$log->contains_ok(qr/good log message/, "good message was logged");
$log->does_not_contain_ok(qr/unexpected log message/, "unexpected message was not logged");
$log->empty_ok("no more logs");
# or
my $msgs = $log->msgs;
cmp_deeply($msgs, ['msg1', 'msg2', 'msg3']);
=head1 DESCRIPTION
C<Test::Log::Dispatch> is a C<Log::Dispatch> object that keeps track of
everything logged to it in memory, and provides convenient tests against what
has been logged.
=head1 CONSTRUCTOR
The constructor returns a C<Test::Log::Dispatch> object, which inherits from
C<Log::Dispatch> and contains a single C<Log::Dispatch::Array> output at
'debug' level.
The constructor requires no parameters. Any parameters will be forwarded to the
C<Log::Dispatch::Array> constructor. For example, you can pass a I<min_level>
to override the default 'debug'.
=head1 METHODS
The test_name is optional in the *_ok methods; a reasonable default will be
provided.
=over
=item contains_ok ($regex[, $test_name])
Tests that a message in the log buffer matches I<$regex>. On success, the
message is I<removed> from the log buffer (but any other matches are left
untouched).
=item does_not_contain_ok ($regex[, $test_name])
Tests that no message in the log buffer matches I<$regex>.
=item empty_ok ([$test_name])
Tests that there is no log buffer left. On failure, the log buffer is cleared
to limit further cascading failures.
=item contains_only_ok ($regex[, $test_name])
Tests that there is a single message in the log buffer and it matches
I<$regex>. On success, the message is removed.
=item clear ()
Clears the log buffer.
=item msgs ()
Returns the current contents of the log buffer as an array reference, where
each element is a hash containing a I<message> and I<level> key.
=back
=head1 TO DO
=over
=item *
Allow testing of log levels.
=back
=head1 SEE ALSO
L<Log::Dispatch|Log::Dispatch>, L<Test::Log4perl|Test::Log4perl>
=head1 AUTHOR
Jonathan Swartz
=head1 COPYRIGHT & LICENSE
Copyright (C) 2009 Jonathan Swartz, all rights reserved.
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
|