Log-Channel
view release on metacpan or search on metacpan
configured from that file (see Log::Dispatch::Config), otherwise
Log::Dispatch must be initialized explicitly
=back
=head1 METHODS
=over 4
=cut
use strict;
use vars qw($VERSION);
$VERSION = '0.7';
use Log::Dispatch;
use POSIX qw(strftime);
my %Channel;
my %Config_by_channel;
my $Configuration;
=item B<new>
my $log_coderef = new Log::Channel "topic";
Define a new channel for logging messages. All new logs default to
output to stderr. Specifying a dispatcher (see dispatch method below)
will override this behavior. Logs default active, but can be disabled.
Note that the object returned from the constructor is a coderef,
not the usual hashref. This seems to me to be an appropriate use
of closures.
The channel will remember the topic specified when it was
created, prepended by the name of the current package.
Suggested usage is
sub logme { $log_coderef->(@_) }
So that you can write logging entries like
logme "This is the message\n";
If omitted, topic will default to the name of the current package. A
channel must have something for the topic, so the parameter is required
for channels created in the main package.
=cut
sub new {
my $proto = shift;
my $class = ref ($proto) || $proto;
if (!$Configuration) {
$Configuration = new Log::Channel::Config;
}
my $package = (caller)[0];
if ($package ne "main") {
unshift @_, $package;
}
if (!$Channel{$package}) {
# make sure channel exists for the entire package
$class->_make($package);
}
return $class->_make(@_);
}
sub _make {
my $proto = shift;
my $class = ref ($proto) || $proto;
my $topic = join("::", @_);
die "Missing topic for Log::Channel->new" unless $topic;
my $existing_channel = $Channel{$topic}->{channel};
return $existing_channel if $existing_channel;
my $config = _config($topic);
my $self = _makesub($class, $config);
bless $self, __PACKAGE__;
$config->{channel} = $self;
$Channel{$topic} = $config;
$Config_by_channel{$self} = $config;
$Configuration->configure($config) if $Configuration;
return $self;
}
sub _config {
# Assumes that caller has verified that there is not an existing
# channel for this topic.
my %config;
$config{topic} = shift;
return \%config;
}
sub _makesub {
my ($class, $config) = @_;
*sym = "${class}::_transmit";
my $transmit = *sym{CODE};
return
sub {
return if $config->{disabled};
my $dispatchers = $config->{dispatchers};
if ($dispatchers) {
foreach my $dispatcher (@$dispatchers) {
$dispatcher->log(level => $config->{priority} || "info",
message => _construct($config, @_));
'carp', 'croak' and so on will be delivered according to the active
dispatch instructions. Remember, Log::Channel defaults all message
delivery to OFF.
Note that the Carp verbose setting should still work correctly.
=cut
sub commandeer {
shift if $_[0] eq __PACKAGE__;
local $^W = 0; # hide 'subroutine redefined' messages
if (!@_) {
# commandeer ALL active modules
_commandeer_package ("main");
} else {
foreach my $package (@_) {
_commandeer_package ($package);
}
}
}
sub _commandeer_package {
my ($package) = shift;
no strict 'refs';
# The subroutine-override code here was cribbed from Exporter.pm
*{"$package\::carp"} = \&{__PACKAGE__ . '::_carp'};
*{"$package\::croak"} = \&{__PACKAGE__ . '::_croak'};
# Recurse through all sub-packages and commandeer carp in each case.
# The package-detection code here was taken from Devel::Symdump.
while (my ($key,$val) = each %{*{"$package\::"}}) {
local *sym = $val;
if (defined $val
&& defined *sym{HASH}
&& $key =~ /::$/
&& $key ne "main::"
&& $key ne "<none>::") {
my $subpkg = "$package\::$key";
$subpkg =~ s/::$//;
_commandeer_package($subpkg);
}
}
}
=item B<_carp>
This is the function that is used to supersede the regular Carp::carp
whenever Carp is commandeered on a module. Note that we still use
Carp::shortmess to generate the actual text, so that if Carp verbose mode
is specified, the full verbose text will go to the log channel.
=cut
sub _carp {
my $topic = (caller)[0];
my $channel = $Channel{$topic}->{channel};
$channel = Log::Channel->_make($topic) unless $channel;
$channel->(Carp::shortmess @_);
}
=item B<_croak>
Substitute for Carp::croak. Note that in this case the message will
be output to two places - the channel, and STDERR (or whatever die() does).
=cut
sub _croak {
my $topic = (caller)[0];
my $channel = $Channel{$topic}->{channel};
$channel = Log::Channel->_make($topic) unless $channel;
$channel->(Carp::shortmess @_);
die Carp::shortmess @_;
}
=item B<decorate>
decorate Log::Channel "topic", "decoration-string";
Specify the prefix elements that will be included in each message
logged to the channel identified by "topic". The formatting options
have been modeled on the log4j system. Options include:
%t - channel topic name
%d{format} - current timestamp; defaults to 'scalar localtime', but
if an optional strftime format may be provided
%F - filename where the log message is generated from
%L - line number
%p - priority string for this channel (see set_priority)
%x - context string for this channel (see set_context)
%m - log message text
Any other textual elements will be transmitted verbatim, eg.
e.g. "%t: %m", "(%t) [%d] %m\n", etc.
Comment on performance: I haven't benchmarked the string formatting
here. s///egx might not be the fastest way to do this.
=cut
sub decorate {
shift if $_[0] eq __PACKAGE__;
my $decorator = pop;
my ($topic, $channel_config) = _topic(@_);
$channel_config->{decoration} = $decorator;
}
=item B<set_context>
set_context Log::Channel "topic", $context;
Associate some information (a string) with a log channel, specified
by topic. This string will be included in log messages if the 'context'
decoration is activated.
This is intended for when messages should include reference info that
changes from call to call, such as a current session id, user id,
transaction code, etc.
=cut
sub set_context {
shift if $_[0] eq __PACKAGE__;
my $context = pop;
Currently does nothing.
=cut
sub status {
return \%Channel;
}
# _recurse
#
# Call the specified function on the name of every sub-package
# in this package. Used to recursively apply constraints to
# sub-packages (disable, enable, commandeer).
#
sub _recurse {
my $package = shift;
my $coderef = shift;
foreach my $topic (keys %Channel) {
if ($topic =~ /^$package\::/) {
$coderef->($topic, @_);
}
}
}
sub _topic {
my ($topic, $channel_config);
if (ref $_[0] eq __PACKAGE__) {
# invoked as $channel->disable
$channel_config = $Config_by_channel{$_[0]};
$topic = $channel_config->{topic};
} else {
$topic = join("::", @_);
die "Missing topic for Log::Channel->disable" unless $topic;
$channel_config = $Channel{$topic};
if (!$channel_config) {
Log::Channel->_make($topic);
$channel_config = $Channel{$topic};
}
}
return ($topic, $channel_config);
}
=item B<export>
$channel->export("subname");
Exports a logging subroutine into the calling package's namespace.
Does the same thing as
sub mylog { $channel->(@_) }
=cut
sub export {
my ($channel, $subname) = @_;
my $package = (caller)[0];
no strict 'refs';
*{"$package\::$subname"} = sub { $channel->(@_) };
}
1;
=back
=head1 TO DO
=over 4
=item *
Syntax-checking on decorator format strings.
=item *
Status reporting available for what log classes have been initiated,
activation status, and where the messages are going.
=item *
Ability to commandeer "print STDERR". To pick up other types of module
logging - and capture die() messages.
=back
=head1 AUTHOR
Jason W. May <jmay@pobox.com>
=head1 COPYRIGHT
Copyright (C) 2001,2002 Jason W. May. All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
Log::Dispatch and Log::Dispatch::Config
http://jakarta.apache.org/log4j
And many other logging modules:
Log::Agent
CGI::Log
Log::Common
Log::ErrLogger
Log::Info
Log::LogLite
Log::Topics
Log::TraceMessages
Pat::Logger
POE::Component::Logger
Tie::Log
Tie::Syslog
Logfile::Rotate
Net::Peep::Log
( run in 1.685 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )