1###########################################################################
2#
3#   Datum.pm
4#
5#   Copyright (C) 1999 Raphael Manfredi.
6#   Copyright (C) 2002-2017 Mark Rogaski, mrogaski@cpan.org;
7#   all rights reserved.
8#
9#   See the README file included with the
10#   distribution for license information.
11#
12##########################################################################
13
14use strict;
15require Log::Agent::Driver;
16
17########################################################################
18package Log::Agent::Driver::Datum;
19
20use vars qw(@ISA);
21
22@ISA = qw(Log::Agent::Driver);
23
24#
25# ->make			-- defined
26#
27# Creation routine.
28#
29# Attributes:
30#   driver     the underlying driver originally configured
31#
32sub make {
33	my $self = bless {}, shift;
34	my ($driver) = @_;
35	$self->_init('', 0);				# 0 is the skip Carp penalty
36	$self->{driver} = $driver;
37	$driver->add_penalty(2);			# We're intercepting the calls
38	return $self;
39}
40
41#
42# Attribute access
43#
44
45sub prefix		{ $_[0]->{driver}->prefix }
46sub driver		{ $_[0]->{driver} }
47
48#
49# Cannot-be-called routines.
50#
51
52sub prefix_msg	{ require Carp; Carp::confess("prefix_msg") }
53sub emit		{ require Carp; Carp::confess("emit") }
54
55#
56# ->channel_eq		-- defined
57#
58# Redirect comparison to driver.
59#
60sub channel_eq {
61	my $self = shift;
62	my ($chan1, $chan2) = @_;
63	return $self->driver->channel_eq($chan1, $chan2);
64}
65
66#
67# ->datum_trace
68#
69# Emit a Carp::Datum trace, which will be a logwrite() on the 'debug' channel.
70#
71sub datum_trace {
72	my $self = shift;
73	my ($str, $tag) = @_;
74	require Carp::Datum;
75	Carp::Datum::trace($str, $tag);
76}
77
78#
79# intercept
80#
81# Intercept call to driver by calling ->datum_trace() first, then resume
82# regular operation on the driver, if the channel where message would go
83# is not the same as the debug channel.
84#
85sub intercept {
86	my ($aref, $tag, $op, $chan, $prepend) = @_;
87	my $self = shift @$aref;
88
89	#
90	# $aref can be [$str] or [$offset, $str]
91	#
92
93	my $pstr = $aref->[$#$aref];		# String is last argument
94	if (defined $prepend) {
95		$pstr = $pstr->clone;			# We're prepending tag on a copy
96		$pstr->prepend("$prepend: ");
97	}
98	$self->datum_trace($pstr, $tag);
99	my $driver = $self->driver;
100	if ($driver->channel_eq('debug', $chan)) {
101		die "$pstr\n" if $prepend eq 'FATAL';
102	} else {
103		$driver->$op(@$aref);
104	}
105}
106
107#
108# Interface interception.
109#
110# The string will be tagged with ">>" to make it clear it comes from Log::Agent,
111# unless it's a fatal string from logconfess/logcarp/logdie, in wich case
112# it is tagged with "**".
113#
114
115sub logconfess	{ intercept(\@_, '**', 'logconfess', 'error',	'FATAL') }
116sub logxcroak	{ intercept(\@_, '**', 'logxcroak',	 'error',	'FATAL') }
117sub logdie		{ intercept(\@_, '**', 'logdie',	 'error',	'FATAL') }
118sub logerr		{ intercept(\@_, '>>', 'logerr',	 'error',	'ERROR') }
119sub logcluck	{ intercept(\@_, '>>', 'logcluck',	 'error',	'WARNING') }
120sub logwarn		{ intercept(\@_, '>>', 'logwarn',	 'error',	'WARNING') }
121sub logxcarp	{ intercept(\@_, '>>', 'logxcarp',	 'error',	'WARNING') }
122sub logsay		{ intercept(\@_, '>>', 'logsay',	 'output') }
123sub loginfo		{ intercept(\@_, '>>', 'loginfo',	 'output') }
124sub logdebug	{ intercept(\@_, '>>', 'logdebug',	 'output') }
125
126#
127# logwrite		-- redefined
128#
129# Emit the message to the specified channel
130#
131sub logwrite {
132	my $self = shift;
133	my ($chan, $prio, $level, $str) = @_;
134
135	#
136	# Have to be careful not to recurse through ->datum_trace().
137	# Look at who is calling us (immediate caller is Log::Agent).
138	#
139
140	my $pkg = caller(1);
141	if ($pkg =~ /^Carp::Datum\b/) {
142		my $drv = $self->driver;
143		return unless defined $drv;	# Can happen during global destruct
144		$drv->logwrite($chan, $prio, $level, $str);
145		return;
146	}
147
148	#
149	# The following will recurse back to us, but the above check will
150	# cut the recursion.
151	#
152
153	intercept([$self, $str], '>>', 'logwrite', $chan);
154}
155
156__END__
157
158=head1 NAME
159
160Log::Agent::Driver::Datum - interceptor driver to cooperate with Carp::Datum
161
162=head1 SYNOPSIS
163
164NONE
165
166=head1 DESCRIPTION
167
168The purpose of the interceptor is to cooperate with Carp::Datum by emitting
169traces to the debug channel via Carp::Datum's traces facilities.
170
171This driver is automatically installed by Log::Agent when Carp::Datum is
172in use and debug was activated through it.
173
174=head1 AUTHOR
175
176Raphael Manfredi F<E<lt>Raphael_Manfredi@pobox.comE<gt>>
177
178=head1 SEE ALSO
179
180Carp::Datum(3).
181
182=cut
183