Initial Commit
This commit is contained in:
Riley Schneider
599
database/perl/vendor/lib/Log/Message.pm
vendored
Normal file
599
database/perl/vendor/lib/Log/Message.pm
vendored
Normal file
@@ -0,0 +1,599 @@
|
||||
package Log::Message;
|
||||
use if $] > 5.017, 'deprecate';
|
||||
|
||||
use strict;
|
||||
|
||||
use Params::Check qw[check];
|
||||
use Log::Message::Item;
|
||||
use Log::Message::Config;
|
||||
use Locale::Maketext::Simple Style => 'gettext';
|
||||
|
||||
local $Params::Check::VERBOSE = 1;
|
||||
|
||||
BEGIN {
|
||||
use vars qw[$VERSION @ISA $STACK $CONFIG];
|
||||
$VERSION = '0.08';
|
||||
$STACK = [];
|
||||
}
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Log::Message - A generic message storing mechanism;
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Log::Message private => 0, config => '/our/cf_file';
|
||||
|
||||
my $log = Log::Message->new( private => 1,
|
||||
level => 'log',
|
||||
config => '/my/cf_file',
|
||||
);
|
||||
|
||||
$log->store('this is my first message');
|
||||
|
||||
$log->store( message => 'message #2',
|
||||
tag => 'MY_TAG',
|
||||
level => 'carp',
|
||||
extra => ['this is an argument to the handler'],
|
||||
);
|
||||
|
||||
my @last_five_items = $log->retrieve(5);
|
||||
|
||||
my @items = $log->retrieve( tag => qr/my_tag/i,
|
||||
message => qr/\d/,
|
||||
remove => 1,
|
||||
);
|
||||
|
||||
my @items = $log->final( level => qr/carp/, amount => 2 );
|
||||
|
||||
my $first_error = $log->first()
|
||||
|
||||
# croak with the last error on the stack
|
||||
$log->final->croak;
|
||||
|
||||
# empty the stack
|
||||
$log->flush();
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Log::Message is a generic message storage mechanism.
|
||||
It allows you to store messages on a stack -- either shared or private
|
||||
-- and assign meta-data to it.
|
||||
Some meta-data will automatically be added for you, like a timestamp
|
||||
and a stack trace, but some can be filled in by the user, like a tag
|
||||
by which to identify it or group it, and a level at which to handle
|
||||
the message (for example, log it, or die with it)
|
||||
|
||||
Log::Message also provides a powerful way of searching through items
|
||||
by regexes on messages, tags and level.
|
||||
|
||||
=head1 Hierarchy
|
||||
|
||||
There are 4 modules of interest when dealing with the Log::Message::*
|
||||
modules:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Log::Message
|
||||
|
||||
Log::Message provides a few methods to manipulate the stack it keeps.
|
||||
It has the option of keeping either a private or a public stack.
|
||||
More on this below.
|
||||
|
||||
=item Log::Message::Item
|
||||
|
||||
These are individual message items, which are objects that contain
|
||||
the user message as well as the meta-data described above.
|
||||
See the L<Log::Message::Item> manpage to see how to extract this
|
||||
meta-data and how to work with the Item objects.
|
||||
You should never need to create your own Item objects, but knowing
|
||||
about their methods and accessors is important if you want to write
|
||||
your own handlers. (See below)
|
||||
|
||||
=item Log::Message::Handlers
|
||||
|
||||
These are a collection of handlers that will be called for a level
|
||||
that is used on a L<Log::Message::Item> object.
|
||||
For example, if a message is logged with the 'carp' level, the 'carp'
|
||||
handler from L<Log::Message::Handlers> will be called.
|
||||
See the L<Log::Message::Handlers> manpage for more explanation about how
|
||||
handlers work, which one are available and how to create your own.
|
||||
|
||||
=item Log::Message::Config
|
||||
|
||||
Per Log::Message object, there is a configuration required that will
|
||||
fill in defaults if the user did not specify arguments to override
|
||||
them (like for example what tag will be set if none was provided),
|
||||
L<Log::Message::Config> handles the creation of these configurations.
|
||||
|
||||
Configuration can be specified in 4 ways:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
As a configuration file when you C<use Log::Message>
|
||||
|
||||
=item *
|
||||
|
||||
As arguments when you C<use Log::Message>
|
||||
|
||||
=item *
|
||||
|
||||
As a configuration file when you create a new L<Log::Message> object.
|
||||
(The config will then only apply to that object if you marked it as
|
||||
private)
|
||||
|
||||
=item *
|
||||
|
||||
As arguments when you create a new Log::Message object.
|
||||
|
||||
You should never need to use the L<Log::Message::Config> module yourself,
|
||||
as this is transparently done by L<Log::Message>, but its manpage does
|
||||
provide an explanation of how you can create a config file.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 Options
|
||||
|
||||
When using Log::Message, or creating a new Log::Message object, you can
|
||||
supply various options to alter its behaviour.
|
||||
Of course, there are sensible defaults should you choose to omit these
|
||||
options.
|
||||
|
||||
Below an explanation of all the options and how they work.
|
||||
|
||||
=over 4
|
||||
|
||||
=item config
|
||||
|
||||
The path to a configuration file to be read.
|
||||
See the manpage of L<Log::Message::Config> for the required format
|
||||
|
||||
These options will be overridden by any explicit arguments passed.
|
||||
|
||||
=item private
|
||||
|
||||
Whether to create, by default, private or shared objects.
|
||||
If you choose to create shared objects, all Log::Message objects will
|
||||
use the same stack.
|
||||
|
||||
This means that even though every module may make its own $log object
|
||||
they will still be sharing the same error stack on which they are
|
||||
putting errors and from which they are retrieving.
|
||||
|
||||
This can be useful in big projects.
|
||||
|
||||
If you choose to create a private object, then the stack will of
|
||||
course be private to this object, but it will still fall back to the
|
||||
shared config should no private config or overriding arguments be
|
||||
provided.
|
||||
|
||||
=item verbose
|
||||
|
||||
Log::Message makes use of another module to validate its arguments,
|
||||
which is called L<Params::Check>, which is a lightweight, yet
|
||||
powerful input checker and parser. (See the L<Params::Check>
|
||||
manpage for details).
|
||||
|
||||
The verbose setting will control whether this module will
|
||||
generate warnings if something improper is passed as input, or merely
|
||||
silently returns undef, at which point Log::Message will generate a
|
||||
warning.
|
||||
|
||||
It's best to just leave this at its default value, which is '1'
|
||||
|
||||
=item tag
|
||||
|
||||
The tag to add to messages if none was provided. If neither your
|
||||
config, nor any specific arguments supply a tag, then Log::Message will
|
||||
set it to 'NONE'
|
||||
|
||||
Tags are useful for searching on or grouping by. For example, you
|
||||
could tag all the messages you want to go to the user as 'USER ERROR'
|
||||
and all those that are only debug information with 'DEBUG'.
|
||||
|
||||
At the end of your program, you could then print all the ones tagged
|
||||
'USER ERROR' to STDOUT, and those marked 'DEBUG' to a log file.
|
||||
|
||||
=item level
|
||||
|
||||
C<level> describes what action to take when a message is logged. Just
|
||||
like C<tag>, Log::Message will provide a default (which is 'log') if
|
||||
neither your config file, nor any explicit arguments are given to
|
||||
override it.
|
||||
|
||||
See the Log::Message::Handlers manpage to see what handlers are
|
||||
available by default and what they do, as well as to how to add your
|
||||
own handlers.
|
||||
|
||||
=item remove
|
||||
|
||||
This indicates whether or not to automatically remove the messages
|
||||
from the stack when you've retrieved them.
|
||||
The default setting provided by Log::Message is '0': do not remove.
|
||||
|
||||
=item chrono
|
||||
|
||||
This indicates whether messages should always be fetched in
|
||||
chronological order or not.
|
||||
This simply means that you can choose whether, when retrieving items,
|
||||
the item most recently added should be returned first, or the one that
|
||||
had been added most long ago.
|
||||
|
||||
The default is to return the newest ones first
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
### subs ###
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my %hash = @_;
|
||||
|
||||
$CONFIG = new Log::Message::Config( %hash )
|
||||
or die loc(qq[Problem initialising %1], __PACKAGE__);
|
||||
|
||||
}
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=head2 new
|
||||
|
||||
This creates a new Log::Message object; The parameters it takes are
|
||||
described in the C<Options> section below and let it just be repeated
|
||||
that you can use these options like this:
|
||||
|
||||
my $log = Log::Message->new( %options );
|
||||
|
||||
as well as during C<use> time, like this:
|
||||
|
||||
use Log::Message option1 => value, option2 => value
|
||||
|
||||
There are but 3 rules to keep in mind:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Provided arguments take precedence over a configuration file.
|
||||
|
||||
=item *
|
||||
|
||||
Arguments to new take precedence over options provided at C<use> time
|
||||
|
||||
=item *
|
||||
|
||||
An object marked private will always have an empty stack to begin with
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $conf = new Log::Message::Config( %hash, default => $CONFIG ) or return undef;
|
||||
|
||||
if( $conf->private || $CONFIG->private ) {
|
||||
|
||||
return _new_stack( $class, config => $conf );
|
||||
|
||||
} else {
|
||||
my $obj = _new_stack( $class, config => $conf, stack => $STACK );
|
||||
|
||||
### if it was an empty stack, this was the first object
|
||||
### in that case, set the global stack to match it for
|
||||
### subsequent new, non-private objects
|
||||
$STACK = $obj->{STACK} unless scalar @$STACK;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
}
|
||||
|
||||
sub _new_stack {
|
||||
my $class = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $tmpl = {
|
||||
stack => { default => [] },
|
||||
config => { default => bless( {}, 'Log::Message::Config'),
|
||||
required => 1,
|
||||
strict_type => 1
|
||||
},
|
||||
};
|
||||
|
||||
my $args = check( $tmpl, \%hash, $CONFIG->verbose ) or (
|
||||
warn(loc(q[Could not create a new stack object: %1],
|
||||
Params::Check->last_error)
|
||||
),
|
||||
return
|
||||
);
|
||||
|
||||
|
||||
my %self = map { uc, $args->{$_} } keys %$args;
|
||||
|
||||
return bless \%self, $class;
|
||||
}
|
||||
|
||||
sub _get_conf {
|
||||
my $self = shift;
|
||||
my $what = shift;
|
||||
|
||||
return defined $self->{CONFIG}->$what()
|
||||
? $self->{CONFIG}->$what()
|
||||
: defined $CONFIG->$what()
|
||||
? $CONFIG->$what()
|
||||
: undef; # should never get here
|
||||
}
|
||||
|
||||
=head2 store
|
||||
|
||||
This will create a new Item object and store it on the stack.
|
||||
|
||||
Possible arguments you can give to it are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item message
|
||||
|
||||
This is the only argument that is required. If no other arguments
|
||||
are given, you may even leave off the C<message> key. The argument
|
||||
will then automatically be assumed to be the message.
|
||||
|
||||
=item tag
|
||||
|
||||
The tag to add to this message. If not provided, Log::Message will look
|
||||
in your configuration for one.
|
||||
|
||||
=item level
|
||||
|
||||
The level at which this message should be handled. If not provided,
|
||||
Log::Message will look in your configuration for one.
|
||||
|
||||
=item extra
|
||||
|
||||
This is an array ref with arguments passed to the handler for this
|
||||
message, when it is called from store();
|
||||
|
||||
The handler will receive them as a normal list
|
||||
|
||||
=back
|
||||
|
||||
store() will return true upon success and undef upon failure, as well
|
||||
as issue a warning as to why it failed.
|
||||
|
||||
=cut
|
||||
|
||||
### should extra be stored in the item object perhaps for later retrieval?
|
||||
sub store {
|
||||
my $self = shift;
|
||||
my %hash = ();
|
||||
|
||||
my $tmpl = {
|
||||
message => {
|
||||
default => '',
|
||||
strict_type => 1,
|
||||
required => 1,
|
||||
},
|
||||
tag => { default => $self->_get_conf('tag') },
|
||||
level => { default => $self->_get_conf('level'), },
|
||||
extra => { default => [], strict_type => 1 },
|
||||
};
|
||||
|
||||
### single arg means just the message
|
||||
### otherwise, they are named
|
||||
if( @_ == 1 ) {
|
||||
$hash{message} = shift;
|
||||
} else {
|
||||
%hash = @_;
|
||||
}
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or (
|
||||
warn( loc(q[Could not store error: %1], Params::Check->last_error) ),
|
||||
return
|
||||
);
|
||||
|
||||
my $extra = delete $args->{extra};
|
||||
my $item = Log::Message::Item->new( %$args,
|
||||
parent => $self,
|
||||
id => scalar @{$self->{STACK}}
|
||||
)
|
||||
or ( warn( loc(q[Could not create new log item!]) ), return undef );
|
||||
|
||||
push @{$self->{STACK}}, $item;
|
||||
|
||||
{ no strict 'refs';
|
||||
|
||||
my $sub = $args->{level};
|
||||
|
||||
$item->$sub( @$extra );
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 retrieve
|
||||
|
||||
This will retrieve all message items matching the criteria specified
|
||||
from the stack.
|
||||
|
||||
Here are the criteria you can discriminate on:
|
||||
|
||||
=over 4
|
||||
|
||||
=item tag
|
||||
|
||||
A regex to which the tag must adhere. For example C<qr/\w/>.
|
||||
|
||||
=item level
|
||||
|
||||
A regex to which the level must adhere.
|
||||
|
||||
=item message
|
||||
|
||||
A regex to which the message must adhere.
|
||||
|
||||
=item amount
|
||||
|
||||
Maximum amount of errors to return
|
||||
|
||||
=item chrono
|
||||
|
||||
Return in chronological order, or not?
|
||||
|
||||
=item remove
|
||||
|
||||
Remove items from the stack upon retrieval?
|
||||
|
||||
=back
|
||||
|
||||
In scalar context it will return the first item matching your criteria
|
||||
and in list context, it will return all of them.
|
||||
|
||||
If an error occurs while retrieving, a warning will be issued and
|
||||
undef will be returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub retrieve {
|
||||
my $self = shift;
|
||||
my %hash = ();
|
||||
|
||||
my $tmpl = {
|
||||
tag => { default => qr/.*/ },
|
||||
level => { default => qr/.*/ },
|
||||
message => { default => qr/.*/ },
|
||||
amount => { default => '' },
|
||||
remove => { default => $self->_get_conf('remove') },
|
||||
chrono => { default => $self->_get_conf('chrono') },
|
||||
};
|
||||
|
||||
### single arg means just the amount
|
||||
### otherwise, they are named
|
||||
if( @_ == 1 ) {
|
||||
$hash{amount} = shift;
|
||||
} else {
|
||||
%hash = @_;
|
||||
}
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or (
|
||||
warn( loc(q[Could not parse input: %1], Params::Check->last_error) ),
|
||||
return
|
||||
);
|
||||
|
||||
my @list =
|
||||
grep { $_->tag =~ /$args->{tag}/ ? 1 : 0 }
|
||||
grep { $_->level =~ /$args->{level}/ ? 1 : 0 }
|
||||
grep { $_->message =~ /$args->{message}/ ? 1 : 0 }
|
||||
grep { defined }
|
||||
$args->{chrono}
|
||||
? @{$self->{STACK}}
|
||||
: reverse @{$self->{STACK}};
|
||||
|
||||
my $amount = $args->{amount} || scalar @list;
|
||||
|
||||
my @rv = map {
|
||||
$args->{remove} ? $_->remove : $_
|
||||
} scalar @list > $amount
|
||||
? splice(@list,0,$amount)
|
||||
: @list;
|
||||
|
||||
return wantarray ? @rv : $rv[0];
|
||||
}
|
||||
|
||||
=head2 first
|
||||
|
||||
This is a shortcut for retrieving the first item(s) stored on the
|
||||
stack. It will default to only retrieving one if called with no
|
||||
arguments, and will always return results in chronological order.
|
||||
|
||||
If you only supply one argument, it is assumed to be the amount you
|
||||
wish returned.
|
||||
|
||||
Furthermore, it can take the same arguments as C<retrieve> can.
|
||||
|
||||
=cut
|
||||
|
||||
sub first {
|
||||
my $self = shift;
|
||||
|
||||
my $amt = @_ == 1 ? shift : 1;
|
||||
return $self->retrieve( amount => $amt, @_, chrono => 1 );
|
||||
}
|
||||
|
||||
=head2 last
|
||||
|
||||
This is a shortcut for retrieving the last item(s) stored on the
|
||||
stack. It will default to only retrieving one if called with no
|
||||
arguments, and will always return results in reverse chronological
|
||||
order.
|
||||
|
||||
If you only supply one argument, it is assumed to be the amount you
|
||||
wish returned.
|
||||
|
||||
Furthermore, it can take the same arguments as C<retrieve> can.
|
||||
|
||||
=cut
|
||||
|
||||
sub final {
|
||||
my $self = shift;
|
||||
|
||||
my $amt = @_ == 1 ? shift : 1;
|
||||
return $self->retrieve( amount => $amt, @_, chrono => 0 );
|
||||
}
|
||||
|
||||
=head2 flush
|
||||
|
||||
This removes all items from the stack and returns them to the caller
|
||||
|
||||
=cut
|
||||
|
||||
sub flush {
|
||||
my $self = shift;
|
||||
|
||||
return splice @{$self->{STACK}};
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Log::Message::Item>, L<Log::Message::Handlers>, L<Log::Message::Config>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module by
|
||||
Jos Boumans E<lt>kane@cpan.orgE<gt>.
|
||||
|
||||
=head1 Acknowledgements
|
||||
|
||||
Thanks to Ann Barcomb for her suggestions.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This module is
|
||||
copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
|
||||
All rights reserved.
|
||||
|
||||
This library is free software;
|
||||
you may redistribute and/or modify it under the same
|
||||
terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
# Local variables:
|
||||
# c-indentation-style: bsd
|
||||
# c-basic-offset: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
# vim: expandtab shiftwidth=4:
|
||||
Reference in New Issue
Block a user