1package Log::Dispatch::Output;
2{
3  $Log::Dispatch::Output::VERSION = '2.34';
4}
5
6use strict;
7use warnings;
8
9use Log::Dispatch;
10
11use base qw( Log::Dispatch::Base );
12
13use Params::Validate qw(validate SCALAR ARRAYREF CODEREF BOOLEAN);
14Params::Validate::validation_options( allow_extra => 1 );
15
16use Carp ();
17
18my $level_names
19    = [qw( debug info notice warning error critical alert emergency )];
20my $ln            = 0;
21my $level_numbers = {
22    ( map { $_ => $ln++ } @{$level_names} ),
23    warn  => 3,
24    err   => 4,
25    crit  => 5,
26    emerg => 7
27};
28
29sub new {
30    my $proto = shift;
31    my $class = ref $proto || $proto;
32
33    die "The new method must be overridden in the $class subclass";
34}
35
36sub log {
37    my $self = shift;
38
39    my %p = validate(
40        @_, {
41            level   => { type => SCALAR },
42            message => { type => SCALAR },
43        }
44    );
45
46    return unless $self->_should_log( $p{level} );
47
48    $p{message} = $self->_apply_callbacks(%p)
49        if $self->{callbacks};
50
51    $self->log_message(%p);
52}
53
54sub _basic_init {
55    my $self = shift;
56
57    my %p = validate(
58        @_, {
59            name      => { type => SCALAR, optional => 1 },
60            min_level => { type => SCALAR, required => 1 },
61            max_level => {
62                type     => SCALAR,
63                optional => 1
64            },
65            callbacks => {
66                type     => ARRAYREF | CODEREF,
67                optional => 1
68            },
69            newline => { type => BOOLEAN, optional => 1 },
70        }
71    );
72
73    $self->{level_names}   = $level_names;
74    $self->{level_numbers} = $level_numbers;
75
76    $self->{name} = $p{name} || $self->_unique_name();
77
78    $self->{min_level} = $self->_level_as_number( $p{min_level} );
79    die "Invalid level specified for min_level"
80        unless defined $self->{min_level};
81
82    # Either use the parameter supplied or just the highest possible level.
83    $self->{max_level} = (
84        exists $p{max_level}
85        ? $self->_level_as_number( $p{max_level} )
86        : $#{ $self->{level_names} }
87    );
88
89    die "Invalid level specified for max_level"
90        unless defined $self->{max_level};
91
92    my @cb = $self->_get_callbacks(%p);
93    $self->{callbacks} = \@cb if @cb;
94
95    if ( $p{newline} ) {
96        push @{ $self->{callbacks} }, \&_add_newline_callback;
97    }
98}
99
100sub name {
101    my $self = shift;
102
103    return $self->{name};
104}
105
106sub min_level {
107    my $self = shift;
108
109    return $self->{level_names}[ $self->{min_level} ];
110}
111
112sub max_level {
113    my $self = shift;
114
115    return $self->{level_names}[ $self->{max_level} ];
116}
117
118sub accepted_levels {
119    my $self = shift;
120
121    return @{ $self->{level_names} }
122        [ $self->{min_level} .. $self->{max_level} ];
123}
124
125sub _should_log {
126    my $self = shift;
127
128    my $msg_level = $self->_level_as_number(shift);
129    return (   ( $msg_level >= $self->{min_level} )
130            && ( $msg_level <= $self->{max_level} ) );
131}
132
133sub _level_as_number {
134    my $self  = shift;
135    my $level = shift;
136
137    unless ( defined $level ) {
138        Carp::croak "undefined value provided for log level";
139    }
140
141    return $level if $level =~ /^\d$/;
142
143    unless ( Log::Dispatch->level_is_valid($level) ) {
144        Carp::croak "$level is not a valid Log::Dispatch log level";
145    }
146
147    return $self->{level_numbers}{$level};
148}
149
150sub _level_as_name {
151    my $self  = shift;
152    my $level = shift;
153
154    unless ( defined $level ) {
155        Carp::croak "undefined value provided for log level";
156    }
157
158    return $level unless $level =~ /^\d$/;
159
160    return $self->{level_names}[$level];
161}
162
163my $_unique_name_counter = 0;
164
165sub _unique_name {
166    my $self = shift;
167
168    return '_anon_' . $_unique_name_counter++;
169}
170
171sub _add_newline_callback {
172    my %p = @_;
173
174    return $p{message} . "\n";
175}
176
1771;
178
179# ABSTRACT: Base class for all Log::Dispatch::* objects
180
181__END__
182
183=pod
184
185=head1 NAME
186
187Log::Dispatch::Output - Base class for all Log::Dispatch::* objects
188
189=head1 VERSION
190
191version 2.34
192
193=head1 SYNOPSIS
194
195  package Log::Dispatch::MySubclass;
196
197  use Log::Dispatch::Output;
198  use base qw( Log::Dispatch::Output );
199
200  sub new {
201      my $proto = shift;
202      my $class = ref $proto || $proto;
203
204      my %p = @_;
205
206      my $self = bless {}, $class;
207
208      $self->_basic_init(%p);
209
210      # Do more if you like
211
212      return $self;
213  }
214
215  sub log_message {
216      my $self = shift;
217      my %p    = @_;
218
219      # Do something with message in $p{message}
220  }
221
222  1;
223
224=head1 DESCRIPTION
225
226This module is the base class from which all Log::Dispatch::* objects
227should be derived.
228
229=head1 CONSTRUCTOR
230
231The constructor, C<new>, must be overridden in a subclass. See L<Output
232Classes|Log::Dispatch/OUTPUT CLASSES> for a description of the common
233parameters accepted by this constructor.
234
235=head1 METHODS
236
237=over 4
238
239=item * _basic_init(%p)
240
241This should be called from a subclass's constructor.  Make sure to
242pass the arguments in @_ to it.  It sets the object's name and minimum
243level.  It also sets up two other attributes which are used by other
244Log::Dispatch::Output methods, level_names and level_numbers.
245
246=item * name
247
248Returns the object's name.
249
250=item * min_level
251
252Returns the object's minimum log level.
253
254=item * max_level
255
256Returns the object's maximum log level.
257
258=item * accepted_levels
259
260Returns a list of the object's accepted levels (by name) from minimum
261to maximum.
262
263=item * log( level => $, message => $ )
264
265Sends a message if the level is greater than or equal to the object's
266minimum level.  This method applies any message formatting callbacks
267that the object may have.
268
269=item * _should_log ($)
270
271This method is called from the C<log()> method with the log level of
272the message to be logged as an argument.  It returns a boolean value
273indicating whether or not the message should be logged by this
274particular object.  The C<log()> method will not process the message
275if the return value is false.
276
277=item * _level_as_number ($)
278
279This method will take a log level as a string (or a number) and return
280the number of that log level.  If not given an argument, it returns
281the calling object's log level instead.  If it cannot determine the
282level then it will croak.
283
284=item * add_callback( $code )
285
286Adds a callback (like those given during construction). It is added to the end
287of the list of callbacks.
288
289=back
290
291=head2 Subclassing
292
293This class should be used as the base class for all logging objects
294you create that you would like to work under the Log::Dispatch
295architecture.  Subclassing is fairly trivial.  For most subclasses, if
296you simply copy the code in the SYNOPSIS and then put some
297functionality into the C<log_message> method then you should be all
298set.  Please make sure to use the C<_basic_init> method as directed.
299
300The actual logging implementation should be done in a C<log_message>
301method that you write. B<Do not override C<log>!>.
302
303=head1 AUTHOR
304
305Dave Rolsky <autarch@urth.org>
306
307=head1 COPYRIGHT AND LICENSE
308
309This software is Copyright (c) 2011 by Dave Rolsky.
310
311This is free software, licensed under:
312
313  The Artistic License 2.0 (GPL Compatible)
314
315=cut
316