Fix IPC-Cmd test failure on Win32: check current directory as well

[p5sagit/p5-mst-13.2.git] / lib / Log / Message.pm

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