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