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, 10 months ago) by root
Branch:	MAIN
Changes since 1.9:	+87 -43 lines
Log Message:	* empty log message *
#	Content
1	=head1 NAME
2
3	AnyEvent::Log - simple logging "framework"
4
5	=head1 SYNOPSIS
6
7	# 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	# "complex" use
16	use AnyEvent::Log;
17
18	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	# 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
41	=head1 DESCRIPTION
42
43	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	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	before starting your program, or change the logging level at runtime wiht
52	something like:
53
54	use AnyEvent;
55	(AnyEvent::Log::ctx "")->level ("info");
56
57	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	=head1 LOGGING FUNCTIONS
63
64	These functions allow you to log messages. They always use the caller's
65	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
69	=over 4
70
71	=cut
72
73	package AnyEvent::Log;
74
75	use Carp ();
76	use POSIX ();
77
78	use AnyEvent (); BEGIN { AnyEvent::common_sense }
79	use AnyEvent::Util ();
80
81	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	our %CTX; # all logging contexts
95
96	# creates a default package context object for the given package
97	sub _pkg_ctx($) {
98	my $ctx = bless [$_[0], (1 << 10) - 1 - 1, {}], "AnyEvent::Log::Ctx";
99
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	=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	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
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	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
141	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	=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	sub now () { time }
169
170	AnyEvent::post_detect {
171	*now = \&AE::now;
172	};
173
174	our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);
175
176	# time, ctx, level, msg
177	sub _format($$$$) {
178	my $pfx = ft $_[0];
179	my @res;
180
181	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	}
188
189	sub _log {
190	my ($ctx, $level, $format, @args) = @_;
191
192	$level = $level > 0 && $level <= 9 ? $level+0 : $STR2LEVEL{$level} \|\| Carp::croak "$level: not a valid logging level, caught";
193
194	my $mask = 1 << $level;
195
196	my (@ctx, $now, $fmt);
197
198	do {
199	# skip if masked
200	next unless $ctx->[1] & $mask;
201
202	if ($ctx->[3]) {
203	# logging target found
204
205	# now get raw message, unless we have it already
206	unless ($now) {
207	$format = $format->() if ref $format;
208	$format = sprintf $format, @args if @args;
209	$format =~ s/\n$//;
210	$now = AE::now;
211	};
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	# not masked, not consume - propagate to parent contexts
223	push @ctx, values %{ $ctx->[2] };
224	} while $ctx = pop @ctx;
225
226	exit 1 if $level <= 1;
227	}
228
229	sub log($$;@) {
230	_log
231	$CTX{ (caller)[0] } \|\|= _pkg_ctx +(caller)[0],
232	@_;
233	}
234
235	AnyEvent::log = AE::log = \&log;
236
237	=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	my ($ctx, $level, $renabled) = @$_;
286
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	_log $ctx, $level, sub { die };
295
296	1
297	};
298
299	$$renabled = 1; # TODO
300	}
301	}
302
303	sub _logger($;$) {
304	my ($ctx, $level, $renabled) = @_;
305
306	$renabled \|\|= \my $enabled;
307
308	$$renabled = 1;
309
310	my $logger = [$ctx, $level, $renabled];
311
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	_log $ctx, $level, @_
325	if $$renabled;
326	}
327	}
328
329	sub logger($;$) {
330	_logger
331	$CTX{ (caller)[0] } \|\|= _pkg_ctx +(caller)[0],
332	@_
333	}
334
335	=back
336
337	=head1 LOGGING CONTEXTS
338
339	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
343	A logging context has three major responsibilities: filtering, logging and
344	propagating the message.
345
346	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
356	For propagation, a context can have any number of attached I<parent
357	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
361	=head2 DEFAULTS
362
363	By default, all logging contexts have an full set of log levels ("all"), a
364	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	The effect of all this is that log messages, by default, wander up to the
385	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
390	=over 4
391
392	=item $ctx = AnyEvent::Log::ctx [$pkg]
393
394	This function creates or returns a logging context (which is an object).
395
396	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
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	: bless [undef, (1 << 10) - 1 - 1], "AnyEvent::Log::Ctx"
414	}
415
416	# create default root context
417	{
418	my $root = ctx undef;
419	$root->[0] = "";
420	$root->title ("default");
421	$root->level ($AnyEvent::VERBOSE); undef $AnyEvent::VERBOSE;
422	$root->log_cb (sub {
423	print STDERR shift;
424	0
425	});
426	$CTX{""} = $root;
427	}
428
429	=back
430
431	=cut
432
433	package AnyEvent::Log::Ctx;
434
435	# 0 1 2 3 4
436	# [$title, $level, %$parents, &$logcb, &$fmtcb]
437
438	=head2 CONFIGURING A LOG CONTEXT
439
440	The following methods can be used to configure the logging context.
441
442	=over 4
443
444	=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	=back
459
460	=head3 LOGGING LEVELS
461
462	The following methods deal with the logging level set associated with the
463	log context.
464
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	All functions which accept a list of levels also accept the special string
469	C<all> which expands to all logging levels.
470
471	=over 4
472
473	=item $ctx->levels ($level[, $level...)
474
475	Enables logging for the given levels and disables it for all others.
476
477	=item $ctx->level ($level)
478
479	Enables logging for the given level and all lower level (higher priority)
480	ones. In addition to normal logging levels, specifying a level of C<0> or
481	C<off> disables all logging for this level.
482
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
492	=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	map {
500	$_ > 0 && $_ <= 9 ? $_+0
501	: $_ eq "all" ? (1 .. 9)
502	: $STR2LEVEL{$_} \|\| Carp::croak "$_: not a valid logging level, caught"
503	} @_
504	}
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	my $lvl = $_[0] =~ /^(?:0\|off\|none)$/ ? 0 : (_lvl_lst $_[0])[-1];
519
520	$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	=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	=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
564	=cut
565
566	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	=back
581
582	=head3 MESSAGE LOGGING
583
584	The following methods configure how the logging context actually does
585	the logging (which consists of formatting the message and printing it or
586	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	=item $ctx->log_cb ($cb->($str))
592
593	Replaces the logging callback on the context (C<undef> disables the
594	logging callback).
595
596	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	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	=item $ctx->fmt_cb ($fmt_cb->($timestamp, $ctx, $level, $message))
621
622	Replaces the formatting callback on the context (C<undef> restores the
623	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
660	$ctx->[3] = $cb;
661	}
662
663	sub fmt_cb {
664	my ($ctx, $cb) = @_;
665
666	$ctx->[4] = $cb;
667	}
668
669	=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	1;
684
685	=back
686
687	=head1 AUTHOR
688
689	Marc Lehmann <schmorp@schmorp.de>
690	http://home.schmorp.de/
691
692	=cut