[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/Log.pm

Comparing AnyEvent/lib/AnyEvent/Log.pm (file contents):
Revision 1.7 by root, Thu Aug 18 18:02:11 2011 UTC vs.
Revision 1.8 by root, Fri Aug 19 19:20:36 2011 UTC

…		…
2		2
3	AnyEvent::Log - simple logging "framework"	3	AnyEvent::Log - simple logging "framework"
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		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
7	use AnyEvent::Log;	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]...
8		25
9	=head1 DESCRIPTION	26	=head1 DESCRIPTION
10		27
11	This module implements a relatively simple "logging framework". It doesn't	28	This module implements a relatively simple "logging framework". It doesn't
12	attempt to be "the" logging solution or even "a" logging solution for	29	attempt to be "the" logging solution or even "a" logging solution for
…		…
54	"$now_str1$f$now_str2"	71	"$now_str1$f$now_str2"
55	}	72	}
56		73
57	our %CTX; # all logging contexts	74	our %CTX; # all logging contexts
58		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
59	=item AnyEvent::Log::log $level, $msg[, @args]	91	=item AnyEvent::Log::log $level, $msg[, @args]
60		92
61	Requests logging of the given C<$msg> with the given log level (1..9).	93	Requests logging of the given C<$msg> with the given log level (1..9).
62	You can also use the following strings as log level: C<fatal> (1),	94	You can also use the following strings as log level: C<fatal> (1),
63	C<alert> (2), C<critical> (3), C<error> (4), C<warn> (5), C<note> (6),	95	C<alert> (2), C<critical> (3), C<error> (4), C<warn> (5), C<note> (6),
…		…
78		110
79	Whether the given message will be logged depends on the maximum log level	111	Whether the given message will be logged depends on the maximum log level
80	and the caller's package.	112	and the caller's package.
81		113
82	Note that you can (and should) call this function as C<AnyEvent::log> or	114	Note that you can (and should) call this function as C<AnyEvent::log> or
83	C<AE::log>, without C<use>-ing this module if possible, as those functions	115	C<AE::log>, without C<use>-ing this module if possible (i.e. you don't
84	will laod the logging module on demand only.	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).
85		122
86	Example: log something at error level.	123	Example: log something at error level.
87		124
88	AE::log error => "something";	125	AE::log error => "something";
89		126
…		…
115	*now = \&AE::now;	152	*now = \&AE::now;
116	};	153	};
117		154
118	our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);	155	our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);
119		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
120	sub _log {	167	sub _log {
121	my ($pkg, $targ, $msg, @args) = @_;	168	my ($ctx, $level, $format, @args) = @_;
122		169
123	my $level = ref $targ ? die "Can't use reference as logging level (yet)"	170	$level = $level > 0 && $level <= 9 ? $level+0 : $STR2LEVEL{$level} \|\| Carp::croak "$level: not a valid logging level, caught";
124	: $targ > 0 && $targ <= 9 ? $targ+0
125	: $STR2LEVEL{$targ} \|\| Carp::croak "$targ: not a valid logging level, caught";
126		171
127	#TODO: find actual targets, see if we even have to log	172	my $mask = 1 << $level;
		173	my $now = AE::now;
128		174
129	return unless $level <= $AnyEvent::VERBOSE;	175	my (@ctx, $did_format, $fmt);
130		176
131	$msg = $msg->() if ref $msg;	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;
132	$msg = sprintf $msg, @args if @args;	184	$format = sprintf $format, @args if @args;
133	$msg =~ s/\n$//;	185	$format =~ s/\n$//;
		186	$did_format = 1;
		187	};
134		188
135	# now we have a message, log it	189	# format msg
		190	my $str = $ctx->[4]
		191	? $ctx->[4]($now, $_[0], $level, $format)
		192	: $fmt \|\|= _format $now, $_[0], $level, $format;
136		193
137	# TODO: writers/processors/filters/formatters?	194	$ctx->[3]($str)
		195	and next;
		196	}
138		197
139	$msg = sprintf "%-5s %s: %s", $LEVEL2STR[$level], $pkg, $msg;	198	# not consume - push parent contexts
140	my $pfx = ft now;	199	push @ctx, values %{ $ctx->[2] };
141		200	} while $ctx = pop @ctx;
142	for (split /\n/, $msg) {
143	printf STDERR "$pfx $_\n";
144	$pfx = "\t";
145	}
146		201
147	exit 1 if $level <= 1;	202	exit 1 if $level <= 1;
148	}	203	}
149		204
150	sub log($$;@) {	205	sub log($$;@) {
151	_log +(caller)[0], @_;	206	_log
		207	$CTX{ (caller)[0] } \|\|= _pkg_ctx +(caller)[0],
		208	@_;
152	}	209	}
153		210
154	AnyEvent::log = AE::log = \&log;	211	AnyEvent::log = AE::log = \&log;
155		212
156	=item $logger = AnyEvent::Log::logger $level[, \$enabled]	213	=item $logger = AnyEvent::Log::logger $level[, \$enabled]
…		…
199	our %LOGGER;	256	our %LOGGER;
200		257
201	# re-assess logging status for all loggers	258	# re-assess logging status for all loggers
202	sub _reassess {	259	sub _reassess {
203	for (@_ ? $LOGGER{$_[0]} : values %LOGGER) {	260	for (@_ ? $LOGGER{$_[0]} : values %LOGGER) {
204	my ($pkg, $level, $renabled) = @$_;	261	my ($ctx, $level, $renabled) = @$_;
205		262
206	# to detetc whether a message would be logged, we # actually	263	# to detetc whether a message would be logged, we # actually
207	# try to log one and die. this isn't # fast, but we can be	264	# try to log one and die. this isn't # fast, but we can be
208	# sure that the logging decision is correct :)	265	# sure that the logging decision is correct :)
209		266
210	$$renabled = !eval {	267	$$renabled = !eval {
211	local $SIG{__DIE__};	268	local $SIG{__DIE__};
212		269
213	_log $pkg, $level, sub { die };	270	_log $ctx, $level, sub { die };
214		271
215	1	272	1
216	};	273	};
217		274
218	$$renabled = 1; # TODO	275	$$renabled = 1; # TODO
219	}	276	}
220	}	277	}
221		278
222	sub logger($;$) {	279	sub _logger($;$) {
223	my ($level, $renabled) = @_;	280	my ($ctx, $level, $renabled) = @_;
224		281
225	$renabled \|\|= \my $enabled;	282	$renabled \|\|= \my $enabled;
226	my $pkg = (caller)[0];
227		283
228	$$renabled = 1;	284	$$renabled = 1;
229		285
230	my $logger = [$pkg, $level, $renabled];	286	my $logger = [$ctx, $level, $renabled];
231		287
232	$LOGGER{$logger+0} = $logger;	288	$LOGGER{$logger+0} = $logger;
233		289
234	_reassess $logger+0;	290	_reassess $logger+0;
235		291
…		…
239	};	295	};
240		296
241	sub {	297	sub {
242	$guard if 0; # keep guard alive, but don't cause runtime overhead	298	$guard if 0; # keep guard alive, but don't cause runtime overhead
243		299
244	_log $pkg, $level, @_	300	_log $ctx, $level, @_
245	if $$renabled;	301	if $$renabled;
246	}	302	}
247	}	303	}
248		304
		305	sub logger($;$) {
		306	_logger
		307	$CTX{ (caller)[0] } \|\|= _pkg_ctx +(caller)[0],
		308	@_
		309	}
		310
249	#TODO	311	#TODO
250		312
251	=back	313	=back
252		314
253	=head1 CONFIGURATION FUNCTIONALITY	315	=head1 CONFIGURATION FUNCTIONALITY
254		316
255	None, yet, except for C<PERL_ANYEVENT_VERBOSE>, described in the L<AnyEvent> manpage.	317	None, yet, except for C<PERL_ANYEVENT_VERBOSE>, described in the L<AnyEvent> manpage.
		318
		319	#TODO: wahst a context
256	#TODO	320	#TODO
257		321
258	=over 4	322	=over 4
259		323
260	=item $ctx = AnyEvent::Log::cfg [$pkg]	324	=item $ctx = AnyEvent::Log::ctx [$pkg]
261		325
262	Returns a I<config> object for the given package name (or previously	326	Returns a I<config> object for the given package name.
263	created package-less configuration). If no package name, or C<undef>, is	327
		328	If no package name is given, returns the context for the current perl
		329	package (i.e. the same context as a C<AE::log> call would use).
		330
264	given, then it creates a new anonymous context that is not tied to any	331	If C<undef> is given, then it creates a new anonymous context that is not
265	package.	332	tied to any package and is destroyed when no longer referenced.
266		333
267	=cut	334	=cut
268		335
269	sub cfg(;$) {	336	sub ctx(;$) {
270	my $name = shift;	337	my $pkg = @_ ? shift : (caller)[0];
271		338
272	my $ctx = defined $name ? $CTX{$name} : undef;	339	ref $pkg
		340	? $pkg
		341	: defined $pkg
		342	? $CTX{$pkg} \|\|= AnyEvent::Log::_pkg_ctx $pkg
		343	: bless [undef, 0, undef, $default_log_cb], "AnyEvent::Log::Ctx"
		344	}
273		345
274	unless ($ctx) {	346	# create default root context
275	$ctx = bless {}, "AnyEvent::Log::Ctx";	347	{
276	$name = -$ctx unless defined $name;	348	my $root = ctx undef;
277	$ctx->{name} = $name;	349	$root->[0] = "";
278	$CTX{$name} = $ctx;	350	$root->title ("default");
		351	$root->level ($AnyEvent::VERBOSE);
		352	$root->log_cb (sub {
		353	print STDERR shift;
		354	0
279	}	355	});
280		356	$CTX{""} = $root;
281	$ctx
282	}	357	}
283		358
284	package AnyEvent::Log::Ctx;	359	package AnyEvent::Log::Ctx;
285		360
286	sub DESTROY {	361	# 0 1 2 3 4
287	# if only one member is remaining (name!) then delete this context	362	# [$title, $level, %$parents, &$logcb, &$fmtcb]
288	delete $CTX{$_[0]{name}}	363
289	if 1 == scalar keys %{ $_[0] };	364	=item $ctx->title ([$new_title])
		365
		366	Returns the title of the logging context - this is the package name, for
		367	package contexts, and a user defined string for all others.
		368
		369	If C<$new_title> is given, then it replaces the package name or title.
		370
		371	=cut
		372
		373	sub title {
		374	$_[0][0] = $_[1] if @_ > 1;
		375	$_[0][0]
290	}	376	}
		377
		378	=item $ctx->levels ($level[, $level...)
		379
		380	Enables logging fot the given levels and disables it for all others.
		381
		382	=item $ctx->level ($level)
		383
		384	Enables logging for the given level and all lower level (higher priority)
		385	ones. Specifying a level of C<0> or C<off> disables all logging for this
		386	level.
		387
		388	Example: log warnings, errors and higher priority messages.
		389
		390	$ctx->level ("warn");
		391	$ctx->level (5); # same thing, just numeric
		392
		393	=item $ctx->enable ($level[, $level...])
		394
		395	Enables logging for the given levels, leaving all others unchanged.
		396
		397	=item $ctx->disable ($level[, $level...])
		398
		399	Disables logging for the given levels, leaving all others unchanged.
		400
		401	=cut
		402
		403	sub _lvl_lst {
		404	map { $_ > 0 && $_ <= 9 ? $_+0 : $STR2LEVEL{$_} \|\| Carp::croak "$_: not a valid logging level, caught" }
		405	@_
		406	}
		407
		408	our $NOP_CB = sub { 0 };
		409
		410	sub levels {
		411	my $ctx = shift;
		412	$ctx->[1] = 0;
		413	$ctx->[1] \|= 1 << $_
		414	for &_lvl_lst;
		415	AnyEvent::Log::_reassess;
		416	}
		417
		418	sub level {
		419	my $ctx = shift;
		420	my $lvl = $_[0] =~ /^(?:0\|off\|none)$/ ? 0 : (_lvl_lst $_[0])[0];
		421	$ctx->[1] = ((1 << $lvl) - 1) << 1;
		422	AnyEvent::Log::_reassess;
		423	}
		424
		425	sub enable {
		426	my $ctx = shift;
		427	$ctx->[1] \|= 1 << $_
		428	for &_lvl_lst;
		429	AnyEvent::Log::_reassess;
		430	}
		431
		432	sub disable {
		433	my $ctx = shift;
		434	$ctx->[1] &= ~(1 << $_)
		435	for &_lvl_lst;
		436	AnyEvent::Log::_reassess;
		437	}
		438
		439	=item $ctx->attach ($ctx2[, $ctx3...])
		440
		441	Attaches the given contexts as parents to this context. It is not an error
		442	to add a context twice (the second add will be ignored).
		443
		444	A context can be specified either as package name or as a context object.
		445
		446	=item $ctx->detach ($ctx2[, $ctx3...])
		447
		448	Removes the given parents from this context - it's not an error to attempt
		449	to remove a context that hasn't been added.
		450
		451	A context can be specified either as package name or as a context object.
		452
		453	=cut
		454
		455	sub attach {
		456	my $ctx = shift;
		457
		458	$ctx->[2]{$_+0} = $_
		459	for map { AnyEvent::Log::ctx $_ } @_;
		460	}
		461
		462	sub detach {
		463	my $ctx = shift;
		464
		465	delete $ctx->[2]{$_+0}
		466	for map { AnyEvent::Log::ctx $_ } @_;
		467	}
		468
		469	=item $ctx->log_cb ($cb->($str))
		470
		471	Replaces the logging callback on the context (C<undef> disables the
		472	logging callback).
		473
		474	The logging callback is responsible for handling formatted log messages
		475	(see C<fmt_cb> below) - normally simple text strings that end with a
		476	newline (and are possibly multiline themselves).
		477
		478	It also has to return true iff it has consumed the log message, and false
		479	if it hasn't. Consuming a message means that it will not be sent to any
		480	parent context. When in doubt, return C<0> from your logging callback.
		481
		482	Example: a very simple logging callback, simply dump the message to STDOUT
		483	and do not consume it.
		484
		485	$ctx->log_cb (sub { print STDERR shift; 0 });
		486
		487	=item $ctx->fmt_cb ($fmt_cb->($timestamp, $ctx, $level, $message))
		488
		489	Replaces the fornatting callback on the cobntext (C<undef> restores the
		490	default formatter).
		491
		492	The callback is passed the (possibly fractional) timestamp, the original
		493	logging context, the (numeric) logging level and the raw message string and needs to
		494	return a formatted log message. In most cases this will be a string, but
		495	it could just as well be an array reference that just stores the values.
		496
		497	Example: format just the raw message, with numeric log level in angle
		498	brackets.
		499
		500	$ctx->fmt_cb (sub {
		501	my ($time, $ctx, $lvl, $msg) = @_;
		502
		503	"<$lvl>$msg\n"
		504	});
		505
		506	Example: return an array reference with just the log values, and use
		507	C<PApp::SQL::sql_exec> to store the emssage in a database.
		508
		509	$ctx->fmt_cb (sub { \@_ });
		510	$ctx->log_cb (sub {
		511	my ($msg) = @_;
		512
		513	sql_exec "insert into log (when, subsys, prio, msg) values (?, ?, ?, ?)",
		514	$msg->[0] + 0,
		515	"$msg->[1]",
		516	$msg->[2] + 0,
		517	"$msg->[3]";
		518
		519	0
		520	});
		521
		522	=cut
		523
		524	sub log_cb {
		525	my ($ctx, $cb) = @_;
		526
		527	$ctx->[3] = $cb \|\| $default_log_cb;
		528	}
		529
		530	sub fmt_cb {
		531	my ($ctx, $cb) = @_;
		532
		533	$ctx->[4] = $cb;
		534	}
		535
		536	=item $ctx->log ($level, $msg[, @params])
		537
		538	Same as C<AnyEvent::Log::log>, but uses the given context as log context.
		539
		540	=item $logger = $ctx->logger ($level[, \$enabled])
		541
		542	Same as C<AnyEvent::Log::logger>, but uses the given context as log
		543	context.
		544
		545	=cut
		546
		547	*log = \&AnyEvent::Log::_log;
		548	*logger = \&AnyEvent::Log::_logger;
291		549
292	1;	550	1;
293		551
294	=back	552	=back
295		553

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent/lib/AnyEvent/Log.pm (file contents): Revision 1.7 by root, Thu Aug 18 18:02:11 2011 UTC vs. Revision 1.8 by root, Fri Aug 19 19:20:36 2011 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Log.pm (file contents):
Revision 1.7 by root, Thu Aug 18 18:02:11 2011 UTC vs.
Revision 1.8 by root, Fri Aug 19 19:20:36 2011 UTC