Add Log::Message and Log::Message::Simple to the core
Jos Boumans [Fri, 13 Oct 2006 17:12:57 +0000 (19:12 +0200)]
From: "Jos Boumans" <kane@xs4all.net>
Message-ID: <13003.80.127.35.68.1160752377.squirrel@webmail.xs4all.nl>

p4raw-id: //depot/perl@29052

14 files changed:
MANIFEST
Porting/Maintainers.pl
lib/Log/Message.pm [new file with mode: 0644]
lib/Log/Message/Config.pm [new file with mode: 0644]
lib/Log/Message/Handlers.pm [new file with mode: 0644]
lib/Log/Message/Item.pm [new file with mode: 0644]
lib/Log/Message/Simple.pm [new file with mode: 0644]
lib/Log/Message/Simple/t/01_use.t [new file with mode: 0644]
lib/Log/Message/Simple/t/02_imports.t [new file with mode: 0644]
lib/Log/Message/Simple/t/03_functions.t [new file with mode: 0644]
lib/Log/Message/t/01_Log-Message-Config.t [new file with mode: 0644]
lib/Log/Message/t/02_Log-Message.t [new file with mode: 0644]
lib/Log/Message/t/conf/LoadMe.pl [new file with mode: 0644]
lib/Log/Message/t/conf/config_file [new file with mode: 0644]

index 736f44e..a9cf92a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -983,10 +983,10 @@ ext/re/re_comp.h          re extension wrapper for regcomp.h
 ext/re/re.pm                   re extension Perl module
 ext/re/re_top.h                        re extension symbol hiding header
 ext/re/re.xs                   re extension external subroutines
-ext/re/t/regop.pl              generate debug output for various patterns
-ext/re/t/regop.t               test RE optimizations by scraping debug output
 ext/re/t/lexical_debug.pl      generate debug output for lexical re 'debug'
 ext/re/t/lexical_debug.t       test that lexical re 'debug' works
+ext/re/t/regop.pl              generate debug output for various patterns
+ext/re/t/regop.t               test RE optimizations by scraping debug output
 ext/re/t/re.t                  see if re pragma works
 ext/Safe/t/safe1.t             See if Safe works
 ext/Safe/t/safe2.t             See if Safe works
@@ -1497,8 +1497,8 @@ lib/CPAN/HandleConfig.pm  helper package for CPAN.pm
 lib/CPAN/Nox.pm                        Runs CPAN while avoiding compiled extensions
 lib/CPAN/PAUSE2003.pub         CPAN public key
 lib/CPAN/PAUSE2005.pub         CPAN public key
-lib/CPAN/Queue.pm              queueing system for CPAN.pm
 lib/CPAN.pm                    Interface to Comprehensive Perl Archive Network
+lib/CPAN/Queue.pm              queueing system for CPAN.pm
 lib/CPAN/SIGNATURE             CPAN public key
 lib/CPAN/t/01loadme.t          See if CPAN the module works
 lib/CPAN/t/02nox.t             See if CPAN::Nox works
@@ -1629,8 +1629,8 @@ lib/ExtUtils/t/config.t           Test ExtUtils::MakeMaker::Config
 lib/ExtUtils/t/Constant.t      See if ExtUtils::Constant works
 lib/ExtUtils/t/dir_target.t    Verify if dir_target() is supported
 lib/ExtUtils/t/Embed.t         See if ExtUtils::Embed and embedding works
-lib/ExtUtils/t/eu_command.t    See if ExtUtils::Command works
 lib/ExtUtils/testlib.pm                Fixes up @INC to use just-built extension
+lib/ExtUtils/t/eu_command.t    See if ExtUtils::Command works
 lib/ExtUtils/t/FIRST_MAKEFILE.t                See if FIRST_MAKEFILE works
 lib/ExtUtils/t/hints.t         See if hint files are honored.
 lib/ExtUtils/t/INSTALL_BASE.t  Test INSTALL_BASE in MakeMaker
@@ -1655,8 +1655,8 @@ lib/ExtUtils/t/oneliner.t See if MM can generate perl one-liners
 lib/ExtUtils/t/Packlist.t      See if Packlist works
 lib/ExtUtils/t/parse_version.t See if parse_version works
 lib/ExtUtils/t/PL_FILES.t      Test PL_FILES in MakeMaker
-lib/ExtUtils/t/postamble.t     See if postamble works
 lib/ExtUtils/t/pm.t            See if Makemaker can handle PM
+lib/ExtUtils/t/postamble.t     See if postamble works
 lib/ExtUtils/t/prefixify.t     See if MakeMaker can apply a PREFIX
 lib/ExtUtils/t/prereq_print.t  See if PREREQ_PRINT works
 lib/ExtUtils/t/problems.t      How MakeMaker reacts to build problems
@@ -1834,6 +1834,18 @@ lib/locale.pm                    For "use locale"
 lib/Locale/Script.pm           Locale::Codes
 lib/Locale/Script.pod          Locale::Codes documentation
 lib/locale.t                   See if locale support works
+lib/Log/Message/Config.pm      Log::Message
+lib/Log/Message/Handlers.pm    Log::Message
+lib/Log/Message/Item.pm        Log::Message
+lib/Log/Message.pm     Log::Message
+lib/Log/Message/Simple.pm      Log::Simple
+lib/Log/Message/Simple/t/01_use.t      Log::Simple tests
+lib/Log/Message/Simple/t/02_imports.t  Log::Simple tests
+lib/Log/Message/Simple/t/03_functions.t        Log::Simple tests
+lib/Log/Message/t/01_Log-Message-Config.t      Log::Message tests
+lib/Log/Message/t/02_Log-Message.t     Log::Message tests
+lib/Log/Message/t/conf/config_file     Log::Message tests
+lib/Log/Message/t/conf/LoadMe.pl       Log::Message tests
 lib/look.pl                    A "look" equivalent
 lib/Math/BigFloat.pm           An arbitrary precision floating-point arithmetic package
 lib/Math/BigFloat/Trace.pm     bignum tracing
@@ -2308,9 +2320,9 @@ lib/Pod/t/htmlview.t              pod2html render test
 lib/Pod/t/InputObjects.t       See if Pod::InputObjects works
 lib/Pod/t/man.t                        podlators test
 lib/Pod/t/parselink.t          podlators test
-lib/Pod/t/pod-parser.t         podlators test
 lib/Pod/t/pod2html-lib.pl      pod2html testing library
 lib/Pod/t/pod2latex.t          See if Pod::LaTeX works
+lib/Pod/t/pod-parser.t         podlators test
 lib/Pod/t/Select.t             See if Pod::Select works
 lib/Pod/t/termcap.t            podlators test
 lib/Pod/t/text-options.t               podlators test
index d8fc0f4..d32fc62 100644 (file)
@@ -381,6 +381,20 @@ package Maintainers;
                'CPAN'          => 1,
                },
 
+       'Log::Message' =>
+               {
+               'MAINTAINER'    => 'kane',
+                'FILES'         => q[lib/Log/Message.pm lib/Log/Message/{Config,Handlers,Item}.pm lib/Log/Message/t],
+                'CPAN'          => 1,
+               },
+
+       'Log::Message::Simple' =>
+                {
+                'MAINTAINER'    => 'tels',
+                'FILES'         => q[lib/Log/Message/Simple.pm lib/Log/Message/Simple],
+                'CPAN'          => 1,
+                },
+
        'Math::BigFloat' =>
                {
                'MAINTAINER'    => 'tels',
diff --git a/lib/Log/Message.pm b/lib/Log/Message.pm
new file mode 100644 (file)
index 0000000..6b61265
--- /dev/null
@@ -0,0 +1,600 @@
+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
diff --git a/lib/Log/Message/Config.pm b/lib/Log/Message/Config.pm
new file mode 100644 (file)
index 0000000..eaeb78b
--- /dev/null
@@ -0,0 +1,197 @@
+package Log::Message::Config;\r
+use strict;\r
+\r
+use Params::Check qw[check];\r
+use Module::Load;\r
+use FileHandle;\r
+use Locale::Maketext::Simple Style => 'gettext';\r
+\r
+BEGIN {\r
+    use vars        qw[$VERSION $AUTOLOAD];\r
+    $VERSION    =   0.01;\r
+}\r
+\r
+sub new {\r
+    my $class = shift;\r
+    my %hash  = @_;\r
+\r
+    ### find out if the user specified a config file to use\r
+    ### and/or a default configuration object\r
+    ### and remove them from the argument hash\r
+    my %special =   map { lc, delete $hash{$_} }\r
+                    grep /^config|default$/i, keys %hash;\r
+\r
+    ### allow provided arguments to override the values from the config ###\r
+    my $tmpl = {\r
+        private => { default => undef,  },\r
+        verbose => { default => 1       },\r
+        tag     => { default => 'NONE', },\r
+        level   => { default => 'log',  },\r
+        remove  => { default => 0       },\r
+        chrono  => { default => 1       },\r
+    };\r
+\r
+    my %lc_hash = map { lc, $hash{$_} } keys %hash;\r
+\r
+    my $file_conf;\r
+    if( $special{config} ) {\r
+        $file_conf = _read_config_file( $special{config} )\r
+                        or ( warn( loc(q[Could not parse config file!]) ), return );\r
+    }\r
+\r
+    my $def_conf = \%{ $special{default} || {} };\r
+\r
+    ### make sure to only include keys that are actually defined --\r
+    ### the checker will assign even 'undef' if you have provided that\r
+    ### as a value\r
+    ### priorities goes as follows:\r
+    ### 1: arguments passed\r
+    ### 2: any config file passed\r
+    ### 3: any default config passed\r
+    my %to_check =  map     { @$_ }\r
+                    grep    { defined $_->[1] }\r
+                    map     {   [ $_ =>\r
+                                    defined $lc_hash{$_}        ? $lc_hash{$_}      :\r
+                                    defined $file_conf->{$_}    ? $file_conf->{$_}  :\r
+                                    defined $def_conf->{$_}     ? $def_conf->{$_}   :\r
+                                    undef\r
+                                ]\r
+                            } keys %$tmpl;\r
+\r
+    my $rv = check( $tmpl, \%to_check, 1 )\r
+                or ( warn( loc(q[Could not validate arguments!]) ), return );\r
+\r
+    return bless $rv, $class;\r
+}\r
+\r
+sub _read_config_file {\r
+    my $file = shift or return;\r
+\r
+    my $conf = {};\r
+    my $FH = new FileHandle;\r
+    $FH->open("$file") or (\r
+                        warn(loc(q[Could not open config file '%1': %2],$file,$!)),\r
+                        return {}\r
+                    );\r
+\r
+    while(<$FH>) {\r
+        next if     /\s*#/;\r
+        next unless /\S/;\r
+\r
+        chomp; s/^\s*//; s/\s*$//;\r
+\r
+        my ($param,$val) = split /\s*=\s*/;\r
+\r
+        if( (lc $param) eq 'include' ) {\r
+            load $val;\r
+            next;\r
+        }\r
+\r
+        ### add these to the config hash ###\r
+        $conf->{ lc $param } = $val;\r
+    }\r
+    close $FH;\r
+\r
+    return $conf;\r
+}\r
+\r
+sub AUTOLOAD {\r
+    $AUTOLOAD =~ s/.+:://;\r
+\r
+    my $self = shift;\r
+\r
+    return $self->{ lc $AUTOLOAD } if exists $self->{ lc $AUTOLOAD };\r
+\r
+    die loc(q[No such accessor '%1' for class '%2'], $AUTOLOAD, ref $self);\r
+}\r
+\r
+sub DESTROY { 1 }\r
+\r
+1;\r
+\r
+__END__\r
+\r
+=pod\r
+\r
+=head1 NAME\r
+\r
+Log::Message::Config - Configuration options for Log::Message\r
+\r
+=head1 SYNOPSIS\r
+\r
+    # This module is implicitly used by Log::Message to create a config\r
+    # which it uses to log messages.\r
+    # For the options you can pass, see the C<Log::Message new()> method.\r
+\r
+    # Below is a sample of a config file you could use\r
+\r
+    # comments are denoted by a single '#'\r
+    # use a shared stack, or have a private instance?\r
+    # if none provided, set to '0',\r
+    private = 1\r
+\r
+    # do not be verbose\r
+    verbose = 0\r
+\r
+    # default tag to set on new items\r
+    # if none provided, set to 'NONE'\r
+    tag = SOME TAG\r
+\r
+    # default level to handle items\r
+    # if none provided, set to 'log'\r
+    level = carp\r
+\r
+    # extra files to include\r
+    # if none provided, no files are auto included\r
+    include = mylib.pl\r
+    include = ../my/other/lib.pl\r
+\r
+    # automatically delete items\r
+    # when you retrieve them from the stack?\r
+    # if none provided, set to '0'\r
+    remove = 1\r
+\r
+    # retrieve errors in chronological order, or not?\r
+    # if none provided, set to '1'\r
+    chrono = 0\r
+\r
+=head1 DESCRIPTION\r
+\r
+Log::Message::Config provides a standardized config object for\r
+Log::Message objects.\r
+\r
+It can either read options as perl arguments, or as a config file.\r
+See the Log::Message manpage for more information about what arguments\r
+are valid, and see the Synopsis for an example config file you can use\r
+\r
+=head1 SEE ALSO\r
+\r
+L<Log::Message>, L<Log::Message::Item>, L<Log::Message::Handlers>\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
+# 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
diff --git a/lib/Log/Message/Handlers.pm b/lib/Log/Message/Handlers.pm
new file mode 100644 (file)
index 0000000..d02fb52
--- /dev/null
@@ -0,0 +1,191 @@
+package Log::Message::Handlers;\r
+use strict;\r
+\r
+=pod\r
+\r
+=head1 NAME\r
+\r
+Log::Message::Handlers - Message handlers for Log::Message\r
+\r
+=head1 SYNOPSIS\r
+\r
+    # Implicitly used by Log::Message to serve as handlers for\r
+    # Log::Message::Item objects\r
+\r
+    # Create your own file with a package called\r
+    # Log::Message::Handlers to add to the existing ones, or to even\r
+    # overwrite them\r
+\r
+    $item->carp;\r
+\r
+    $item->trace;\r
+\r
+\r
+=head1 DESCRIPTION\r
+\r
+Log::Message::Handlers provides handlers for Log::Message::Item objects.\r
+The handler corresponding to the level (see Log::Message::Item manpage\r
+for an explanation about levels) will be called automatically upon\r
+storing the error.\r
+\r
+Handlers may also explicitly be called on an Log::Message::Item object\r
+if one so desires (see the Log::Message manpage on how to retrieve the\r
+Item objects).\r
+\r
+=head1 Default Handlers\r
+\r
+=head2 log\r
+\r
+Will simply log the error on the stack, and do nothing special\r
+\r
+=cut\r
+\r
+sub log { 1 }\r
+\r
+=head2 carp\r
+\r
+Will carp (see the Carp manpage) with the error, and add the timestamp\r
+of when it occurred.\r
+\r
+=cut\r
+\r
+sub carp {\r
+    my $self = shift;\r
+    warn join " ", $self->message, $self->shortmess, 'at', $self->when, "\n";\r
+}\r
+\r
+=head2 croak\r
+\r
+Will croak (see the Carp manpage) with the error, and add the\r
+timestamp of when it occurred.\r
+\r
+=cut\r
+\r
+sub croak {\r
+    my $self = shift;\r
+    die join " ", $self->message, $self->shortmess, 'at', $self->when, "\n";\r
+}\r
+\r
+=head2 cluck\r
+\r
+Will cluck (see the Carp manpage) with the error, and add the\r
+timestamp of when it occurred.\r
+\r
+=cut\r
+\r
+sub cluck {\r
+    my $self = shift;\r
+    warn join " ", $self->message, $self->longmess, 'at', $self->when, "\n";\r
+}\r
+\r
+=head2 confess\r
+\r
+Will confess (see the Carp manpage) with the error, and add the\r
+timestamp of when it occurred\r
+\r
+=cut\r
+\r
+sub confess {\r
+    my $self = shift;\r
+    die join " ", $self->message, $self->longmess, 'at', $self->when, "\n";\r
+}\r
+\r
+=head2 die\r
+\r
+Will simply die with the error message of the item\r
+\r
+=cut\r
+\r
+sub die  { die  shift->message; }\r
+\r
+\r
+=head2 warn\r
+\r
+Will simply warn with the error message of the item\r
+\r
+=cut\r
+\r
+sub warn { warn shift->message; }\r
+\r
+\r
+=head2 trace\r
+\r
+Will provide a traceback of this error item back to the first one that\r
+occurrent, clucking with every item as it comes across it.\r
+\r
+=cut\r
+\r
+sub trace {\r
+    my $self = shift;\r
+\r
+    for my $item( $self->parent->retrieve( chrono => 0 ) ) {\r
+        $item->cluck;\r
+    }\r
+}\r
+\r
+=head1 Custom Handlers\r
+\r
+If you wish to provide your own handlers, you can simply do the\r
+following:\r
+\r
+=over 4\r
+\r
+=item *\r
+\r
+Create a file that holds a package by the name of\r
+C<Log::Message::Handlers>\r
+\r
+=item *\r
+\r
+Create subroutines with the same name as the levels you wish to\r
+handle in the Log::Message module (see the Log::Message manpage for\r
+explanation on levels)\r
+\r
+=item *\r
+\r
+Require that file in your program, or add it in your configuration\r
+(see the Log::Message::Config manpage for explanation on how to use a\r
+config file)\r
+\r
+=back\r
+\r
+And that is it, the handler will now be available to handle messages\r
+for you.\r
+\r
+The arguments a handler may receive are those specified by the\r
+C<extra> key, when storing the message.\r
+See the Log::Message manpage for details on the arguments.\r
+\r
+=head1 SEE ALSO\r
+\r
+L<Log::Message>, L<Log::Message::Item>, 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
diff --git a/lib/Log/Message/Item.pm b/lib/Log/Message/Item.pm
new file mode 100644 (file)
index 0000000..2ecf82d
--- /dev/null
@@ -0,0 +1,192 @@
+package Log::Message::Item;\r
+\r
+use strict;\r
+use Params::Check qw[check];\r
+use Log::Message::Handlers;\r
+\r
+### for the messages to store ###\r
+use Carp ();\r
+\r
+BEGIN {\r
+    use vars qw[$AUTOLOAD $VERSION];\r
+\r
+    $VERSION    =   $Log::Message::VERSION;\r
+}\r
+\r
+### create a new item.\r
+### note that only an id (position on the stack), message and a reference\r
+### to its parent are required. all the other things it can fill in itself\r
+sub new {\r
+    my $class   = shift;\r
+    my %hash    = @_;\r
+\r
+    my $tmpl = {\r
+        when        => { no_override    => 1,   default    => scalar localtime },\r
+        id          => { required       => 1    },\r
+        message     => { required       => 1    },\r
+        parent      => { required        => 1    },\r
+        level       => { default        => ''   },      # default may be conf dependant\r
+        tag         => { default        => ''   },      # default may be conf dependant\r
+        longmess    => { default        => _clean(Carp::longmess()) },\r
+        shortmess   => { default        => _clean(Carp::shortmess())},\r
+    };\r
+\r
+    my $args = check($tmpl, \%hash) or return undef;\r
+\r
+    return bless $args, $class;\r
+}\r
+\r
+sub _clean { map { s/\s*//; chomp; $_ } shift; }\r
+\r
+sub remove {\r
+    my $item = shift;\r
+    my $self = $item->parent;\r
+\r
+    return splice( @{$self->{STACK}}, $item->id, 1, undef );\r
+}\r
+\r
+sub AUTOLOAD {\r
+    my $self = $_[0];\r
+\r
+    $AUTOLOAD =~ s/.+:://;\r
+\r
+    return $self->{$AUTOLOAD} if exists $self->{$AUTOLOAD};\r
+\r
+    local $Carp::CarpLevel = $Carp::CarpLevel + 3;\r
+\r
+    {   no strict 'refs';\r
+        return *{"Log::Message::Handlers::${AUTOLOAD}"}->(@_);\r
+    }\r
+}\r
+\r
+sub DESTROY { 1 }\r
+\r
+1;\r
+\r
+__END__\r
+\r
+=pod\r
+\r
+=head1 NAME\r
+\r
+Log::Message::Item  - Message objects for Log::Message\r
+\r
+=head1 SYNOPSIS\r
+\r
+    # Implicitly used by Log::Message to create Log::Message::Item objects\r
+\r
+    print "this is the message's id: ",     $item->id;\r
+\r
+    print "this is the message stored: ",   $item->message;\r
+\r
+    print "this is when it happened: ",     $item->when;\r
+\r
+    print "the message was tagged: ",       $item->tag;\r
+\r
+    print "this was the severity level: ",  $item->level;\r
+\r
+    $item->remove;  # delete the item from the stack it was on\r
+\r
+    # Besides these methods, you can also call the handlers on\r
+    # the object specificallly.\r
+    # See the Log::Message::Handlers manpage for documentation on what\r
+    # handlers are available by default and how to add your own\r
+\r
+\r
+=head1 DESCRIPTION\r
+\r
+Log::Message::Item is a class that generates generic Log items.\r
+These items are stored on a Log::Message stack, so see the Log::Message\r
+manpage about details how to retrieve them.\r
+\r
+You should probably not create new items by yourself, but use the\r
+storing mechanism provided by Log::Message.\r
+\r
+However, the accessors and handlers are of interest if you want to do\r
+fine tuning of how your messages are handled.\r
+\r
+The accessors and methods are described below, the handlers are\r
+documented in the Log::Message::Handlers manpage.\r
+\r
+=head1 Methods and Accessors\r
+\r
+=head2 remove\r
+\r
+Calling remove will remove the object from the stack it was on, so it\r
+will not show up any more in subsequent fetches of messages.\r
+\r
+You can still call accessors and handlers on it however, to handle it\r
+as you will.\r
+\r
+=head2 id\r
+\r
+Returns the internal ID of the item. This may be useful for comparing\r
+since the ID is incremented each time a new item is created.\r
+Therefore, an item with ID 4 must have been logged before an item with\r
+ID 9.\r
+\r
+=head2 when\r
+\r
+Returns the timestamp of when the message was logged\r
+\r
+=head2 message\r
+\r
+The actual message that was stored\r
+\r
+=head2 level\r
+\r
+The severity type of this message, as well as the name of the handler\r
+that was called upon storing it.\r
+\r
+=head2 tag\r
+\r
+Returns the identification tag that was put on the message.\r
+\r
+=head2 shortmess\r
+\r
+Returns the equivalent of a C<Carp::shortmess> for this item.\r
+See the C<Carp> manpage for details.\r
+\r
+=head2 longmess\r
+\r
+Returns the equivalent of a C<Carp::longmess> for this item, which\r
+is essentially a stack trace.\r
+See the C<Carp> manpage for details.\r
+\r
+=head2 parent\r
+\r
+Returns a reference to the Log::Message object that stored this item.\r
+This is useful if you want to have access to the full stack in a\r
+handler.\r
+\r
+=head1 SEE ALSO\r
+\r
+L<Log::Message>, 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
+# 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
diff --git a/lib/Log/Message/Simple.pm b/lib/Log/Message/Simple.pm
new file mode 100644 (file)
index 0000000..46188d0
--- /dev/null
@@ -0,0 +1,293 @@
+package Log::Message::Simple;
+
+use strict;
+use Log::Message private => 0;;
+
+BEGIN { 
+    use vars qw[$VERSION]; 
+    $VERSION = 0.01; 
+}
+        
+
+=pod
+
+=head1 NAME
+
+Log::Message::Simple
+
+=head1 SYNOPSIS
+
+    use Log::Message::Simple qw[msg error debug
+                                carp croak cluck confess];
+
+    use Log::Message::Simple qw[:STD :CARP];
+
+    ### standard reporting functionality
+    msg(    "Connecting to database",           $verbose );
+    error(  "Database connection failed: $@",   $verbose );
+    debug(  "Connection arguments were: $args", $debug );
+
+    ### standard carp functionality
+    carp(   "Wrong arguments passed: @_" );
+    croak(  "Fatal: wrong arguments passed: @_" );
+    cluck(  "Wrong arguments passed -- including stacktrace: @_" );
+    confess("Fatal: wrong arguments passed -- including stacktrace: @_" );
+
+    ### retrieve individual message
+    my @stack = Log::Message::Simple->stack;
+    my @stack = Log::Message::Simple->flush;
+
+    ### retrieve the entire stack in printable form
+    my $msgs  = Log::Message::Simple->stack_as_string;
+    my $trace = Log::Message::Simple->stack_as_string(1);
+
+    ### redirect output
+    local $Log::Message::Simple::MSG_FH     = \*STDERR;
+    local $Log::Message::Simple::ERROR_FH   = \*STDERR;
+    local $Log::Message::Simple::DEBUG_FH   = \*STDERR;
+    
+    ### force a stacktrace on error
+    local $Log::Message::Simple::STACKTRACE_ON_ERROR = 1
+
+=head1 DESCRIPTION
+
+This module provides standardized logging facilities using the
+C<Log::Message> module.
+
+=head1 FUNCTIONS
+
+=head2 msg("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT> (or actually
+C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+Exported by default, or using the C<:STD> tag.
+
+=head2 debug("message string" [,VERBOSE])
+
+Records a debug message on the stack, and prints it to C<STDOUT> (or
+actually C<$DEBUG_FH>, see the C<GLOBAL VARIABLES> section below), 
+if the C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+Exported by default, or using the C<:STD> tag.
+
+=head2 error("error string" [,VERBOSE])
+
+Records an error on the stack, and prints it to C<STDERR> (or actually
+C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> options defaults to true.
+
+Exported by default, or using the C<:STD> tag.
+
+=cut 
+
+{   package Log::Message::Handlers;
+    
+    sub msg {
+        my $self    = shift;
+        my $verbose = shift || 0;
+
+        ### so you don't want us to print the msg? ###
+        return if defined $verbose && $verbose == 0;
+
+        my $old_fh = select $Log::Message::Simple::MSG_FH;
+        print '['. $self->tag (). '] ' . $self->message . "\n";
+        select $old_fh;
+
+        return;
+    }
+
+    sub debug {
+        my $self    = shift;
+        my $verbose = shift || 0;
+
+        ### so you don't want us to print the msg? ###
+        return if defined $verbose && $verbose == 0;
+
+        my $old_fh = select $Log::Message::Simple::DEBUG_FH;
+        print '['. $self->tag (). '] ' . $self->message . "\n";
+        select $old_fh;
+
+        return;
+    }
+
+    sub error {
+        my $self    = shift;
+        my $verbose = shift;
+           $verbose = 1 unless defined $verbose;    # default to true
+
+        ### so you don't want us to print the error? ###
+        return if defined $verbose && $verbose == 0;
+
+        my $old_fh = select $Log::Message::Simple::ERROR_FH;
+
+        my $msg     = '['. $self->tag . '] ' . $self->message;
+
+        print $Log::Message::Simple::STACKTRACE_ON_ERROR 
+                    ? Carp::shortmess($msg) 
+                    : $msg . "\n";
+
+        select $old_fh;
+
+        return;
+    }
+}
+
+=head2 carp();
+
+Provides functionality equal to C<Carp::carp()>, whilst still logging
+to the stack.
+
+Exported by by using the C<:CARP> tag.
+
+=head2 croak();
+
+Provides functionality equal to C<Carp::croak()>, whilst still logging
+to the stack.
+
+Exported by by using the C<:CARP> tag.
+
+=head2 confess();
+
+Provides functionality equal to C<Carp::confess()>, whilst still logging
+to the stack.
+
+Exported by by using the C<:CARP> tag.
+
+=head2 cluck();
+
+Provides functionality equal to C<Carp::cluck()>, whilst still logging
+to the stack.
+
+Exported by by using the C<:CARP> tag.
+
+=head1 CLASS METHODS
+
+=head2 Log::Message::Simple->stack()
+
+Retrieves all the items on the stack. Since C<Log::Message::Simple> is
+implemented using C<Log::Message>, consult its manpage for the
+function C<retrieve> to see what is returned and how to use the items.
+
+=head2 Log::Message::Simple->stack_as_string([TRACE])
+
+Returns the whole stack as a printable string. If the C<TRACE> option is
+true all items are returned with C<Carp::longmess> output, rather than
+just the message.
+C<TRACE> defaults to false.
+
+=head2 Log::Message::Simple->flush()
+
+Removes all the items from the stack and returns them. Since
+C<Log::Message::Simple> is  implemented using C<Log::Message>, consult its
+manpage for the function C<retrieve> to see what is returned and how
+to use the items.
+
+=cut
+
+BEGIN {
+    use Exporter;
+    use Params::Check   qw[ check ];
+    use vars            qw[ @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA ];;
+
+    @ISA            = 'Exporter';
+    @EXPORT         = qw[error msg debug];
+    @EXPORT_OK      = qw[carp cluck croak confess];
+    
+    %EXPORT_TAGS    = (
+        STD     => \@EXPORT,
+        CARP    => \@EXPORT_OK,
+        ALL     => [ @EXPORT, @EXPORT_OK ],
+    );        
+
+    my $log         = new Log::Message;
+
+    for my $func ( @EXPORT, @EXPORT_OK ) {
+        no strict 'refs';
+        
+                        ### up the carplevel for the carp emulation
+                        ### functions
+        *$func = sub {  local $Carp::CarpLevel += 2
+                            if grep { $_ eq $func } @EXPORT_OK;
+                            
+                        my $msg     = shift;
+                        $log->store(
+                                message => $msg,
+                                tag     => uc $func,
+                                level   => $func,
+                                extra   => [@_]
+                        );
+                };
+    }
+
+    sub flush {
+        return reverse $log->flush;
+    }
+
+    sub stack {
+        return $log->retrieve( chrono => 1 );
+    }
+
+    sub stack_as_string {
+        my $class = shift;
+        my $trace = shift() ? 1 : 0;
+
+        return join $/, map {
+                        '[' . $_->tag . '] [' . $_->when . '] ' .
+                        ($trace ? $_->message . ' ' . $_->longmess
+                                : $_->message);
+                    } __PACKAGE__->stack;
+    }
+}
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $ERROR_FH
+
+This is the filehandle all the messages sent to C<error()> are being
+printed. This defaults to C<*STDERR>.
+
+=item $MSG_FH
+
+This is the filehandle all the messages sent to C<msg()> are being
+printed. This default to C<*STDOUT>.
+
+=item $DEBUG_FH
+
+This is the filehandle all the messages sent to C<debug()> are being
+printed. This default to C<*STDOUT>.
+
+=item $STACKTRACE_ON_ERROR
+
+If this option is set to C<true>, every call to C<error()> will 
+generate a stacktrace using C<Carp::shortmess()>.
+Defaults to C<false>
+
+=cut
+
+BEGIN {
+    use vars qw[ $ERROR_FH $MSG_FH $DEBUG_FH $STACKTRACE_ON_ERROR ];
+
+    local $| = 1;
+    $ERROR_FH               = \*STDERR;
+    $MSG_FH                 = \*STDOUT;
+    $DEBUG_FH               = \*STDOUT;
+    
+    $STACKTRACE_ON_ERROR    = 0;
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/Log/Message/Simple/t/01_use.t b/lib/Log/Message/Simple/t/01_use.t
new file mode 100644 (file)
index 0000000..147347c
--- /dev/null
@@ -0,0 +1,8 @@
+use Test::More 'no_plan';
+use strict;
+
+my $Class = 'Log::Message::Simple';
+
+use_ok( $Class );
+
+diag( "Testing $Class version " . $Class->VERSION ) unless $ENV{PERL_CORE};
diff --git a/lib/Log/Message/Simple/t/02_imports.t b/lib/Log/Message/Simple/t/02_imports.t
new file mode 100644 (file)
index 0000000..4910b97
--- /dev/null
@@ -0,0 +1,68 @@
+use Test::More 'no_plan';
+use strict;
+
+my $Class   = 'Log::Message::Simple';
+my @Carp    = qw[carp croak cluck confess];
+my @Msg     = qw[msg debug error];
+
+
+
+### test empty import
+{   package Test::A;
+    
+
+    eval "use $Class ()";
+    Test::More::ok( !$@,        "using $Class with no import" );
+    
+    for my $func ( @Carp, @Msg ) {
+        Test::More::ok( !__PACKAGE__->can( $func ),
+                                "   $func not imported" );
+    }
+}    
+
+### test :STD import
+{   package Test::B;
+
+    eval "use $Class ':STD'";
+    Test::More::ok( !$@,        "using $Class with :STD  import" );
+    
+    for my $func ( @Carp ) {
+        Test::More::ok( !__PACKAGE__->can( $func ),
+                                "   $func not imported" );
+    }
+    
+    for my $func ( @Msg ) {
+        Test::More::ok( __PACKAGE__->can( $func ),
+                                "   $func imported" );
+    }                                
+}    
+
+### test :CARP import
+{   package Test::C;
+
+    eval "use $Class ':CARP'";
+    Test::More::ok( !$@,        "using $Class with :CARP  import" );
+    
+    for my $func ( @Msg ) {
+        Test::More::ok( !__PACKAGE__->can( $func ),
+                                "   $func not imported" );
+    }
+    
+    for my $func ( @Carp ) {
+        Test::More::ok( __PACKAGE__->can( $func ),
+                                "   $func imported" );
+    }                                
+}    
+
+### test all import
+
+{   package Test::D;
+
+    eval "use $Class ':ALL'";
+    Test::More::ok( !$@,        "using $Class with :ALL  import" );
+    
+    for my $func ( @Carp, @Msg ) {
+        Test::More::ok( __PACKAGE__->can( $func ),
+                                "   $func imported" );
+    }                                
+}    
diff --git a/lib/Log/Message/Simple/t/03_functions.t b/lib/Log/Message/Simple/t/03_functions.t
new file mode 100644 (file)
index 0000000..7d8a0d8
--- /dev/null
@@ -0,0 +1,76 @@
+use Test::More 'no_plan';
+use strict;
+
+my $Class   = 'Log::Message::Simple';
+my @Carp    = qw[carp croak cluck confess];
+my @Msg     = qw[msg debug error];
+my $Text    = 'text';
+my $Pkg     = 'Test::A';
+
+use_ok( $Class );
+
+{   package Test::A;
+
+    ### set up local equivalents to exported functions
+    ### so we can print to closed FH without having to worry
+    ### about warnings
+    ### close stderr/warnings for that same purpose, as carp
+    ### & friends will print there
+    for my $name (@Carp, @Msg) {
+        no strict 'refs';
+        *$name = sub {  
+                    local $^W;
+
+                    ### do the block twice to avoid 'used only once'
+                    ### warnings
+                    local $Log::Message::Simple::ERROR_FH;
+                    local $Log::Message::Simple::DEBUG_FH;
+                    local $Log::Message::Simple::MSG_FH;
+
+                    local $Log::Message::Simple::ERROR_FH;
+                    local $Log::Message::Simple::DEBUG_FH;
+                    local $Log::Message::Simple::MSG_FH;
+
+
+
+
+                    local *STDERR;
+                    local $SIG{__WARN__} = sub { };
+                    
+                    my $ref = $Class->can( $name );
+
+
+                    $ref->( @_ );
+                };
+    }      
+}
+
+for my $name (@Carp, @Msg) {
+    
+    my $ref = $Pkg->can( $name );
+    ok( $ref,                   "Found function for '$name'" );
+
+    ### start with an empty stack?
+    cmp_ok( scalar @{[$Class->stack]}, '==', 0,
+                                "   Starting with empty stack" );
+    ok(!$Class->stack_as_string,"   Stringified stack empty" );                                
+    
+    ### call the func... no output should appear
+    ### eval this -- the croak/confess functions die
+    eval { $ref->( $Text ); };
+    
+    my @stack = $Class->stack;
+    cmp_ok( scalar(@stack), '==', 1,
+                                "   Text logged to stack" );
+                                
+    for my $re ( $Text, quotemeta '['.uc($name).']' ) {                               
+        like( $Class->stack_as_string, qr/$re/,
+                                "   Text as expected" );
+    }
+
+    ### empty stack again ###    
+    ok( $Class->flush,          "   Stack flushed" );
+    cmp_ok( scalar @{[$Class->stack]}, '==', 0,
+                                "   Starting with empty stack" );
+    ok(!$Class->stack_as_string,"   Stringified stack empty" );                                
+}
diff --git a/lib/Log/Message/t/01_Log-Message-Config.t b/lib/Log/Message/t/01_Log-Message-Config.t
new file mode 100644 (file)
index 0000000..2f8a021
--- /dev/null
@@ -0,0 +1,84 @@
+### Log::Message::Config test suite ###
+BEGIN { 
+    if( $ENV{PERL_CORE} ) {
+        chdir '../lib/Log/Message' if -d '../lib/Log/Message';
+        unshift @INC, '../../..';
+    }
+} 
+
+BEGIN { chdir 't' if -d 't' }
+
+use strict;
+use lib qw[../lib conf];
+use Test::More tests => 6;
+use File::Spec;
+use File::Basename qw[dirname];
+
+use_ok( 'Log::Message::Config'    ) or diag "Config.pm not found.  Dying", die;
+use_ok( 'Log::Message'            ) or diag "Module.pm not found.  Dying", die;
+
+{
+    my $default = {
+        private => undef,
+        verbose => 1,
+        tag     => 'NONE',
+        level   => 'log',
+        remove  => 0,
+        chrono  => 1,
+    };
+
+    my $log = Log::Message->new();
+
+    is_deeply( $default, $log->{CONFIG}, q[Config creation from default] );
+}
+
+{
+    my $config = {
+        private => 1,
+        verbose => 1,
+        tag     => 'TAG',
+        level   => 'carp',
+        remove  => 0,
+        chrono  => 1,
+    };
+
+    my $log = Log::Message->new( %$config );
+
+    is_deeply( $config, $log->{CONFIG}, q[Config creation from options] );
+}
+
+{
+    my $file = {
+        private => 1,
+        verbose => 0,
+        tag     => 'SOME TAG',
+        level   => 'carp',
+        remove  => 1,
+        chrono  => 0,
+    };
+
+    my $log = Log::Message->new(
+                    config  => File::Spec->catfile( qw|conf config_file| )
+                );
+
+    is_deeply( $file, $log->{CONFIG}, q[Config creation from file] );
+}
+
+{
+
+    my $mixed = {
+        private => 1,
+        verbose => 0,
+        remove  => 1,
+        chrono  => 0,
+        tag     => 'MIXED',
+        level   => 'die',
+    };
+    my $log = Log::Message->new(
+                    config  => File::Spec->catfile( qw|conf config_file| ),
+                    tag     => 'MIXED',
+                    level   => 'die',
+                );
+    is_deeply( $mixed, $log->{CONFIG}, q[Config creation from file & options] );
+}
+           
diff --git a/lib/Log/Message/t/02_Log-Message.t b/lib/Log/Message/t/02_Log-Message.t
new file mode 100644 (file)
index 0000000..b49c962
--- /dev/null
@@ -0,0 +1,175 @@
+### Log::Message test suite ###
+BEGIN { 
+    if( $ENV{PERL_CORE} ) {
+        chdir '../lib/Log/Message' if -d '../lib/Log/Message';
+        unshift @INC, '../../..';
+    }
+} 
+
+BEGIN { chdir 't' if -d 't' }
+
+
+use strict;
+use lib qw[../lib to_load];
+use Test::More tests => 34;
+
+### use tests
+for my $pkg ( qw[ Log::Message          Log::Message::Config
+                  Log::Message::Item    Log::Message::Handlers]
+) {
+    use_ok( $pkg ) or diag "'$pkg' not found. Dying";
+}    
+
+### test global stack
+{
+    my $log = Log::Message->new( private => 0 );
+    is( $log->{STACK}, $Log::Message::STACK, q[Using global stack] );
+}
+
+### test using private stack
+{
+    my $log = Log::Message->new( private => 1 );
+    isnt( $log->{STACK}, $Log::Message::STACK, q[Using private stack] );
+
+    $log->store('foo'); $log->store('bar');
+
+    ### retrieval tests
+    {
+        my @list = $log->retrieve();
+
+        ok( @list == 2, q[Stored 2 messages] );
+    }
+
+    $log->store('zot'); $log->store('quux');
+
+    {
+        my @list = $log->retrieve( amount => 3 );
+
+        ok( @list == 3, q[Retrieving 3 messages] );
+    }
+
+    {
+        is( $log->first->message, 'foo',    q[  Retrieving first message] );
+        is( $log->final->message, 'quux',   q[  Retrieving final message] );
+    }
+
+    {
+        package Log::Message::Handlers;
+
+        sub test    { return shift }
+        sub test2   { shift; return @_ }
+
+        package main;
+    }
+
+    $log->store(
+            message     => 'baz',
+            tag         => 'MY TAG',
+            level       => 'test',
+    );
+
+    {
+        ok( $log->retrieve( message => qr/baz/ ),   
+                                        q[  Retrieving based on message] );
+        ok( $log->retrieve( tag     => qr/TAG/ ),   
+                                        q[  Retrieving based on tag] );
+        ok( $log->retrieve( level   => qr/test/ ),  
+                                        q[  Retrieving based on level] );
+    }
+
+    my $item = $log->retrieve( chrono => 0 );
+
+    {
+        ok( $item,                      q[Retrieving item] );
+        is( $item->parent,  $log,       q[  Item reference to parent] );
+        is( $item->message, 'baz',      q[  Item message stored] );
+        is( $item->id,      4,          q[  Item id stored] );
+        is( $item->tag,     'MY TAG',   q[  Item tag stored] );
+        is( $item->level,   'test',     q[  Item level stored] );
+    }
+
+    {
+        ### shortmess is very different from 5.6.1 => 5.8, so let's
+        ### just check that it is filled.
+        ok(     $item->shortmess,       q[Item shortmess stored] );
+        like(   $item->shortmess, qr/\w+/,
+                q[  Item shortmess stored properly]
+        );
+        
+        ok(     $item->longmess,        q[Item longmess stored] );
+        like(   $item->longmess, qr/Log::Message::store/s,
+                q[  Item longmess stored properly]
+        );
+
+        my $t = scalar localtime;
+        $t =~ /(\w+ \w+ \d+)/;
+
+        like(   $item->when, qr/$1/, q[Item timestamp stored] );
+    }
+
+    {
+        my $i = $item->test;
+        my @a = $item->test2(1,2,3);
+
+        is( $item, $i,              q[Item handler check] );
+        is_deeply( $item, $i,       q[  Item handler deep check] );
+        is_deeply( \@a, [1,2,3],    q[  Item extra argument check] );
+    }
+
+    {
+        ok( $item->remove,          q[Removing item from stack] );
+        ok( (!grep{ $item eq $_ } $log->retrieve), 
+                                    q[  Item removed from stack] );
+    }
+
+    {
+        $log->flush;
+        ok( @{$log->{STACK}} == 0,  q[Flushing stack] );
+    }
+}
+    
+### test errors 
+{   my $log = Log::Message->new( private => 1 );
+
+    
+    ### store errors
+    {   ### dont make it print
+        my $warnings;
+        local $SIG{__WARN__} = sub { $warnings .= "@_" };
+    
+        my $rv  = $log->store();
+        ok( !$rv,                       q[Logging empty message failed] );
+        like( $warnings, qr/message/,   q[  Spotted the error] );
+    }
+    
+    ### retrieve errors
+    {   ### dont make it print
+        my $warnings;
+        local $SIG{__WARN__} = sub { $warnings .= "@_" };
+    
+        ### XXX whitebox test!
+        local $Params::Check::VERBOSE = 1; # so the warnings are emitted
+    
+        my $rv  = $log->retrieve( frobnitz => $$ );
+        ok( !$rv,                       q[Retrieval with bogus args] );
+        like( $warnings, qr/not a valid key/,   
+                                        qq[  Spotted the error] );
+    }
+}    
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/lib/Log/Message/t/conf/LoadMe.pl b/lib/Log/Message/t/conf/LoadMe.pl
new file mode 100644 (file)
index 0000000..6912615
--- /dev/null
@@ -0,0 +1 @@
+1;
\ No newline at end of file
diff --git a/lib/Log/Message/t/conf/config_file b/lib/Log/Message/t/conf/config_file
new file mode 100644 (file)
index 0000000..645cbb1
--- /dev/null
@@ -0,0 +1,30 @@
+    # Below is a sample of a config file you could use\r
+\r
+    # comments are denoted by a single '#'\r
+    # use a shared stack, or have a private instance?\r
+    # if none provided, set to '0',\r
+    private = 1\r
+\r
+    # do not be verbose\r
+    verbose = 0\r
+\r
+    # default tag to set on new items\r
+    # if none provided, set to 'NONE'\r
+    tag = SOME TAG\r
+\r
+    # default level to handle items\r
+    # if none provided, set to 'log'\r
+    level = carp\r
+\r
+    # extra files to include\r
+    # if none provided, no files are auto included\r
+    include = LoadMe.pl\r
+\r
+    # automatically delete items\r
+    # when you retrieve them from the stack?\r
+    # if none provided, set to '0'\r
+    remove = 1\r
+\r
+    # retrieve errors in chronological order, or not?\r
+    # if none provided, set to '1'\r
+    chrono = 0
\ No newline at end of file