Commit | Line | Data |
f0ac4cdb |
1 | ### Log::Message test suite ### |
2 | BEGIN { |
3 | if( $ENV{PERL_CORE} ) { |
4 | chdir '../lib/Log/Message' if -d '../lib/Log/Message'; |
5 | unshift @INC, '../../..'; |
6 | } |
7 | } |
8 | |
9 | BEGIN { chdir 't' if -d 't' } |
10 | |
11 | |
12 | use strict; |
13 | use lib qw[../lib to_load]; |
14 | use Test::More tests => 34; |
15 | |
16 | ### use tests |
17 | for my $pkg ( qw[ Log::Message Log::Message::Config |
18 | Log::Message::Item Log::Message::Handlers] |
19 | ) { |
20 | use_ok( $pkg ) or diag "'$pkg' not found. Dying"; |
21 | } |
22 | |
23 | ### test global stack |
24 | { |
25 | my $log = Log::Message->new( private => 0 ); |
26 | is( $log->{STACK}, $Log::Message::STACK, q[Using global stack] ); |
27 | } |
28 | |
29 | ### test using private stack |
30 | { |
31 | my $log = Log::Message->new( private => 1 ); |
32 | isnt( $log->{STACK}, $Log::Message::STACK, q[Using private stack] ); |
33 | |
34 | $log->store('foo'); $log->store('bar'); |
35 | |
36 | ### retrieval tests |
37 | { |
38 | my @list = $log->retrieve(); |
39 | |
40 | ok( @list == 2, q[Stored 2 messages] ); |
41 | } |
42 | |
43 | $log->store('zot'); $log->store('quux'); |
44 | |
45 | { |
46 | my @list = $log->retrieve( amount => 3 ); |
47 | |
48 | ok( @list == 3, q[Retrieving 3 messages] ); |
49 | } |
50 | |
51 | { |
52 | is( $log->first->message, 'foo', q[ Retrieving first message] ); |
53 | is( $log->final->message, 'quux', q[ Retrieving final message] ); |
54 | } |
55 | |
56 | { |
57 | package Log::Message::Handlers; |
58 | |
59 | sub test { return shift } |
60 | sub test2 { shift; return @_ } |
61 | |
62 | package main; |
63 | } |
64 | |
65 | $log->store( |
66 | message => 'baz', |
67 | tag => 'MY TAG', |
68 | level => 'test', |
69 | ); |
70 | |
71 | { |
72 | ok( $log->retrieve( message => qr/baz/ ), |
73 | q[ Retrieving based on message] ); |
74 | ok( $log->retrieve( tag => qr/TAG/ ), |
75 | q[ Retrieving based on tag] ); |
76 | ok( $log->retrieve( level => qr/test/ ), |
77 | q[ Retrieving based on level] ); |
78 | } |
79 | |
80 | my $item = $log->retrieve( chrono => 0 ); |
81 | |
82 | { |
83 | ok( $item, q[Retrieving item] ); |
84 | is( $item->parent, $log, q[ Item reference to parent] ); |
85 | is( $item->message, 'baz', q[ Item message stored] ); |
86 | is( $item->id, 4, q[ Item id stored] ); |
87 | is( $item->tag, 'MY TAG', q[ Item tag stored] ); |
88 | is( $item->level, 'test', q[ Item level stored] ); |
89 | } |
90 | |
91 | { |
92 | ### shortmess is very different from 5.6.1 => 5.8, so let's |
93 | ### just check that it is filled. |
94 | ok( $item->shortmess, q[Item shortmess stored] ); |
95 | like( $item->shortmess, qr/\w+/, |
96 | q[ Item shortmess stored properly] |
97 | ); |
98 | |
99 | ok( $item->longmess, q[Item longmess stored] ); |
100 | like( $item->longmess, qr/Log::Message::store/s, |
101 | q[ Item longmess stored properly] |
102 | ); |
103 | |
104 | my $t = scalar localtime; |
105 | $t =~ /(\w+ \w+ \d+)/; |
106 | |
107 | like( $item->when, qr/$1/, q[Item timestamp stored] ); |
108 | } |
109 | |
110 | { |
111 | my $i = $item->test; |
112 | my @a = $item->test2(1,2,3); |
113 | |
114 | is( $item, $i, q[Item handler check] ); |
115 | is_deeply( $item, $i, q[ Item handler deep check] ); |
116 | is_deeply( \@a, [1,2,3], q[ Item extra argument check] ); |
117 | } |
118 | |
119 | { |
120 | ok( $item->remove, q[Removing item from stack] ); |
121 | ok( (!grep{ $item eq $_ } $log->retrieve), |
122 | q[ Item removed from stack] ); |
123 | } |
124 | |
125 | { |
126 | $log->flush; |
127 | ok( @{$log->{STACK}} == 0, q[Flushing stack] ); |
128 | } |
129 | } |
130 | |
131 | ### test errors |
132 | { my $log = Log::Message->new( private => 1 ); |
133 | |
134 | |
135 | ### store errors |
136 | { ### dont make it print |
137 | my $warnings; |
138 | local $SIG{__WARN__} = sub { $warnings .= "@_" }; |
139 | |
140 | my $rv = $log->store(); |
141 | ok( !$rv, q[Logging empty message failed] ); |
142 | like( $warnings, qr/message/, q[ Spotted the error] ); |
143 | } |
144 | |
145 | ### retrieve errors |
146 | { ### dont make it print |
147 | my $warnings; |
148 | local $SIG{__WARN__} = sub { $warnings .= "@_" }; |
149 | |
150 | ### XXX whitebox test! |
151 | local $Params::Check::VERBOSE = 1; # so the warnings are emitted |
760f623a |
152 | local $Params::Check::VERBOSE = 1; # so the warnings are emitted |
f0ac4cdb |
153 | |
154 | my $rv = $log->retrieve( frobnitz => $$ ); |
155 | ok( !$rv, q[Retrieval with bogus args] ); |
156 | like( $warnings, qr/not a valid key/, |
157 | qq[ Spotted the error] ); |
158 | } |
159 | } |
160 | |
161 | |
162 | |
163 | |
164 | |
165 | |
166 | |
167 | |
168 | |
169 | |
170 | |
171 | |
172 | |
173 | |
174 | |
175 | |
176 | |