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
|
### Log::Message test suite ###
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir '../lib/Log/Message' if -d '../lib/Log/Message';
unshift @INC, '../../..';
}
}
BEGIN { chdir 't' if -d 't' }
use strict;
use lib qw[../lib to_load];
use Test::More tests => 34;
### use tests
for my $pkg ( qw[ Log::Message Log::Message::Config
Log::Message::Item Log::Message::Handlers]
) {
use_ok( $pkg ) or diag "'$pkg' not found. Dying";
}
### test global stack
{
my $log = Log::Message->new( private => 0 );
is( $log->{STACK}, $Log::Message::STACK, q[Using global stack] );
}
### test using private stack
{
my $log = Log::Message->new( private => 1 );
isnt( $log->{STACK}, $Log::Message::STACK, q[Using private stack] );
$log->store('foo'); $log->store('bar');
### retrieval tests
{
my @list = $log->retrieve();
ok( @list == 2, q[Stored 2 messages] );
}
$log->store('zot'); $log->store('quux');
{
my @list = $log->retrieve( amount => 3 );
ok( @list == 3, q[Retrieving 3 messages] );
}
{
is( $log->first->message, 'foo', q[ Retrieving first message] );
is( $log->final->message, 'quux', q[ Retrieving final message] );
}
{
package Log::Message::Handlers;
sub test { return shift }
sub test2 { shift; return @_ }
package main;
}
$log->store(
message => 'baz',
tag => 'MY TAG',
level => 'test',
);
{
ok( $log->retrieve( message => qr/baz/ ),
q[ Retrieving based on message] );
ok( $log->retrieve( tag => qr/TAG/ ),
q[ Retrieving based on tag] );
ok( $log->retrieve( level => qr/test/ ),
q[ Retrieving based on level] );
}
my $item = $log->retrieve( chrono => 0 );
{
ok( $item, q[Retrieving item] );
is( $item->parent, $log, q[ Item reference to parent] );
is( $item->message, 'baz', q[ Item message stored] );
is( $item->id, 4, q[ Item id stored] );
is( $item->tag, 'MY TAG', q[ Item tag stored] );
is( $item->level, 'test', q[ Item level stored] );
}
{
### shortmess is very different from 5.6.1 => 5.8, so let's
### just check that it is filled.
ok( $item->shortmess, q[Item shortmess stored] );
like( $item->shortmess, qr/\w+/,
q[ Item shortmess stored properly]
);
ok( $item->longmess, q[Item longmess stored] );
like( $item->longmess, qr/Log::Message::store/s,
q[ Item longmess stored properly]
);
my $t = scalar localtime;
$t =~ /(\w+ \w+ \d+)/;
like( $item->when, qr/$1/, q[Item timestamp stored] );
}
{
my $i = $item->test;
my @a = $item->test2(1,2,3);
is( $item, $i, q[Item handler check] );
is_deeply( $item, $i, q[ Item handler deep check] );
is_deeply( \@a, [1,2,3], q[ Item extra argument check] );
}
{
ok( $item->remove, q[Removing item from stack] );
ok( (!grep{ $item eq $_ } $log->retrieve),
q[ Item removed from stack] );
}
{
$log->flush;
ok( @{$log->{STACK}} == 0, q[Flushing stack] );
}
}
### test errors
{ my $log = Log::Message->new( private => 1 );
### store errors
{ ### dont make it print
my $warnings;
local $SIG{__WARN__} = sub { $warnings .= "@_" };
my $rv = $log->store();
ok( !$rv, q[Logging empty message failed] );
like( $warnings, qr/message/, q[ Spotted the error] );
}
### retrieve errors
{ ### dont make it print
my $warnings;
local $SIG{__WARN__} = sub { $warnings .= "@_" };
### XXX whitebox test!
local $Params::Check::VERBOSE = 1; # so the warnings are emitted
local $Params::Check::VERBOSE = 1; # so the warnings are emitted
my $rv = $log->retrieve( frobnitz => $$ );
ok( !$rv, q[Retrieval with bogus args] );
like( $warnings, qr/not a valid key/,
qq[ Spotted the error] );
}
}
|
