line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Log::Message; |
2
|
2
|
|
|
2
|
|
28434
|
use if $] > 5.017, 'deprecate'; |
|
2
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
17
|
|
3
|
|
|
|
|
|
|
|
4
|
2
|
|
|
2
|
|
1780
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
196
|
|
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
1054
|
use Params::Check qw[check]; |
|
2
|
|
|
|
|
5809
|
|
|
2
|
|
|
|
|
157
|
|
7
|
2
|
|
|
2
|
|
1887
|
use Log::Message::Item; |
|
2
|
|
|
|
|
27
|
|
|
2
|
|
|
|
|
61
|
|
8
|
2
|
|
|
2
|
|
593
|
use Log::Message::Config; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
69
|
|
9
|
2
|
|
|
2
|
|
13
|
use Locale::Maketext::Simple Style => 'gettext'; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
17
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
local $Params::Check::VERBOSE = 1; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
BEGIN { |
14
|
2
|
|
|
2
|
|
1181
|
use vars qw[$VERSION @ISA $STACK $CONFIG]; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
139
|
|
15
|
2
|
|
|
2
|
|
4
|
$VERSION = '0.08'; |
16
|
2
|
|
|
|
|
1668
|
$STACK = []; |
17
|
|
|
|
|
|
|
} |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=pod |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 NAME |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
Log::Message - A generic message storing mechanism; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 SYNOPSIS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
use Log::Message private => 0, config => '/our/cf_file'; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
my $log = Log::Message->new( private => 1, |
31
|
|
|
|
|
|
|
level => 'log', |
32
|
|
|
|
|
|
|
config => '/my/cf_file', |
33
|
|
|
|
|
|
|
); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$log->store('this is my first message'); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
$log->store( message => 'message #2', |
38
|
|
|
|
|
|
|
tag => 'MY_TAG', |
39
|
|
|
|
|
|
|
level => 'carp', |
40
|
|
|
|
|
|
|
extra => ['this is an argument to the handler'], |
41
|
|
|
|
|
|
|
); |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my @last_five_items = $log->retrieve(5); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my @items = $log->retrieve( tag => qr/my_tag/i, |
46
|
|
|
|
|
|
|
message => qr/\d/, |
47
|
|
|
|
|
|
|
remove => 1, |
48
|
|
|
|
|
|
|
); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
my @items = $log->final( level => qr/carp/, amount => 2 ); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
my $first_error = $log->first() |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# croak with the last error on the stack |
55
|
|
|
|
|
|
|
$log->final->croak; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# empty the stack |
58
|
|
|
|
|
|
|
$log->flush(); |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=head1 DESCRIPTION |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
Log::Message is a generic message storage mechanism. |
64
|
|
|
|
|
|
|
It allows you to store messages on a stack -- either shared or private |
65
|
|
|
|
|
|
|
-- and assign meta-data to it. |
66
|
|
|
|
|
|
|
Some meta-data will automatically be added for you, like a timestamp |
67
|
|
|
|
|
|
|
and a stack trace, but some can be filled in by the user, like a tag |
68
|
|
|
|
|
|
|
by which to identify it or group it, and a level at which to handle |
69
|
|
|
|
|
|
|
the message (for example, log it, or die with it) |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
Log::Message also provides a powerful way of searching through items |
72
|
|
|
|
|
|
|
by regexes on messages, tags and level. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=head1 Hierarchy |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
There are 4 modules of interest when dealing with the Log::Message::* |
77
|
|
|
|
|
|
|
modules: |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=over 4 |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=item Log::Message |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
Log::Message provides a few methods to manipulate the stack it keeps. |
84
|
|
|
|
|
|
|
It has the option of keeping either a private or a public stack. |
85
|
|
|
|
|
|
|
More on this below. |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=item Log::Message::Item |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
These are individual message items, which are objects that contain |
90
|
|
|
|
|
|
|
the user message as well as the meta-data described above. |
91
|
|
|
|
|
|
|
See the L manpage to see how to extract this |
92
|
|
|
|
|
|
|
meta-data and how to work with the Item objects. |
93
|
|
|
|
|
|
|
You should never need to create your own Item objects, but knowing |
94
|
|
|
|
|
|
|
about their methods and accessors is important if you want to write |
95
|
|
|
|
|
|
|
your own handlers. (See below) |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=item Log::Message::Handlers |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
These are a collection of handlers that will be called for a level |
100
|
|
|
|
|
|
|
that is used on a L object. |
101
|
|
|
|
|
|
|
For example, if a message is logged with the 'carp' level, the 'carp' |
102
|
|
|
|
|
|
|
handler from L will be called. |
103
|
|
|
|
|
|
|
See the L manpage for more explanation about how |
104
|
|
|
|
|
|
|
handlers work, which one are available and how to create your own. |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=item Log::Message::Config |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
Per Log::Message object, there is a configuration required that will |
109
|
|
|
|
|
|
|
fill in defaults if the user did not specify arguments to override |
110
|
|
|
|
|
|
|
them (like for example what tag will be set if none was provided), |
111
|
|
|
|
|
|
|
L handles the creation of these configurations. |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
Configuration can be specified in 4 ways: |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=over 4 |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=item * |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
As a configuration file when you C |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=item * |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
As arguments when you C |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=item * |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
As a configuration file when you create a new L object. |
128
|
|
|
|
|
|
|
(The config will then only apply to that object if you marked it as |
129
|
|
|
|
|
|
|
private) |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=item * |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
As arguments when you create a new Log::Message object. |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
You should never need to use the L module yourself, |
136
|
|
|
|
|
|
|
as this is transparently done by L, but its manpage does |
137
|
|
|
|
|
|
|
provide an explanation of how you can create a config file. |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=back |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=back |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=head1 Options |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
When using Log::Message, or creating a new Log::Message object, you can |
146
|
|
|
|
|
|
|
supply various options to alter its behaviour. |
147
|
|
|
|
|
|
|
Of course, there are sensible defaults should you choose to omit these |
148
|
|
|
|
|
|
|
options. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
Below an explanation of all the options and how they work. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=over 4 |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=item config |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
The path to a configuration file to be read. |
157
|
|
|
|
|
|
|
See the manpage of L for the required format |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
These options will be overridden by any explicit arguments passed. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=item private |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
Whether to create, by default, private or shared objects. |
164
|
|
|
|
|
|
|
If you choose to create shared objects, all Log::Message objects will |
165
|
|
|
|
|
|
|
use the same stack. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
This means that even though every module may make its own $log object |
168
|
|
|
|
|
|
|
they will still be sharing the same error stack on which they are |
169
|
|
|
|
|
|
|
putting errors and from which they are retrieving. |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
This can be useful in big projects. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
If you choose to create a private object, then the stack will of |
174
|
|
|
|
|
|
|
course be private to this object, but it will still fall back to the |
175
|
|
|
|
|
|
|
shared config should no private config or overriding arguments be |
176
|
|
|
|
|
|
|
provided. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=item verbose |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
Log::Message makes use of another module to validate its arguments, |
181
|
|
|
|
|
|
|
which is called L, which is a lightweight, yet |
182
|
|
|
|
|
|
|
powerful input checker and parser. (See the L |
183
|
|
|
|
|
|
|
manpage for details). |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
The verbose setting will control whether this module will |
186
|
|
|
|
|
|
|
generate warnings if something improper is passed as input, or merely |
187
|
|
|
|
|
|
|
silently returns undef, at which point Log::Message will generate a |
188
|
|
|
|
|
|
|
warning. |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
It's best to just leave this at its default value, which is '1' |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=item tag |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
The tag to add to messages if none was provided. If neither your |
195
|
|
|
|
|
|
|
config, nor any specific arguments supply a tag, then Log::Message will |
196
|
|
|
|
|
|
|
set it to 'NONE' |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
Tags are useful for searching on or grouping by. For example, you |
199
|
|
|
|
|
|
|
could tag all the messages you want to go to the user as 'USER ERROR' |
200
|
|
|
|
|
|
|
and all those that are only debug information with 'DEBUG'. |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
At the end of your program, you could then print all the ones tagged |
203
|
|
|
|
|
|
|
'USER ERROR' to STDOUT, and those marked 'DEBUG' to a log file. |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=item level |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
C describes what action to take when a message is logged. Just |
208
|
|
|
|
|
|
|
like C, Log::Message will provide a default (which is 'log') if |
209
|
|
|
|
|
|
|
neither your config file, nor any explicit arguments are given to |
210
|
|
|
|
|
|
|
override it. |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
See the Log::Message::Handlers manpage to see what handlers are |
213
|
|
|
|
|
|
|
available by default and what they do, as well as to how to add your |
214
|
|
|
|
|
|
|
own handlers. |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=item remove |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
This indicates whether or not to automatically remove the messages |
219
|
|
|
|
|
|
|
from the stack when you've retrieved them. |
220
|
|
|
|
|
|
|
The default setting provided by Log::Message is '0': do not remove. |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=item chrono |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
This indicates whether messages should always be fetched in |
225
|
|
|
|
|
|
|
chronological order or not. |
226
|
|
|
|
|
|
|
This simply means that you can choose whether, when retrieving items, |
227
|
|
|
|
|
|
|
the item most recently added should be returned first, or the one that |
228
|
|
|
|
|
|
|
had been added most long ago. |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
The default is to return the newest ones first |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=back |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=cut |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
### subs ### |
238
|
|
|
|
|
|
|
sub import { |
239
|
2
|
|
|
2
|
|
104
|
my $pkg = shift; |
240
|
2
|
|
|
|
|
6
|
my %hash = @_; |
241
|
|
|
|
|
|
|
|
242
|
2
|
50
|
|
|
|
13
|
$CONFIG = new Log::Message::Config( %hash ) |
243
|
|
|
|
|
|
|
or die loc(qq[Problem initialising %1], __PACKAGE__); |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
=head1 Methods |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=head2 new |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
This creates a new Log::Message object; The parameters it takes are |
252
|
|
|
|
|
|
|
described in the C section below and let it just be repeated |
253
|
|
|
|
|
|
|
that you can use these options like this: |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
my $log = Log::Message->new( %options ); |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
as well as during C |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
use Log::Message option1 => value, option2 => value |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
There are but 3 rules to keep in mind: |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=over 4 |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=item * |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
Provided arguments take precedence over a configuration file. |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
=item * |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
Arguments to new take precedence over options provided at C |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=item * |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
An object marked private will always have an empty stack to begin with |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=back |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=cut |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub new { |
282
|
7
|
|
|
7
|
1
|
2947
|
my $class = shift; |
283
|
7
|
|
|
|
|
21
|
my %hash = @_; |
284
|
|
|
|
|
|
|
|
285
|
7
|
50
|
|
|
|
39
|
my $conf = new Log::Message::Config( %hash, default => $CONFIG ) or return undef; |
286
|
|
|
|
|
|
|
|
287
|
7
|
100
|
66
|
|
|
54
|
if( $conf->private || $CONFIG->private ) { |
288
|
|
|
|
|
|
|
|
289
|
5
|
|
|
|
|
14
|
return _new_stack( $class, config => $conf ); |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
} else { |
292
|
2
|
|
|
|
|
9
|
my $obj = _new_stack( $class, config => $conf, stack => $STACK ); |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
### if it was an empty stack, this was the first object |
295
|
|
|
|
|
|
|
### in that case, set the global stack to match it for |
296
|
|
|
|
|
|
|
### subsequent new, non-private objects |
297
|
2
|
50
|
|
|
|
153
|
$STACK = $obj->{STACK} unless scalar @$STACK; |
298
|
|
|
|
|
|
|
|
299
|
2
|
|
|
|
|
9
|
return $obj; |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
sub _new_stack { |
304
|
7
|
|
|
7
|
|
12
|
my $class = shift; |
305
|
7
|
|
|
|
|
19
|
my %hash = @_; |
306
|
|
|
|
|
|
|
|
307
|
7
|
|
|
|
|
50
|
my $tmpl = { |
308
|
|
|
|
|
|
|
stack => { default => [] }, |
309
|
|
|
|
|
|
|
config => { default => bless( {}, 'Log::Message::Config'), |
310
|
|
|
|
|
|
|
required => 1, |
311
|
|
|
|
|
|
|
strict_type => 1 |
312
|
|
|
|
|
|
|
}, |
313
|
|
|
|
|
|
|
}; |
314
|
|
|
|
|
|
|
|
315
|
7
|
50
|
|
|
|
39
|
my $args = check( $tmpl, \%hash, $CONFIG->verbose ) or ( |
316
|
|
|
|
|
|
|
warn(loc(q[Could not create a new stack object: %1], |
317
|
|
|
|
|
|
|
Params::Check->last_error) |
318
|
|
|
|
|
|
|
), |
319
|
|
|
|
|
|
|
return |
320
|
|
|
|
|
|
|
); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
|
323
|
7
|
|
|
|
|
460
|
my %self = map { uc, $args->{$_} } keys %$args; |
|
14
|
|
|
|
|
51
|
|
324
|
|
|
|
|
|
|
|
325
|
7
|
|
|
|
|
50
|
return bless \%self, $class; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub _get_conf { |
329
|
32
|
|
|
32
|
|
42
|
my $self = shift; |
330
|
32
|
|
|
|
|
40
|
my $what = shift; |
331
|
|
|
|
|
|
|
|
332
|
32
|
0
|
|
|
|
180
|
return defined $self->{CONFIG}->$what() |
|
|
50
|
|
|
|
|
|
333
|
|
|
|
|
|
|
? $self->{CONFIG}->$what() |
334
|
|
|
|
|
|
|
: defined $CONFIG->$what() |
335
|
|
|
|
|
|
|
? $CONFIG->$what() |
336
|
|
|
|
|
|
|
: undef; # should never get here |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
=head2 store |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
This will create a new Item object and store it on the stack. |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
Possible arguments you can give to it are: |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
=over 4 |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
=item message |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
This is the only argument that is required. If no other arguments |
350
|
|
|
|
|
|
|
are given, you may even leave off the C key. The argument |
351
|
|
|
|
|
|
|
will then automatically be assumed to be the message. |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=item tag |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
The tag to add to this message. If not provided, Log::Message will look |
356
|
|
|
|
|
|
|
in your configuration for one. |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=item level |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
The level at which this message should be handled. If not provided, |
361
|
|
|
|
|
|
|
Log::Message will look in your configuration for one. |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=item extra |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
This is an array ref with arguments passed to the handler for this |
366
|
|
|
|
|
|
|
message, when it is called from store(); |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
The handler will receive them as a normal list |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
=back |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
store() will return true upon success and undef upon failure, as well |
373
|
|
|
|
|
|
|
as issue a warning as to why it failed. |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
=cut |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
### should extra be stored in the item object perhaps for later retrieval? |
378
|
|
|
|
|
|
|
sub store { |
379
|
6
|
|
|
6
|
1
|
1747
|
my $self = shift; |
380
|
6
|
|
|
|
|
14
|
my %hash = (); |
381
|
|
|
|
|
|
|
|
382
|
6
|
|
|
|
|
30
|
my $tmpl = { |
383
|
|
|
|
|
|
|
message => { |
384
|
|
|
|
|
|
|
default => '', |
385
|
|
|
|
|
|
|
strict_type => 1, |
386
|
|
|
|
|
|
|
required => 1, |
387
|
|
|
|
|
|
|
}, |
388
|
|
|
|
|
|
|
tag => { default => $self->_get_conf('tag') }, |
389
|
|
|
|
|
|
|
level => { default => $self->_get_conf('level'), }, |
390
|
|
|
|
|
|
|
extra => { default => [], strict_type => 1 }, |
391
|
|
|
|
|
|
|
}; |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
### single arg means just the message |
394
|
|
|
|
|
|
|
### otherwise, they are named |
395
|
6
|
100
|
|
|
|
21
|
if( @_ == 1 ) { |
396
|
4
|
|
|
|
|
10
|
$hash{message} = shift; |
397
|
|
|
|
|
|
|
} else { |
398
|
2
|
|
|
|
|
40
|
%hash = @_; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
6
|
100
|
|
|
|
21
|
my $args = check( $tmpl, \%hash ) or ( |
402
|
|
|
|
|
|
|
warn( loc(q[Could not store error: %1], Params::Check->last_error) ), |
403
|
|
|
|
|
|
|
return |
404
|
|
|
|
|
|
|
); |
405
|
|
|
|
|
|
|
|
406
|
5
|
|
|
|
|
459
|
my $extra = delete $args->{extra}; |
407
|
5
|
|
|
|
|
24
|
my $item = Log::Message::Item->new( %$args, |
408
|
|
|
|
|
|
|
parent => $self, |
409
|
5
|
50
|
|
|
|
12
|
id => scalar @{$self->{STACK}} |
410
|
|
|
|
|
|
|
) |
411
|
|
|
|
|
|
|
or ( warn( loc(q[Could not create new log item!]) ), return undef ); |
412
|
|
|
|
|
|
|
|
413
|
5
|
|
|
|
|
12
|
push @{$self->{STACK}}, $item; |
|
5
|
|
|
|
|
12
|
|
414
|
|
|
|
|
|
|
|
415
|
2
|
|
|
2
|
|
12
|
{ no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
1340
|
|
|
5
|
|
|
|
|
6
|
|
416
|
|
|
|
|
|
|
|
417
|
5
|
|
|
|
|
8
|
my $sub = $args->{level}; |
418
|
|
|
|
|
|
|
|
419
|
5
|
|
|
|
|
37
|
$item->$sub( @$extra ); |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
5
|
|
|
|
|
35
|
return 1; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
=head2 retrieve |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
This will retrieve all message items matching the criteria specified |
428
|
|
|
|
|
|
|
from the stack. |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
Here are the criteria you can discriminate on: |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
=over 4 |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=item tag |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
A regex to which the tag must adhere. For example C. |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
=item level |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
A regex to which the level must adhere. |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
=item message |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
A regex to which the message must adhere. |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=item amount |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
Maximum amount of errors to return |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=item chrono |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
Return in chronological order, or not? |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
=item remove |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
Remove items from the stack upon retrieval? |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
=back |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
In scalar context it will return the first item matching your criteria |
461
|
|
|
|
|
|
|
and in list context, it will return all of them. |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
If an error occurs while retrieving, a warning will be issued and |
464
|
|
|
|
|
|
|
undef will be returned. |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=cut |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
sub retrieve { |
469
|
10
|
|
|
10
|
1
|
1853
|
my $self = shift; |
470
|
10
|
|
|
|
|
22
|
my %hash = (); |
471
|
|
|
|
|
|
|
|
472
|
10
|
|
|
|
|
128
|
my $tmpl = { |
473
|
|
|
|
|
|
|
tag => { default => qr/.*/ }, |
474
|
|
|
|
|
|
|
level => { default => qr/.*/ }, |
475
|
|
|
|
|
|
|
message => { default => qr/.*/ }, |
476
|
|
|
|
|
|
|
amount => { default => '' }, |
477
|
|
|
|
|
|
|
remove => { default => $self->_get_conf('remove') }, |
478
|
|
|
|
|
|
|
chrono => { default => $self->_get_conf('chrono') }, |
479
|
|
|
|
|
|
|
}; |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
### single arg means just the amount |
482
|
|
|
|
|
|
|
### otherwise, they are named |
483
|
10
|
50
|
|
|
|
41
|
if( @_ == 1 ) { |
484
|
0
|
|
|
|
|
0
|
$hash{amount} = shift; |
485
|
|
|
|
|
|
|
} else { |
486
|
10
|
|
|
|
|
30
|
%hash = @_; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
10
|
50
|
|
|
|
38
|
my $args = check( $tmpl, \%hash ) or ( |
490
|
|
|
|
|
|
|
warn( loc(q[Could not parse input: %1], Params::Check->last_error) ), |
491
|
|
|
|
|
|
|
return |
492
|
|
|
|
|
|
|
); |
493
|
|
|
|
|
|
|
|
494
|
30
|
100
|
|
|
|
124
|
my @list = |
495
|
34
|
100
|
|
|
|
219
|
grep { $_->tag =~ /$args->{tag}/ ? 1 : 0 } |
496
|
38
|
100
|
|
|
|
172
|
grep { $_->level =~ /$args->{level}/ ? 1 : 0 } |
497
|
39
|
|
|
|
|
73
|
grep { $_->message =~ /$args->{message}/ ? 1 : 0 } |
498
|
8
|
|
|
|
|
25
|
grep { defined } |
499
|
|
|
|
|
|
|
$args->{chrono} |
500
|
2
|
|
|
|
|
6
|
? @{$self->{STACK}} |
501
|
10
|
100
|
|
|
|
1871
|
: reverse @{$self->{STACK}}; |
502
|
|
|
|
|
|
|
|
503
|
10
|
|
100
|
|
|
41
|
my $amount = $args->{amount} || scalar @list; |
504
|
|
|
|
|
|
|
|
505
|
19
|
50
|
|
|
|
55
|
my @rv = map { |
506
|
10
|
100
|
|
|
|
30
|
$args->{remove} ? $_->remove : $_ |
507
|
|
|
|
|
|
|
} scalar @list > $amount |
508
|
|
|
|
|
|
|
? splice(@list,0,$amount) |
509
|
|
|
|
|
|
|
: @list; |
510
|
|
|
|
|
|
|
|
511
|
10
|
100
|
|
|
|
124
|
return wantarray ? @rv : $rv[0]; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=head2 first |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
This is a shortcut for retrieving the first item(s) stored on the |
517
|
|
|
|
|
|
|
stack. It will default to only retrieving one if called with no |
518
|
|
|
|
|
|
|
arguments, and will always return results in chronological order. |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
If you only supply one argument, it is assumed to be the amount you |
521
|
|
|
|
|
|
|
wish returned. |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
Furthermore, it can take the same arguments as C can. |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
=cut |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
sub first { |
528
|
1
|
|
|
1
|
1
|
592
|
my $self = shift; |
529
|
|
|
|
|
|
|
|
530
|
1
|
50
|
|
|
|
7
|
my $amt = @_ == 1 ? shift : 1; |
531
|
1
|
|
|
|
|
4
|
return $self->retrieve( amount => $amt, @_, chrono => 1 ); |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
=head2 last |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
This is a shortcut for retrieving the last item(s) stored on the |
537
|
|
|
|
|
|
|
stack. It will default to only retrieving one if called with no |
538
|
|
|
|
|
|
|
arguments, and will always return results in reverse chronological |
539
|
|
|
|
|
|
|
order. |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
If you only supply one argument, it is assumed to be the amount you |
542
|
|
|
|
|
|
|
wish returned. |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
Furthermore, it can take the same arguments as C can. |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
=cut |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
sub final { |
549
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
550
|
|
|
|
|
|
|
|
551
|
1
|
50
|
|
|
|
4
|
my $amt = @_ == 1 ? shift : 1; |
552
|
1
|
|
|
|
|
3
|
return $self->retrieve( amount => $amt, @_, chrono => 0 ); |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
=head2 flush |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
This removes all items from the stack and returns them to the caller |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
=cut |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
sub flush { |
562
|
1
|
|
|
1
|
1
|
310
|
my $self = shift; |
563
|
|
|
|
|
|
|
|
564
|
1
|
|
|
|
|
1
|
return splice @{$self->{STACK}}; |
|
1
|
|
|
|
|
8
|
|
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=head1 SEE ALSO |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
L, L, L |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=head1 AUTHOR |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
This module by |
574
|
|
|
|
|
|
|
Jos Boumans Ekane@cpan.orgE. |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
=head1 Acknowledgements |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
Thanks to Ann Barcomb for her suggestions. |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=head1 COPYRIGHT |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
This module is |
583
|
|
|
|
|
|
|
copyright (c) 2002 Jos Boumans Ekane@cpan.orgE. |
584
|
|
|
|
|
|
|
All rights reserved. |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
This library is free software; |
587
|
|
|
|
|
|
|
you may redistribute and/or modify it under the same |
588
|
|
|
|
|
|
|
terms as Perl itself. |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
=cut |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
1; |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
# Local variables: |
595
|
|
|
|
|
|
|
# c-indentation-style: bsd |
596
|
|
|
|
|
|
|
# c-basic-offset: 4 |
597
|
|
|
|
|
|
|
# indent-tabs-mode: nil |
598
|
|
|
|
|
|
|
# End: |
599
|
|
|
|
|
|
|
# vim: expandtab shiftwidth=4: |