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
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
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
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
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
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
'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',
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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:
--- /dev/null
+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};
--- /dev/null
+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" );
+ }
+}
--- /dev/null
+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" );
+}
--- /dev/null
+### 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] );
+}
+
--- /dev/null
+### 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] );
+ }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+1;
\ No newline at end of file
--- /dev/null
+ # 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