diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Log/Message.pm')
| -rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Log/Message.pm | 600 |
1 files changed, 600 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Log/Message.pm b/Master/tlpkg/tlperl.straw/lib/Log/Message.pm new file mode 100755 index 00000000000..3b2f43e57da --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Log/Message.pm @@ -0,0 +1,600 @@ +package Log::Message; + +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.02; + + $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: |