lib/AnyEvent/Log.pm

=head1 NAME

AnyEvent::Log - simple logging "framework"

=head1 SYNOPSIS

   # simple use
   use AnyEvent;

   AE::log debug => "hit my knee";
   AE::log warn  => "it's a bit too hot";
   AE::log error => "the flag was false!";
   AE::log fatal => "the bit toggled! run!";

   # "complex" use
   use AnyEvent::Log;

   my $tracer = AnyEvent::Log::logger trace => \$my $trace;

   $tracer->("i am here") if $trace;
   $tracer->(sub { "lots of data: " . Dumper $self }) if $trace;

   # configuration

   # set logging for this package to maximum
   AnyEvent::Log::ctx->level ("all");

   # set logging globally to anything below debug
   (AnyEvent::Log::ctx "")->level ("notice");

   # see also EXAMPLES, below

   # disable logging for package "AnyEvent" and all packages below it
   AnyEvent->AnyEvent::Log::ctx->level (0);

   # log everything below debug to a file, for the whole program
   my $ctx = AnyEvent::Log::ctx;
   $ctx->log_cb (sub { print FILE shift; 0 });
   (AnyEvent::Log::ctx "")->add ($ctx);

=head1 DESCRIPTION

This module implements a relatively simple "logging framework". It doesn't
attempt to be "the" logging solution or even "a" logging solution for
AnyEvent - AnyEvent simply creates logging messages internally, and this
module more or less exposes the mechanism, with some extra spiff to allow
using it from other modules as well.

Remember that the default verbosity level is C<0>, so nothing will be
logged, ever, unless you set C<PERL_ANYEVENT_VERBOSE> to a higher number
before starting your program, or change the logging level at runtime wiht
something like:

   use AnyEvent;
   (AnyEvent::Log::ctx "")->level ("info");

The design goal behind this module was to keep it simple (and small),
but make it powerful enough to be potentially useful for any module, and
extensive enough for the most common tasks, such as logging to multiple
targets, or being able to log into a database.

=head1 LOGGING FUNCTIONS

These functions allow you to log messages. They always use the caller's
package as a "logging module/source". Also, the main logging function is
callable as C<AnyEvent::log> or C<AE::log> when the C<AnyEvent> module is
loaded.

=over 4

=cut

package AnyEvent::Log;

use Carp ();
use POSIX ();

use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util ();

our ($now_int, $now_str1, $now_str2);

# Format Time, not public - yet?
sub ft($) {
   my $i = int $_[0];
   my $f = sprintf "%06d", 1e6 * ($_[0] - $i);

   ($now_int, $now_str1, $now_str2) = ($i, split /\x01/, POSIX::strftime "%Y-%m-%d %H:%M:%S.\x01 %z", localtime $i)
      if $now_int != $i;

   "$now_str1$f$now_str2"
}

our %CTX; # all logging contexts

# creates a default package context object for the given package
sub _pkg_ctx($) {
   my $ctx = bless [$_[0], (1 << 10) - 1 - 1, {}], "AnyEvent::Log::Ctx";

   # link "parent" package
   my $pkg = $_[0] =~ /^(.+)::/ ? $1 : "";

   $pkg = $CTX{$pkg} ||= &_pkg_ctx ($pkg);
   $ctx->[2]{$pkg+0} = $pkg;

   $ctx
}

=item AnyEvent::Log::log $level, $msg[, @args]

Requests logging of the given C<$msg> with the given log level (1..9).
You can also use the following strings as log level: C<fatal> (1),
C<alert> (2), C<critical> (3), C<error> (4), C<warn> (5), C<note> (6),
C<info> (7), C<debug> (8), C<trace> (9).

For C<fatal> log levels, the program will abort.

If only a C<$msg> is given, it is logged as-is. With extra C<@args>, the
C<$msg> is interpreted as an sprintf format string.

The C<$msg> should not end with C<\n>, but may if that is convenient for
you. Also, multiline messages are handled properly.

Last not least, C<$msg> might be a code reference, in which case it is
supposed to return the message. It will be called only then the message
actually gets logged, which is useful if it is costly to create the
message in the first place.

Whether the given message will be logged depends on the maximum log level
and the caller's package.

Note that you can (and should) call this function as C<AnyEvent::log> or
C<AE::log>, without C<use>-ing this module if possible (i.e. you don't
need any additional functionality), as those functions will load the
logging module on demand only. They are also much shorter to write.

Also, if you otpionally generate a lot of debug messages (such as when
tracing some code), you should look into using a logger callback and a
boolean enabler (see C<logger>, below).

Example: log something at error level.

   AE::log error => "something";

Example: use printf-formatting.

   AE::log info => "%5d %-10.10s %s", $index, $category, $msg;

Example: only generate a costly dump when the message is actually being logged.

   AE::log debug => sub { require Data::Dump; Data::Dump::dump \%cache };

=cut

# also allow syslog equivalent names
our %STR2LEVEL = (
   fatal    => 1, emerg    => 1,
   alert    => 2,
   critical => 3, crit     => 3,
   error    => 4, err      => 4,
   warn     => 5, warning  => 5,
   note     => 6, notice   => 6,
   info     => 7,
   debug    => 8,
   trace    => 9,
);

sub now () { time }

AnyEvent::post_detect {
   *now = \&AE::now;
};

our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);

# time, ctx, level, msg
sub _format($$$$) {
   my $pfx = ft $_[0];
   my @res;

   for (split /\n/, sprintf "%-5s %s: %s", $LEVEL2STR[$_[2]], $_[1][0], $_[3]) {
      push @res, "$pfx $_\n";
      $pfx = "\t";
   }

   join "", @res
}

sub _log {
   my ($ctx, $level, $format, @args) = @_;

   $level = $level > 0 && $level <= 9 ? $level+0 : $STR2LEVEL{$level} || Carp::croak "$level: not a valid logging level, caught";

   my $mask = 1 << $level;

   my (@ctx, $now, $fmt);

   do {
      # skip if masked
      next unless $ctx->[1] & $mask;

      if ($ctx->[3]) {
         # logging target found

         # now get raw message, unless we have it already
         unless ($now) {
            $format = $format->() if ref $format;
            $format = sprintf $format, @args if @args;
            $format =~ s/\n$//;
            $now = AE::now;
         };

         # format msg
         my $str = $ctx->[4]
            ? $ctx->[4]($now, $_[0], $level, $format)
            : $fmt ||= _format $now, $_[0], $level, $format;

         $ctx->[3]($str)
            and next;
      }

      # not masked, not consume - propagate to parent contexts
      push @ctx, values %{ $ctx->[2] };
   } while $ctx = pop @ctx;

   exit 1 if $level <= 1;
}

sub log($$;@) {
   _log
      $CTX{ (caller)[0] } ||= _pkg_ctx +(caller)[0],
      @_;
}

*AnyEvent::log = *AE::log = \&log;

=item $logger = AnyEvent::Log::logger $level[, \$enabled]

Creates a code reference that, when called, acts as if the
C<AnyEvent::Log::log> function was called at this point with the givne
level. C<$logger> is passed a C<$msg> and optional C<@args>, just as with
the C<AnyEvent::Log::log> function:

   my $debug_log = AnyEvent::Log::logger "debug";

   $debug_log->("debug here");
   $debug_log->("%06d emails processed", 12345);
   $debug_log->(sub { $obj->as_string });

The idea behind this function is to decide whether to log before actually
logging - when the C<logger> function is called once, but the returned
logger callback often, then this can be a tremendous speed win.

Despite this speed advantage, changes in logging configuration will
still be reflected by the logger callback, even if configuration changes
I<after> it was created.

To further speed up logging, you can bind a scalar variable to the logger,
which contains true if the logger should be called or not - if it is
false, calling the logger can be safely skipped. This variable will be
updated as long as C<$logger> is alive.

Full example:

   # near the init section
   use AnyEvent::Log;

   my $debug_log = AnyEvent:Log::logger debug => \my $debug;

   # and later in your program
   $debug_log->("yo, stuff here") if $debug;

   $debug and $debug_log->("123");

Note: currently the enabled var is always true - that will be fixed in a
future version :)

=cut

our %LOGGER;

# re-assess logging status for all loggers
sub _reassess {
   for (@_ ? $LOGGER{$_[0]} : values %LOGGER) {
      my ($ctx, $level, $renabled) = @$_;

      # to detetc whether a message would be logged, we # actually
      # try to log one and die. this isn't # fast, but we can be
      # sure that the logging decision is correct :)

      $$renabled = !eval {
         local $SIG{__DIE__};

         _log $ctx, $level, sub { die };

         1
      };

      $$renabled = 1; # TODO
   }
}

sub _logger($;$) {
   my ($ctx, $level, $renabled) = @_;

   $renabled ||= \my $enabled;

   $$renabled = 1;

   my $logger = [$ctx, $level, $renabled];

   $LOGGER{$logger+0} = $logger;

   _reassess $logger+0;

   my $guard = AnyEvent::Util::guard {
      # "clean up"
      delete $LOGGER{$logger+0};
   };

   sub {
      $guard if 0; # keep guard alive, but don't cause runtime overhead

      _log $ctx, $level, @_
         if $$renabled;
   }
}

sub logger($;$) {
   _logger
      $CTX{ (caller)[0] } ||= _pkg_ctx +(caller)[0],
      @_
}

=back

=head1 LOGGING CONTEXTS

This module associates every log message with a so-called I<logging
context>, based on the package of the caller. Every perl package has its
own logging context.

A logging context has three major responsibilities: filtering, logging and
propagating the message.

For the first purpose, filtering, each context has a set of logging
levels, called the log level mask. Messages not in the set will be ignored
by this context (masked).

For logging, the context stores a formatting callback (which takes the
timestamp, context, level and string message and formats it in the way
it should be logged) and a logging callback (which is responsible for
actually logging the formatted message and telling C<AnyEvent::Log>
whether it has consumed the message, or whether it should be propagated).

For propagation, a context can have any number of attached I<parent
contexts>. Any message that is neither masked by the logging mask nor
masked by the logging callback returning true will be passed to all parent
contexts.

=head2 DEFAULTS

By default, all logging contexts have an full set of log levels ("all"), a
disabled logging callback and the default formatting callback.

Package contexts have the package name as logging title by default.

They have exactly one parent - the context of the "parent" package. The
parent package is simply defined to be the package name without the last
component, i.e. C<AnyEvent::Debug::Wrapped> becomes C<AnyEvent::Debug>,
and C<AnyEvent> becomes the empty string.

Since perl packages form only an approximate hierarchy, this parent
context can of course be removed.

All other (anonymous) contexts have no parents and an empty title by
default.

When the module is first loaded, it configures the root context (the one
with the empty string) to simply dump all log messages to C<STDERR>,
and sets it's log level set to all levels up to the one specified by
C<$ENV{PERL_ANYEVENT_VERBOSE}>.

The effect of all this is that log messages, by default, wander up to the
root context and will be logged to STDERR if their log level is less than
or equal to C<$ENV{PERL_ANYEVENT_VERBOSE}>.

=head2 CREATING/FINDING A CONTEXT

=over 4

=item $ctx = AnyEvent::Log::ctx [$pkg]

This function creates or returns a logging context (which is an object).

If a package name is given, then the context for that packlage is
returned. If it is called without any arguments, then the context for the
callers package is returned (i.e. the same context as a C<AE::log> call
would use).

If C<undef> is given, then it creates a new anonymous context that is not
tied to any package and is destroyed when no longer referenced.

=cut

sub ctx(;$) {
   my $pkg = @_ ? shift : (caller)[0];

   ref $pkg
      ? $pkg
      : defined $pkg
         ? $CTX{$pkg} ||= AnyEvent::Log::_pkg_ctx $pkg
         : bless [undef, (1 << 10) - 1 - 1], "AnyEvent::Log::Ctx"
}

# create default root context
{
   my $root = ctx undef;
   $root->[0] = "";
   $root->title ("default");
   $root->level ($AnyEvent::VERBOSE); undef $AnyEvent::VERBOSE;
   $root->log_cb (sub {
      print STDERR shift;
      0
   });
   $CTX{""} = $root;
}

=back

=cut

package AnyEvent::Log::Ctx;

#       0       1          2        3        4
# [$title, $level, %$parents, &$logcb, &$fmtcb]

=head2 CONFIGURING A LOG CONTEXT

The following methods can be used to configure the logging context.

=over 4

=item $ctx->title ([$new_title])

Returns the title of the logging context - this is the package name, for
package contexts, and a user defined string for all others.

If C<$new_title> is given, then it replaces the package name or title.

=cut

sub title {
   $_[0][0] = $_[1] if @_ > 1;
   $_[0][0]
}

=back

=head3 LOGGING LEVELS

The following methods deal with the logging level set associated with the
log context.

The most common method to use is probably C<< $ctx->level ($level) >>,
which configures the specified and any higher priority levels.

All functions which accept a list of levels also accept the special string
C<all> which expands to all logging levels.

=over 4

=item $ctx->levels ($level[, $level...)

Enables logging for the given levels and disables it for all others.

=item $ctx->level ($level)

Enables logging for the given level and all lower level (higher priority)
ones. In addition to normal logging levels, specifying a level of C<0> or
C<off> disables all logging for this level.

Example: log warnings, errors and higher priority messages.

   $ctx->level ("warn");
   $ctx->level (5); # same thing, just numeric

=item $ctx->enable ($level[, $level...])

Enables logging for the given levels, leaving all others unchanged.

=item $ctx->disable ($level[, $level...])

Disables logging for the given levels, leaving all others unchanged.

=cut

sub _lvl_lst {
   map {
      $_ > 0 && $_ <= 9 ? $_+0
      : $_ eq "all"     ? (1 .. 9)
      : $STR2LEVEL{$_} || Carp::croak "$_: not a valid logging level, caught"
   } @_
}

our $NOP_CB = sub { 0 };

sub levels {
   my $ctx = shift;
   $ctx->[1] = 0;
   $ctx->[1] |= 1 << $_
      for &_lvl_lst;
   AnyEvent::Log::_reassess;
}

sub level {
   my $ctx = shift;
   my $lvl = $_[0] =~ /^(?:0|off|none)$/ ? 0 : (_lvl_lst $_[0])[-1];

   $ctx->[1] =  ((1 << $lvl) - 1) << 1;
   AnyEvent::Log::_reassess;
}

sub enable {
   my $ctx = shift;
   $ctx->[1] |= 1 << $_
      for &_lvl_lst;
   AnyEvent::Log::_reassess;
}

sub disable {
   my $ctx = shift;
   $ctx->[1] &= ~(1 << $_)
      for &_lvl_lst;
   AnyEvent::Log::_reassess;
}

=back

=head3 PARENT CONTEXTS

The following methods attach and detach another logging context to a
logging context.

Log messages are propagated to all parent contexts, unless the logging
callback consumes the message.

=over 4

=item $ctx->attach ($ctx2[, $ctx3...])

Attaches the given contexts as parents to this context. It is not an error
to add a context twice (the second add will be ignored).

A context can be specified either as package name or as a context object.

=item $ctx->detach ($ctx2[, $ctx3...])

Removes the given parents from this context - it's not an error to attempt
to remove a context that hasn't been added.

A context can be specified either as package name or as a context object.

=cut

sub attach {
   my $ctx = shift;

   $ctx->[2]{$_+0} = $_
      for map { AnyEvent::Log::ctx $_ } @_;
}

sub detach {
   my $ctx = shift;

   delete $ctx->[2]{$_+0}
      for map { AnyEvent::Log::ctx $_ } @_;
}

=back

=head3 MESSAGE LOGGING

The following methods configure how the logging context actually does
the logging (which consists of formatting the message and printing it or
whatever it wants to do with it) and also allows you to log messages
directly to a context, without going via your package context.

=over 4

=item $ctx->log_cb ($cb->($str))

Replaces the logging callback on the context (C<undef> disables the
logging callback).

The logging callback is responsible for handling formatted log messages
(see C<fmt_cb> below) - normally simple text strings that end with a
newline (and are possibly multiline themselves).

It also has to return true iff it has consumed the log message, and false
if it hasn't. Consuming a message means that it will not be sent to any
parent context. When in doubt, return C<0> from your logging callback.

Example: a very simple logging callback, simply dump the message to STDOUT
and do not consume it.

   $ctx->log_cb (sub { print STDERR shift; 0 });

You can filter messages by having a log callback that simply returns C<1>
and does not do anything with the message, but this counts as "message
being logged" and might not be very efficient.

Example: propagate all messages except for log levels "debug" and
"trace". The messages will still be generated, though, which can slow down
your program.

   $ctx->levels ("debug", "trace");
   $ctx->log_cb (sub { 1 }); # do not log, but eat debug and trace messages

=item $ctx->fmt_cb ($fmt_cb->($timestamp, $ctx, $level, $message))

Replaces the formatting callback on the context (C<undef> restores the
default formatter).

The callback is passed the (possibly fractional) timestamp, the original
logging context, the (numeric) logging level and the raw message string and needs to
return a formatted log message. In most cases this will be a string, but
it could just as well be an array reference that just stores the values.

Example: format just the raw message, with numeric log level in angle
brackets.

   $ctx->fmt_cb (sub {
      my ($time, $ctx, $lvl, $msg) = @_;

      "<$lvl>$msg\n"
   });

Example: return an array reference with just the log values, and use
C<PApp::SQL::sql_exec> to store the emssage in a database.

   $ctx->fmt_cb (sub { \@_ });
   $ctx->log_cb (sub {
      my ($msg) = @_;

      sql_exec "insert into log (when, subsys, prio, msg) values (?, ?, ?, ?)",
               $msg->[0] + 0,
               "$msg->[1]",
               $msg->[2] + 0,
               "$msg->[3]";

      0
   });

=cut

sub log_cb {
   my ($ctx, $cb) = @_;

   $ctx->[3] = $cb;
}

sub fmt_cb {
   my ($ctx, $cb) = @_;

   $ctx->[4] = $cb;
}

=item $ctx->log ($level, $msg[, @params])

Same as C<AnyEvent::Log::log>, but uses the given context as log context.

=item $logger = $ctx->logger ($level[, \$enabled])

Same as C<AnyEvent::Log::logger>, but uses the given context as log
context.

=cut

*log    = \&AnyEvent::Log::_log;
*logger = \&AnyEvent::Log::_logger;

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut
Revision:	1.10
Committed:	Fri Aug 19 21:17:08 2011 UTC (12 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.9:	+87 -43 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::Log - simple logging "framework"
4
5			=head1 SYNOPSIS
6
7	root	1.8	# simple use
8			use AnyEvent;
9
10			AE::log debug => "hit my knee";
11			AE::log warn => "it's a bit too hot";
12			AE::log error => "the flag was false!";
13			AE::log fatal => "the bit toggled! run!";
14
15	root	1.10	# "complex" use
16	root	1.1	use AnyEvent::Log;
17
18	root	1.8	my $tracer = AnyEvent::Log::logger trace => \$my $trace;
19
20			$tracer->("i am here") if $trace;
21			$tracer->(sub { "lots of data: " . Dumper $self }) if $trace;
22
23	root	1.10	# configuration
24
25			# set logging for this package to maximum
26			AnyEvent::Log::ctx->level ("all");
27
28			# set logging globally to anything below debug
29			(AnyEvent::Log::ctx "")->level ("notice");
30
31			# see also EXAMPLES, below
32
33			# disable logging for package "AnyEvent" and all packages below it
34			AnyEvent->AnyEvent::Log::ctx->level (0);
35
36			# log everything below debug to a file, for the whole program
37			my $ctx = AnyEvent::Log::ctx;
38			$ctx->log_cb (sub { print FILE shift; 0 });
39			(AnyEvent::Log::ctx "")->add ($ctx);
40	root	1.8
41	root	1.1	=head1 DESCRIPTION
42
43	root	1.2	This module implements a relatively simple "logging framework". It doesn't
44			attempt to be "the" logging solution or even "a" logging solution for
45			AnyEvent - AnyEvent simply creates logging messages internally, and this
46			module more or less exposes the mechanism, with some extra spiff to allow
47			using it from other modules as well.
48
49	root	1.5	Remember that the default verbosity level is C<0>, so nothing will be
50			logged, ever, unless you set C<PERL_ANYEVENT_VERBOSE> to a higher number
51	root	1.9	before starting your program, or change the logging level at runtime wiht
52			something like:
53	root	1.2
54	root	1.9	use AnyEvent;
55			(AnyEvent::Log::ctx "")->level ("info");
56	root	1.2
57	root	1.10	The design goal behind this module was to keep it simple (and small),
58			but make it powerful enough to be potentially useful for any module, and
59			extensive enough for the most common tasks, such as logging to multiple
60			targets, or being able to log into a database.
61
62	root	1.9	=head1 LOGGING FUNCTIONS
63	root	1.2
64			These functions allow you to log messages. They always use the caller's
65	root	1.7	package as a "logging module/source". Also, the main logging function is
66			callable as C<AnyEvent::log> or C<AE::log> when the C<AnyEvent> module is
67			loaded.
68	root	1.1
69			=over 4
70
71			=cut
72
73			package AnyEvent::Log;
74
75	root	1.2	use Carp ();
76	root	1.1	use POSIX ();
77
78			use AnyEvent (); BEGIN { AnyEvent::common_sense }
79	root	1.3	use AnyEvent::Util ();
80	root	1.1
81	root	1.2	our ($now_int, $now_str1, $now_str2);
82
83			# Format Time, not public - yet?
84			sub ft($) {
85			my $i = int $_[0];
86			my $f = sprintf "%06d", 1e6 * ($_[0] - $i);
87
88			($now_int, $now_str1, $now_str2) = ($i, split /\x01/, POSIX::strftime "%Y-%m-%d %H:%M:%S.\x01 %z", localtime $i)
89			if $now_int != $i;
90
91			"$now_str1$f$now_str2"
92			}
93
94	root	1.5	our %CTX; # all logging contexts
95	root	1.3
96	root	1.8	# creates a default package context object for the given package
97			sub _pkg_ctx($) {
98	root	1.10	my $ctx = bless [$_[0], (1 << 10) - 1 - 1, {}], "AnyEvent::Log::Ctx";
99	root	1.8
100			# link "parent" package
101			my $pkg = $_[0] =~ /^(.+)::/ ? $1 : "";
102
103			$pkg = $CTX{$pkg} \|\|= &_pkg_ctx ($pkg);
104			$ctx->[2]{$pkg+0} = $pkg;
105
106			$ctx
107			}
108
109	root	1.2	=item AnyEvent::Log::log $level, $msg[, @args]
110
111			Requests logging of the given C<$msg> with the given log level (1..9).
112			You can also use the following strings as log level: C<fatal> (1),
113			C<alert> (2), C<critical> (3), C<error> (4), C<warn> (5), C<note> (6),
114			C<info> (7), C<debug> (8), C<trace> (9).
115
116			For C<fatal> log levels, the program will abort.
117
118			If only a C<$msg> is given, it is logged as-is. With extra C<@args>, the
119			C<$msg> is interpreted as an sprintf format string.
120
121			The C<$msg> should not end with C<\n>, but may if that is convenient for
122			you. Also, multiline messages are handled properly.
123
124	root	1.3	Last not least, C<$msg> might be a code reference, in which case it is
125			supposed to return the message. It will be called only then the message
126			actually gets logged, which is useful if it is costly to create the
127			message in the first place.
128	root	1.2
129			Whether the given message will be logged depends on the maximum log level
130			and the caller's package.
131
132			Note that you can (and should) call this function as C<AnyEvent::log> or
133	root	1.8	C<AE::log>, without C<use>-ing this module if possible (i.e. you don't
134			need any additional functionality), as those functions will load the
135			logging module on demand only. They are also much shorter to write.
136
137			Also, if you otpionally generate a lot of debug messages (such as when
138			tracing some code), you should look into using a logger callback and a
139			boolean enabler (see C<logger>, below).
140	root	1.2
141	root	1.3	Example: log something at error level.
142
143			AE::log error => "something";
144
145			Example: use printf-formatting.
146
147			AE::log info => "%5d %-10.10s %s", $index, $category, $msg;
148
149			Example: only generate a costly dump when the message is actually being logged.
150
151			AE::log debug => sub { require Data::Dump; Data::Dump::dump \%cache };
152
153	root	1.2	=cut
154
155			# also allow syslog equivalent names
156			our %STR2LEVEL = (
157			fatal => 1, emerg => 1,
158			alert => 2,
159			critical => 3, crit => 3,
160			error => 4, err => 4,
161			warn => 5, warning => 5,
162			note => 6, notice => 6,
163			info => 7,
164			debug => 8,
165			trace => 9,
166			);
167
168	root	1.4	sub now () { time }
169	root	1.10
170	root	1.4	AnyEvent::post_detect {
171			*now = \&AE::now;
172			};
173
174	root	1.2	our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);
175
176	root	1.8	# time, ctx, level, msg
177			sub _format($$$$) {
178			my $pfx = ft $_[0];
179	root	1.10	my @res;
180	root	1.8
181	root	1.10	for (split /\n/, sprintf "%-5s %s: %s", $LEVEL2STR[$_[2]], $_[1][0], $_[3]) {
182			push @res, "$pfx $_\n";
183			$pfx = "\t";
184			}
185
186			join "", @res
187	root	1.8	}
188
189	root	1.3	sub _log {
190	root	1.8	my ($ctx, $level, $format, @args) = @_;
191	root	1.2
192	root	1.8	$level = $level > 0 && $level <= 9 ? $level+0 : $STR2LEVEL{$level} \|\| Carp::croak "$level: not a valid logging level, caught";
193	root	1.2
194	root	1.8	my $mask = 1 << $level;
195	root	1.2
196	root	1.10	my (@ctx, $now, $fmt);
197	root	1.4
198	root	1.8	do {
199	root	1.10	# skip if masked
200			next unless $ctx->[1] & $mask;
201
202			if ($ctx->[3]) {
203	root	1.8	# logging target found
204
205	root	1.10	# now get raw message, unless we have it already
206			unless ($now) {
207	root	1.8	$format = $format->() if ref $format;
208			$format = sprintf $format, @args if @args;
209			$format =~ s/\n$//;
210	root	1.10	$now = AE::now;
211	root	1.8	};
212
213			# format msg
214			my $str = $ctx->[4]
215			? $ctx->[4]($now, $_[0], $level, $format)
216			: $fmt \|\|= _format $now, $_[0], $level, $format;
217
218			$ctx->[3]($str)
219			and next;
220			}
221
222	root	1.10	# not masked, not consume - propagate to parent contexts
223	root	1.8	push @ctx, values %{ $ctx->[2] };
224			} while $ctx = pop @ctx;
225	root	1.2
226			exit 1 if $level <= 1;
227			}
228
229	root	1.3	sub log($$;@) {
230	root	1.8	_log
231			$CTX{ (caller)[0] } \|\|= _pkg_ctx +(caller)[0],
232			@_;
233	root	1.3	}
234
235	root	1.2	AnyEvent::log = AE::log = \&log;
236
237	root	1.3	=item $logger = AnyEvent::Log::logger $level[, \$enabled]
238
239			Creates a code reference that, when called, acts as if the
240			C<AnyEvent::Log::log> function was called at this point with the givne
241			level. C<$logger> is passed a C<$msg> and optional C<@args>, just as with
242			the C<AnyEvent::Log::log> function:
243
244			my $debug_log = AnyEvent::Log::logger "debug";
245
246			$debug_log->("debug here");
247			$debug_log->("%06d emails processed", 12345);
248			$debug_log->(sub { $obj->as_string });
249
250			The idea behind this function is to decide whether to log before actually
251			logging - when the C<logger> function is called once, but the returned
252			logger callback often, then this can be a tremendous speed win.
253
254			Despite this speed advantage, changes in logging configuration will
255			still be reflected by the logger callback, even if configuration changes
256			I<after> it was created.
257
258			To further speed up logging, you can bind a scalar variable to the logger,
259			which contains true if the logger should be called or not - if it is
260			false, calling the logger can be safely skipped. This variable will be
261			updated as long as C<$logger> is alive.
262
263			Full example:
264
265			# near the init section
266			use AnyEvent::Log;
267
268			my $debug_log = AnyEvent:Log::logger debug => \my $debug;
269
270			# and later in your program
271			$debug_log->("yo, stuff here") if $debug;
272
273			$debug and $debug_log->("123");
274
275			Note: currently the enabled var is always true - that will be fixed in a
276			future version :)
277
278			=cut
279
280			our %LOGGER;
281
282			# re-assess logging status for all loggers
283			sub _reassess {
284			for (@_ ? $LOGGER{$_[0]} : values %LOGGER) {
285	root	1.8	my ($ctx, $level, $renabled) = @$_;
286	root	1.3
287			# to detetc whether a message would be logged, we # actually
288			# try to log one and die. this isn't # fast, but we can be
289			# sure that the logging decision is correct :)
290
291			$$renabled = !eval {
292			local $SIG{__DIE__};
293
294	root	1.8	_log $ctx, $level, sub { die };
295	root	1.3
296			1
297			};
298
299			$$renabled = 1; # TODO
300			}
301			}
302
303	root	1.8	sub _logger($;$) {
304			my ($ctx, $level, $renabled) = @_;
305	root	1.3
306			$renabled \|\|= \my $enabled;
307
308			$$renabled = 1;
309
310	root	1.8	my $logger = [$ctx, $level, $renabled];
311	root	1.3
312			$LOGGER{$logger+0} = $logger;
313
314			_reassess $logger+0;
315
316			my $guard = AnyEvent::Util::guard {
317			# "clean up"
318			delete $LOGGER{$logger+0};
319			};
320
321			sub {
322			$guard if 0; # keep guard alive, but don't cause runtime overhead
323
324	root	1.8	_log $ctx, $level, @_
325	root	1.3	if $$renabled;
326			}
327			}
328
329	root	1.8	sub logger($;$) {
330			_logger
331			$CTX{ (caller)[0] } \|\|= _pkg_ctx +(caller)[0],
332			@_
333			}
334
335	root	1.2	=back
336
337	root	1.9	=head1 LOGGING CONTEXTS
338	root	1.2
339	root	1.9	This module associates every log message with a so-called I<logging
340			context>, based on the package of the caller. Every perl package has its
341			own logging context.
342	root	1.8
343	root	1.10	A logging context has three major responsibilities: filtering, logging and
344			propagating the message.
345	root	1.9
346	root	1.10	For the first purpose, filtering, each context has a set of logging
347			levels, called the log level mask. Messages not in the set will be ignored
348			by this context (masked).
349
350			For logging, the context stores a formatting callback (which takes the
351			timestamp, context, level and string message and formats it in the way
352			it should be logged) and a logging callback (which is responsible for
353			actually logging the formatted message and telling C<AnyEvent::Log>
354			whether it has consumed the message, or whether it should be propagated).
355	root	1.9
356			For propagation, a context can have any number of attached I<parent
357	root	1.10	contexts>. Any message that is neither masked by the logging mask nor
358			masked by the logging callback returning true will be passed to all parent
359			contexts.
360	root	1.9
361			=head2 DEFAULTS
362
363	root	1.10	By default, all logging contexts have an full set of log levels ("all"), a
364	root	1.9	disabled logging callback and the default formatting callback.
365
366			Package contexts have the package name as logging title by default.
367
368			They have exactly one parent - the context of the "parent" package. The
369			parent package is simply defined to be the package name without the last
370			component, i.e. C<AnyEvent::Debug::Wrapped> becomes C<AnyEvent::Debug>,
371			and C<AnyEvent> becomes the empty string.
372
373			Since perl packages form only an approximate hierarchy, this parent
374			context can of course be removed.
375
376			All other (anonymous) contexts have no parents and an empty title by
377			default.
378
379			When the module is first loaded, it configures the root context (the one
380			with the empty string) to simply dump all log messages to C<STDERR>,
381			and sets it's log level set to all levels up to the one specified by
382			C<$ENV{PERL_ANYEVENT_VERBOSE}>.
383
384	root	1.10	The effect of all this is that log messages, by default, wander up to the
385	root	1.9	root context and will be logged to STDERR if their log level is less than
386			or equal to C<$ENV{PERL_ANYEVENT_VERBOSE}>.
387
388			=head2 CREATING/FINDING A CONTEXT
389	root	1.2
390			=over 4
391
392	root	1.8	=item $ctx = AnyEvent::Log::ctx [$pkg]
393
394	root	1.9	This function creates or returns a logging context (which is an object).
395	root	1.8
396	root	1.9	If a package name is given, then the context for that packlage is
397			returned. If it is called without any arguments, then the context for the
398			callers package is returned (i.e. the same context as a C<AE::log> call
399			would use).
400	root	1.8
401			If C<undef> is given, then it creates a new anonymous context that is not
402			tied to any package and is destroyed when no longer referenced.
403
404			=cut
405
406			sub ctx(;$) {
407			my $pkg = @_ ? shift : (caller)[0];
408
409			ref $pkg
410			? $pkg
411			: defined $pkg
412			? $CTX{$pkg} \|\|= AnyEvent::Log::_pkg_ctx $pkg
413	root	1.10	: bless [undef, (1 << 10) - 1 - 1], "AnyEvent::Log::Ctx"
414	root	1.8	}
415
416			# create default root context
417			{
418			my $root = ctx undef;
419			$root->[0] = "";
420			$root->title ("default");
421	root	1.9	$root->level ($AnyEvent::VERBOSE); undef $AnyEvent::VERBOSE;
422	root	1.8	$root->log_cb (sub {
423			print STDERR shift;
424			0
425			});
426			$CTX{""} = $root;
427			}
428
429	root	1.9	=back
430
431			=cut
432
433	root	1.8	package AnyEvent::Log::Ctx;
434
435			# 0 1 2 3 4
436			# [$title, $level, %$parents, &$logcb, &$fmtcb]
437
438	root	1.9	=head2 CONFIGURING A LOG CONTEXT
439
440			The following methods can be used to configure the logging context.
441
442			=over 4
443
444	root	1.8	=item $ctx->title ([$new_title])
445
446			Returns the title of the logging context - this is the package name, for
447			package contexts, and a user defined string for all others.
448
449			If C<$new_title> is given, then it replaces the package name or title.
450
451			=cut
452
453			sub title {
454			$_[0][0] = $_[1] if @_ > 1;
455			$_[0][0]
456			}
457
458	root	1.9	=back
459
460			=head3 LOGGING LEVELS
461
462	root	1.10	The following methods deal with the logging level set associated with the
463			log context.
464	root	1.9
465			The most common method to use is probably C<< $ctx->level ($level) >>,
466			which configures the specified and any higher priority levels.
467
468	root	1.10	All functions which accept a list of levels also accept the special string
469			C<all> which expands to all logging levels.
470
471	root	1.9	=over 4
472
473	root	1.8	=item $ctx->levels ($level[, $level...)
474
475	root	1.10	Enables logging for the given levels and disables it for all others.
476	root	1.8
477			=item $ctx->level ($level)
478
479			Enables logging for the given level and all lower level (higher priority)
480	root	1.10	ones. In addition to normal logging levels, specifying a level of C<0> or
481			C<off> disables all logging for this level.
482	root	1.8
483			Example: log warnings, errors and higher priority messages.
484
485			$ctx->level ("warn");
486			$ctx->level (5); # same thing, just numeric
487
488			=item $ctx->enable ($level[, $level...])
489
490			Enables logging for the given levels, leaving all others unchanged.
491	root	1.5
492	root	1.8	=item $ctx->disable ($level[, $level...])
493
494			Disables logging for the given levels, leaving all others unchanged.
495
496			=cut
497
498			sub _lvl_lst {
499	root	1.10	map {
500			$_ > 0 && $_ <= 9 ? $_+0
501			: $_ eq "all" ? (1 .. 9)
502			: $STR2LEVEL{$_} \|\| Carp::croak "$_: not a valid logging level, caught"
503			} @_
504	root	1.8	}
505
506			our $NOP_CB = sub { 0 };
507
508			sub levels {
509			my $ctx = shift;
510			$ctx->[1] = 0;
511			$ctx->[1] \|= 1 << $_
512			for &_lvl_lst;
513			AnyEvent::Log::_reassess;
514			}
515
516			sub level {
517			my $ctx = shift;
518	root	1.10	my $lvl = $_[0] =~ /^(?:0\|off\|none)$/ ? 0 : (_lvl_lst $_[0])[-1];
519
520	root	1.8	$ctx->[1] = ((1 << $lvl) - 1) << 1;
521			AnyEvent::Log::_reassess;
522			}
523
524			sub enable {
525			my $ctx = shift;
526			$ctx->[1] \|= 1 << $_
527			for &_lvl_lst;
528			AnyEvent::Log::_reassess;
529			}
530
531			sub disable {
532			my $ctx = shift;
533			$ctx->[1] &= ~(1 << $_)
534			for &_lvl_lst;
535			AnyEvent::Log::_reassess;
536			}
537
538	root	1.9	=back
539
540			=head3 PARENT CONTEXTS
541
542			The following methods attach and detach another logging context to a
543			logging context.
544
545			Log messages are propagated to all parent contexts, unless the logging
546			callback consumes the message.
547
548			=over 4
549
550	root	1.8	=item $ctx->attach ($ctx2[, $ctx3...])
551
552			Attaches the given contexts as parents to this context. It is not an error
553			to add a context twice (the second add will be ignored).
554
555			A context can be specified either as package name or as a context object.
556
557			=item $ctx->detach ($ctx2[, $ctx3...])
558
559			Removes the given parents from this context - it's not an error to attempt
560			to remove a context that hasn't been added.
561
562			A context can be specified either as package name or as a context object.
563	root	1.5
564	root	1.2	=cut
565
566	root	1.8	sub attach {
567			my $ctx = shift;
568
569			$ctx->[2]{$_+0} = $_
570			for map { AnyEvent::Log::ctx $_ } @_;
571			}
572
573			sub detach {
574			my $ctx = shift;
575
576			delete $ctx->[2]{$_+0}
577			for map { AnyEvent::Log::ctx $_ } @_;
578			}
579
580	root	1.9	=back
581
582			=head3 MESSAGE LOGGING
583
584			The following methods configure how the logging context actually does
585	root	1.10	the logging (which consists of formatting the message and printing it or
586	root	1.9	whatever it wants to do with it) and also allows you to log messages
587			directly to a context, without going via your package context.
588
589			=over 4
590
591	root	1.8	=item $ctx->log_cb ($cb->($str))
592	root	1.5
593	root	1.8	Replaces the logging callback on the context (C<undef> disables the
594			logging callback).
595	root	1.5
596	root	1.8	The logging callback is responsible for handling formatted log messages
597			(see C<fmt_cb> below) - normally simple text strings that end with a
598			newline (and are possibly multiline themselves).
599
600			It also has to return true iff it has consumed the log message, and false
601			if it hasn't. Consuming a message means that it will not be sent to any
602			parent context. When in doubt, return C<0> from your logging callback.
603
604			Example: a very simple logging callback, simply dump the message to STDOUT
605			and do not consume it.
606
607			$ctx->log_cb (sub { print STDERR shift; 0 });
608
609	root	1.10	You can filter messages by having a log callback that simply returns C<1>
610			and does not do anything with the message, but this counts as "message
611			being logged" and might not be very efficient.
612
613			Example: propagate all messages except for log levels "debug" and
614			"trace". The messages will still be generated, though, which can slow down
615			your program.
616
617			$ctx->levels ("debug", "trace");
618			$ctx->log_cb (sub { 1 }); # do not log, but eat debug and trace messages
619
620	root	1.8	=item $ctx->fmt_cb ($fmt_cb->($timestamp, $ctx, $level, $message))
621
622	root	1.10	Replaces the formatting callback on the context (C<undef> restores the
623	root	1.8	default formatter).
624
625			The callback is passed the (possibly fractional) timestamp, the original
626			logging context, the (numeric) logging level and the raw message string and needs to
627			return a formatted log message. In most cases this will be a string, but
628			it could just as well be an array reference that just stores the values.
629
630			Example: format just the raw message, with numeric log level in angle
631			brackets.
632
633			$ctx->fmt_cb (sub {
634			my ($time, $ctx, $lvl, $msg) = @_;
635
636			"<$lvl>$msg\n"
637			});
638
639			Example: return an array reference with just the log values, and use
640			C<PApp::SQL::sql_exec> to store the emssage in a database.
641
642			$ctx->fmt_cb (sub { \@_ });
643			$ctx->log_cb (sub {
644			my ($msg) = @_;
645
646			sql_exec "insert into log (when, subsys, prio, msg) values (?, ?, ?, ?)",
647			$msg->[0] + 0,
648			"$msg->[1]",
649			$msg->[2] + 0,
650			"$msg->[3]";
651
652			0
653			});
654
655			=cut
656
657			sub log_cb {
658			my ($ctx, $cb) = @_;
659	root	1.6
660	root	1.10	$ctx->[3] = $cb;
661	root	1.6	}
662	root	1.5
663	root	1.8	sub fmt_cb {
664			my ($ctx, $cb) = @_;
665	root	1.6
666	root	1.8	$ctx->[4] = $cb;
667	root	1.5	}
668
669	root	1.8	=item $ctx->log ($level, $msg[, @params])
670
671			Same as C<AnyEvent::Log::log>, but uses the given context as log context.
672
673			=item $logger = $ctx->logger ($level[, \$enabled])
674
675			Same as C<AnyEvent::Log::logger>, but uses the given context as log
676			context.
677
678			=cut
679
680			*log = \&AnyEvent::Log::_log;
681			*logger = \&AnyEvent::Log::_logger;
682
683	root	1.1	1;
684
685			=back
686
687			=head1 AUTHOR
688
689			Marc Lehmann <schmorp@schmorp.de>
690			http://home.schmorp.de/
691
692			=cut