summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/Log/Message.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Log/Message.pm')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Log/Message.pm600
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: