—###########################################################################
# $Id: Fork.pm,v 1.2 2002/03/18 18:11:09 wendigo Exp $
###########################################################################
#
# Log::Agent::Driver::Fork
#
# RCS Revision: $Revision: 1.2 $
# Date: $Date: 2002/03/18 18:11:09 $
#
# Copyright (C) 2002 Mark Rogaski, mrogaski@cpan.org; all rights reserved.
#
# See the README file included with the
# distribution for license information.
#
# $Log: Fork.pm,v $
# Revision 1.2 2002/03/18 18:11:09 wendigo
# Removed paranoid test for correct arguments to make()
#
# Revision 1.1 2002/03/09 15:47:14 wendigo
# Initial revision
#
#
###########################################################################
package
Log::Agent::Driver::Fork;
use
strict;
require
Log::Agent::Driver;
@ISA
=
qw(Log::Agent::Driver)
;
###########################################################################
#
# Public Methods
#
###########################################################################
#
# make
#
# constructor method
#
sub
make {
my
$class
=
shift
;
# initialize the dispatcher
my
$self
= {
drivers
=> []
};
bless
$self
,
$class
;
$self
->_init(
''
, 0);
# test for 5.6
$^W = 0;
my
$new_perl
=
eval
"$^V and $^V ge v5.6.0"
|| 0;
$^W = 1;
# process the arguments
foreach
my
$arg
(
@_
) {
if
(
ref
$arg
) {
# add to the list of drivers
push
(@{
$self
->{drivers}},
$arg
);
}
else
{
Carp::croak(
"argument is not an object reference: $arg"
);
}
}
return
$self
;
}
#
# prefix_msg
#
# does little of value
#
sub
prefix_msg {
return
$_
[1];
}
#
# write
#
# pass-through to drivers
#
sub
write
{
my
(
$self
,
$channel
,
$priority
,
$str
) =
@_
;
foreach
my
$driver
(@{
$self
->{drivers}}) {
$driver
->
write
(
$channel
,
$priority
,
$str
);
}
}
#
# emit
#
# wrapper for write() that uses dynamically bound priority() and prefix_msg()
# methods
#
sub
emit {
my
(
$self
,
$channel
,
$priority
,
$str
) =
@_
;
foreach
my
$driver
(@{
$self
->{drivers}}) {
$driver
->emit(
$channel
,
$priority
,
$str
);
# This is a kludge to make duperr work in file driver,
# the encapsulation purists should lynch me for this.
if
(
$driver
->isa(
'Log::Agent::Driver::File'
)) {
if
(
$driver
->duperr) {
if
(
$priority
eq
'critical'
) {
$driver
->emit_output(
'critical'
,
'FATAL'
,
$str
);
}
elsif
(
$priority
eq
'error'
) {
$driver
->emit_output(
'error'
,
'ERROR'
,
$str
);
}
elsif
(
$priority
eq
'warning'
) {
$driver
->emit_output(
'warning'
,
'WARNING'
,
$str
);
}
}
}
}
}
#
# emit_carp
#
# A specialized wrapper to hand-off carp/croak messages at a
# specified offset.
#
sub
emit_carp {
my
(
$self
,
$channel
,
$priority
,
$offset
,
$str
) =
@_
;
# yet another kludge
$offset
++
if
(
caller
(3))[3] =~ /^main::/;
foreach
my
$driver
(@{
$self
->{drivers}}) {
# construct the message
my
$msg
=
$driver
->carpmess(
$offset
,
$str
, \
&Carp::shortmess
);
# send it to the driver
$driver
->emit(
$channel
,
$priority
,
$str
);
}
}
#
# channel_eq
#
# exhaustive equality comparison
#
sub
channel_eq {
my
$self
=
shift
;
foreach
my
$driver
(@{
$self
->{drivers}}) {
$driver
->channel_eq(
@_
) ||
return
;
}
return
1;
}
#
# logconfess
#
# Fatal error, with stack trace
#
sub
logconfess {
my
(
$self
,
$str
) =
@_
;
# log error to all drivers
$self
->emit_carp(
'error'
,
'critical'
, 0,
$str
);
die
;
}
#
# logcroak
#
# Fatal error
#
sub
logcroak {
my
(
$self
,
$str
) =
@_
;
#
# log error to all drivers
#
$self
->emit_carp(
'error'
,
'critical'
, 0,
$str
);
die
;
}
#
# logxcroak
#
# Fatal error, from perspective of caller
#
sub
logxcroak {
my
(
$self
,
$offset
,
$str
) =
@_
;
#
# log error to all drivers
#
$self
->emit_carp(
'error'
,
'critical'
,
$offset
,
$str
);
die
;
}
#
# logdie
#
# Fatal error
#
sub
logdie {
my
(
$self
,
$str
) =
@_
;
#
# log error to all drivers
#
$self
->emit(
'error'
,
'critical'
,
$str
);
die
;
}
#
# logerr
#
# Signal error on stderr
#
sub
logerr {
my
(
$self
,
$str
) =
@_
;
#
# log error to all drivers
#
$self
->emit(
'error'
,
'error'
,
$str
);
}
#
# logwarn
#
# Warn, with "WARNING" clearly emphasized
#
sub
logwarn {
my
(
$self
,
$str
) =
@_
;
#
# log error to all drivers
#
$self
->emit(
'error'
,
'warning'
,
$str
);
}
#
# logcarp
#
# log a warning, carp-style
#
sub
logcarp {
my
(
$self
,
$str
) =
@_
;
#
# log message to all drivers
#
$self
->emit_carp(
'error'
,
'warning'
, 0,
$str
);
}
#
# logxcarp
#
# Warn from perspective of caller
#
sub
logxcarp {
my
(
$self
,
$offset
,
$str
) =
@_
;
#
# log message to all drivers
#
$self
->emit_carp(
'error'
,
'warning'
,
$offset
,
$str
);
}
#
# logsay
#
# Log message to "output" channel at "notice" priority
#
sub
logsay {
my
(
$self
,
$str
) =
@_
;
#
# send message to drivers
#
$self
->emit(
'output'
,
'notice'
,
$str
);
}
1;
# for require
__END__
=head1 NAME
Log::Agent::Driver::Fork - dummy driver for forking output to multiple drivers
=head1 SYNOPSIS
use Log::Agent;
require Log::Agent::Driver::Fork;
require Log::Agent::Driver::Foo;
require Log::Agent::Driver::Bar;
my $driver = Log::Agent::Driver::Fork->make(
Log::Agent::Driver::Foo->make( ... ),
Log::Agent::Driver::Bar->make( ... )
);
logconfig(-driver => $driver);
=head1 DESCRIPTION
This driver merely acts a multiplexer for logxxx() calls, duplicating
them and distributing them to other drivers.
The only routine of interest here is the creation routine:
=over 4
=item make(@drivers)
Create a Log::Agent::Driver::Fork driver that duplicates logxxx() calls and
distributes them to the drivers in @drivers. The arguments must be the return
value of the make() call for the client drivers.
=head1 NOTES
Many thanks go to Daniel Lundin and Jason May who proposed this module
independently. Eventually, logconfig() will support multiple drivers
directly. But, for now, this solution requires no change to the existing
interface.
=head1 AUTHOR
Mark Rogaski E<lt>mrogaski@pobox.comE<gt>
=head1 LICENSE
Copyright (C) 2002 Mark Rogaski; all rights reserved.
See L<Log::Agent(3)> or the README file included with the distribution for
license information.
=head1 SEE ALSO
L<Log::Agent::Driver(3)>, L<Log::Agent(3)>.
=cut