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;

   #TODO: config
   #TODO: ctx () becomes caller[0]...

=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");

=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

my $default_log_cb = sub { 0 };

# creates a default package context object for the given package
sub _pkg_ctx($) {
   my $ctx = bless [$_[0], 0, {}, $default_log_cb], "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];

   join "",
      map "$pfx $_\n",
         split /\n/,
            sprintf "%-5s %s: %s", $LEVEL2STR[$_[2]], $_[1][0], $_[3]
}

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 $now = AE::now;

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

   do {
      if ($ctx->[1] & $mask) {
         # logging target found

         # get raw message
         unless ($did_format) {
            $format = $format->() if ref $format;
            $format = sprintf $format, @args if @args;
            $format =~ s/\n$//;
            $did_format = 1;
         };

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

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

      # not consume - push 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],
      @_
}

#TODO

=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 two major responsibilities: logging the message and
propagating the message to other contexts.

For logging, the context stores a set of logging levels that it
potentially wishes to log, a formatting callback that takes the timestamp,
context, level and string emssage 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>. They will be ignored if the logging callback consumes the
message, but in all other cases, the log message will be passed to all
parent contexts attached to a context.

=head2 DEFAULTS

By default, all logging contexts have an empty set of log levels, 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 effetc 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, 0, undef, $default_log_cb], "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 wiht the log context.

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

=over 4

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

Enables logging fot 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. 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 : $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])[0];
   $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 foratting 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 });

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

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