| File: | blib/lib/Log/Abstraction.pm | 
| Coverage: | 61.4% | 
| line | stmt | bran | cond | sub | time | code | 
|---|---|---|---|---|---|---|
| 1 | package Log::Abstraction; | |||||
| 2 | ||||||
| 3 | # TODO: add a minimum logging level | |||||
| 4 | ||||||
| 5 | 7 7 7  | 553940 4 90  | use strict; | |||
| 6 | 7 7 7  | 13 0 107  | use warnings; | |||
| 7 | 7 7 7  | 14 6 180  | use Carp; # Import Carp for warnings | |||
| 8 | 7 7 7  | 1462 173807 99  | use Config::Abstraction 0.36; | |||
| 9 | 7 7 7  | 16 5 146  | use Data::Dumper; | |||
| 10 | 7 7 7  | 12 29 88  | use Params::Get 0.13; # Import Params::Get for parameter handling | |||
| 11 | 7 7 7  | 10 8 15  | use POSIX qw(strftime); | |||
| 12 | 7 7 7  | 1649 28207 409  | use Readonly::Values::Syslog 0.03; | |||
| 13 | 7 7 7  | 1023 1515 133  | use Return::Set; | |||
| 14 | 7 7 7  | 14 5 115  | use Scalar::Util 'blessed'; # Import Scalar::Util for object reference checking | |||
| 15 | 7 7 7  | 1242 25521 10736  | use Sys::Syslog 0.28; # Import Sys::Syslog for syslog support | |||
| 16 | ||||||
| 17 | =encoding utf-8 | |||||
| 18 | ||||||
| 19 - 27 | =head1 NAME Log::Abstraction - Logging Abstraction Layer =head1 VERSION 0.26 =cut  | |||||
| 28 | ||||||
| 29 | our $VERSION = 0.26; | |||||
| 30 | ||||||
| 31 - 184 | =head1 SYNOPSIS
  use Log::Abstraction;
  my $logger = Log::Abstraction->new(logger => 'logfile.log');
  $logger->debug('This is a debug message');
  $logger->info('This is an info message');
  $logger->notice('This is a notice message');
  $logger->trace('This is a trace message');
  $logger->warn({ warning => 'This is a warning message' });
=head1 DESCRIPTION
The C<Log::Abstraction> class provides a flexible logging layer on top of different types of loggers,
including code references, arrays, file paths, and objects.
It also supports logging to syslog if configured.
=head1 METHODS
=head2 new
    my $logger = Log::Abstraction->new(%args);
Creates a new C<Log::Abstraction> object.
The argument can be a hash,
a reference to a hash or the C<logger> value.
The following arguments can be provided:
=over
=item * C<carp_on_warn>
If set to 1,
and C<logger> is not given,
call C<Carp:carp> on C<warn()>.
Causes C<error()> to C<carp> if C<croak_on_error> is not given.
=item * C<croak_on_error>
If set to 1,
and C<logger> is not given,
call C<Carp:croak> on C<error()>.
=item * C<config_file>
Points to a configuration file which contains the parameters to C<new()>.
The file can be in any common format,
including C<YAML>, C<XML>, and C<INI>.
This allows the parameters to be set at run time.
On a non-Windows system,
the class can be configured using environment variables starting with C<"Log::Abstraction::">.
For example:
  export Log::Abstraction::script_name=foo
It doesn't work on Windows because of the case-insensitive nature of that system.
=item * C<level>
The minimum level at which to log something,
the default is "warning".
=item * C<logger>
A logger can be one or more of:
=over
=item * a code reference
The code will be called with a hashref containing:
=over
=item * class
=item * file
=item * line
=item * level
=item * message - an arrayref of messages
=back
=item * an object
=item * a hash of options
=item * sendmail - send higher priority messages to an email address
To send an e-mail,
you need L<require Email::Simple>, L<require Email::Sender::Simple> and L<Email::Sender::Transport::SMTP>.
=item * array - a reference to an array
=item * fd - containing a file descriptor to log to
=item * file - containing the filename
=back
Defaults to L<Log::Log4perl>.
In that case,
the argument 'verbose' to new() will raise the logging level.
=item * C<format>
The format of the message.
Expands:
=over
=item * %callstack%
=item * %level%
=item * %class%
=item * %message%
=item * %timestamp%
=%item * %env_foo%
Replaces with C<$ENV{foo}>
=back
=item * C<syslog>
A hash reference for syslog configuration.
Only warnings and above will be sent to syslog.
This restriction should be lifted in the future,
since it's reasonable to send notices and above to the syslog.
=item * C<script_name>
The name of the script.
It's needed when C<syslog> is given,
if none is passed, the value is guessed.
=back
Clone existing objects with or without modifications:
    my $clone = $logger->new();
=cut | |||||
| 185 | ||||||
| 186 | sub new { | |||||
| 187 | 22  | 375755  | my $class = shift; | |||
| 188 | ||||||
| 189 | # Handle hash or hashref arguments | |||||
| 190 | 22  | 14  | my %args; | |||
| 191 | ||||||
| 192 | 22  | 64  | if((scalar(@_) == 1) && (ref($_[0]) ne 'HASH')) { | |||
| 193 | 1  | 1  | $args{'logger'} = shift; | |||
| 194 | } elsif(my $params = Params::Get::get_params(undef, @_)) { | |||||
| 195 | 16 16  | 203 21  | %args = %{$params}; | |||
| 196 | } | |||||
| 197 | ||||||
| 198 | # Load the configuration from a config file, if provided | |||||
| 199 | 22  | 71  | if(exists($args{'config_file'})) { | |||
| 200 | # my $config = YAML::XS::LoadFile($params->{'config_file'}); | |||||
| 201 | 4  | 18  | if(!-r $args{'config_file'}) { | |||
| 202 | 1  | 21  | croak("$class: ", $args{'config_file'}, ': File not readable'); | |||
| 203 | } | |||||
| 204 | 3  | 9  | if(my $config = Config::Abstraction->new(config_dirs => [''], config_file => $args{'config_file'}, env_prefix => "${class}::")) { | |||
| 205 | 3  | 2523  | $config = $config->all(); | |||
| 206 | 3  | 10  | if($config->{$class}) { | |||
| 207 | 2  | 4  | $config = $config->{$class}; | |||
| 208 | } | |||||
| 209 | 3  | 3  | my $array = $args{'array'}; | |||
| 210 | 3 3  | 2 5  | %args = (%{$config}, %args); | |||
| 211 | 3  | 3  | if($array) { | |||
| 212 | 0  | 0  | $args{'array'} = $array; | |||
| 213 | } | |||||
| 214 | } else { | |||||
| 215 | 0  | 0  | croak("$class: Can't load configuration from ", $args{'config_file'}); | |||
| 216 | } | |||||
| 217 | } | |||||
| 218 | ||||||
| 219 | 21  | 40  | if(!defined($class)) { | |||
| 220 | 1  | 2  | if((scalar keys %args) > 0) { | |||
| 221 | # Using Log::Abstraction:new(), not Log::Abstraction->new() | |||||
| 222 | 0  | 0  | carp(__PACKAGE__, ' use ->new() not ::new() to instantiate'); | |||
| 223 | 0  | 0  | return; | |||
| 224 | } | |||||
| 225 | ||||||
| 226 | # FIXME: this only works when no arguments are given | |||||
| 227 | 1  | 1  | $class = __PACKAGE__; | |||
| 228 | } elsif(Scalar::Util::blessed($class)) { | |||||
| 229 | # If $class is an object, clone it with new arguments | |||||
| 230 | 2 2  | 1 4  | my $clone = bless { %{$class}, %args }, ref($class); | |||
| 231 | 2 2  | 3 2  | $clone->{messages} = [ @{$class->{messages}} ]; # Deep copy | |||
| 232 | 2  | 3  | return $clone; | |||
| 233 | } | |||||
| 234 | ||||||
| 235 | 19  | 57  | if($args{'syslog'} && !$args{'script_name'}) { | |||
| 236 | 1  | 6  | require File::Basename && File::Basename->import() unless File::Basename->can('basename'); | |||
| 237 | ||||||
| 238 | # Determine script name | |||||
| 239 | 1  | 32  | $args{'script_name'} = File::Basename::basename($ENV{'SCRIPT_NAME'} || $0); | |||
| 240 | ||||||
| 241 | 1  | 6  | croak("$class: syslog needs to know the script name") if(!defined($args{'script_name'})); | |||
| 242 | } | |||||
| 243 | ||||||
| 244 | 19  | 13  | my $level = $args{'level'}; | |||
| 245 | 19  | 37  | if(defined(my $logger = $args{logger})) { | |||
| 246 | 9  | 13  | if(Scalar::Util::blessed($logger) && (ref($logger) eq __PACKAGE__)) { | |||
| 247 | 0  | 0  | croak("$class: attempt to encapulate ", __PACKAGE__, ' as a logging class, that would add a needless indirection'); | |||
| 248 | } | |||||
| 249 | } elsif((!$args{'file'}) && (!$args{'array'})) { | |||||
| 250 | # Default to Log4perl | |||||
| 251 | 10  | 1497  | require Log::Log4perl; | |||
| 252 | 10  | 73365  | Log::Log4perl->import(); | |||
| 253 | ||||||
| 254 | # FIXME: add default minimum logging level | |||||
| 255 | 10  | 131  | Log::Log4perl->easy_init($args{verbose} ? $Log::Log4perl::DEBUG : $Log::Log4perl::ERROR); | |||
| 256 | 10  | 9343  | $args{'logger'} = Log::Log4perl->get_logger(); | |||
| 257 | } | |||||
| 258 | ||||||
| 259 | 19  | 786  | if($level) { | |||
| 260 | 7  | 9  | if(ref($level) eq 'ARRAY') { | |||
| 261 | 0  | 0  | $level = $level->[0]; | |||
| 262 | } | |||||
| 263 | 7  | 8  | $level = lc($level); | |||
| 264 | 7  | 8  | if(!defined($syslog_values{$level})) { | |||
| 265 | 0  | 0  | Carp::croak("$class: invalid syslog level '$level'"); | |||
| 266 | } | |||||
| 267 | 7  | 7  | $args{'level'} = $level; | |||
| 268 | } else { | |||||
| 269 | # The default minimum level at which to log something is 'warning' | |||||
| 270 | 12  | 11  | $args{'level'} = 'warning'; | |||
| 271 | } | |||||
| 272 | ||||||
| 273 | # Bless and return the object | |||||
| 274 | return bless { | |||||
| 275 | messages => [], # Initialize messages array | |||||
| 276 | %args, | |||||
| 277 | 19  | 70  | level => $syslog_values{$args{'level'}}, | |||
| 278 | }, $class; | |||||
| 279 | } | |||||
| 280 | ||||||
| 281 - 323 | =head2 _sanitize_email_header my $clean_value = _sanitize_email_header($raw_value); Internal routine to remove carriage return and line feed characters from an email header value to prevent header injection or formatting issues. =over 4 =item * Input Takes a single scalar value, typically a string representing an email header field. =item * Behavior If the input is undefined, returns `undef`. Otherwise, removes all newline characters (`\n`), carriage returns (`\r`), and CRLF pairs from the string. =item * Output Returns the sanitized string with CR/LF characters removed. =back =head3 FORMAL SPECIFICATION If the input is undefined (â ), the output is also undefined (â ). If the input is defined, the result is a defined string with CR and LF characters removed. [CHAR] CR, LF : CHAR CR == '\r' LF == '\n' STRING == seq CHAR SanitizeEmailHeader raw?: STRING sanitized!: STRING ------------------------------------------------- sanitized! = [ c : raw? | c â CR â§ c â LF ] =cut  | |||||
| 324 | ||||||
| 325 | sub _sanitize_email_header { | |||||
| 326 | 0  | 0  | my $value = $_[0]; | |||
| 327 | ||||||
| 328 | 0  | 0  | return unless defined $value; | |||
| 329 | 0  | 0  | $value =~ s/\r\n?|\n//g; # Remove CR/LF characters | |||
| 330 | ||||||
| 331 | 0  | 0  | return Return::Set::set_return($value, { type => 'string', 'matches' => qr /^[^\r\n]*$/ }); | |||
| 332 | } | |||||
| 333 | ||||||
| 334 | # Internal method to log messages. This method is called by other logging methods. | |||||
| 335 | # $logger->_log($level, @messages); | |||||
| 336 | # $logger->_log($level, \@messages); | |||||
| 337 | ||||||
| 338 | sub _log { | |||||
| 339 | 23  | 45  | my ($self, $level, @messages) = @_; | |||
| 340 | ||||||
| 341 | 23  | 25  | if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) { | |||
| 342 | 1  | 25  | Carp::croak('Illegal Operation: _log is a private method'); | |||
| 343 | } | |||||
| 344 | ||||||
| 345 | 22  | 183  | if(!defined($syslog_values{$level})) { | |||
| 346 | 0  | 0  | Carp::Croak(ref($self), ": Invalid level '$level'"); # "Can't happen" | |||
| 347 | } | |||||
| 348 | ||||||
| 349 | 22  | 26  | if($syslog_values{$level} > $self->{'level'}) { | |||
| 350 | # The level is too low to log | |||||
| 351 | 3  | 3  | return; | |||
| 352 | } | |||||
| 353 | ||||||
| 354 | 19  | 30  | if((scalar(@messages) == 1) && (ref($messages[0]) eq 'ARRAY')) { | |||
| 355 | # Passed a reference to an array | |||||
| 356 | 0 0  | 0 0  | @messages = @{$messages[0]}; | |||
| 357 | } | |||||
| 358 | 19  | 25  | @messages = grep defined, @messages; | |||
| 359 | ||||||
| 360 | 19  | 17  | my $str = join('', @messages); | |||
| 361 | 19  | 15  | chomp($str); | |||
| 362 | ||||||
| 363 | # Push the message to the internal messages array | |||||
| 364 | 19 19  | 12 21  | push @{$self->{messages}}, { level => $level, message => $str }; | |||
| 365 | ||||||
| 366 | 19  | 27  | my $class = blessed($self) || $self; | |||
| 367 | 19  | 18  | if($class eq __PACKAGE__) { | |||
| 368 | 18  | 14  | $class = ''; | |||
| 369 | } | |||||
| 370 | ||||||
| 371 | 19  | 287  | my $timestamp = strftime "%Y-%m-%d %H:%M:%S", localtime; | |||
| 372 | ||||||
| 373 | 19  | 25  | if(my $logger = $self->{'logger'}) { | |||
| 374 | 19  | 35  | if(ref($logger) eq 'CODE') { | |||
| 375 | # If logger is a code reference, call it with log details | |||||
| 376 | 3  | 8  | $logger->({ | |||
| 377 | class => blessed($self) || __PACKAGE__, | |||||
| 378 | file => (caller(1))[1], | |||||
| 379 | # function => (caller(1))[3], | |||||
| 380 | line => (caller(1))[2], | |||||
| 381 | level => $level, | |||||
| 382 | message => \@messages, | |||||
| 383 | }); | |||||
| 384 | } elsif(ref($logger) eq 'ARRAY') { | |||||
| 385 | # If logger is an array reference, push the log message to the array | |||||
| 386 | 7 7  | 3 7  | push @{$logger}, { level => $level, message => $str }; | |||
| 387 | } elsif(ref($logger) eq 'HASH') { | |||||
| 388 | 3  | 4  | if(my $file = $logger->{'file'}) { | |||
| 389 | # if($file =~ /^([-\@\w.\/\\]+)$/) { | |||||
| 390 | 2  | 23  | if($file =~ /^([^<>|*?;!`$"\0-\037]+)$/) { | |||
| 391 | 2  | 2  | $file = $1; # Will untaint | |||
| 392 | } else { | |||||
| 393 | 0  | 0  | Carp::croak(ref($self), ": Invalid file name: $file"); | |||
| 394 | } | |||||
| 395 | 2  | 21  | if(open(my $fout, '>>', $logger->{'file'})) { | |||
| 396 | 2  | 2  | my $format = $self->{'format'} || '%level%> [%timestamp%] %class% %callstack% %message%'; | |||
| 397 | 2  | 3  | my $ulevel = uc($level); | |||
| 398 | 2  | 3  | my $callstack = (caller(1))[1] . ' ' . (caller(1))[2]; | |||
| 399 | ||||||
| 400 | 2  | 26  | $format =~ s/%level%/$ulevel/g; | |||
| 401 | 2  | 1  | $format =~ s/%class%/$class/g; | |||
| 402 | 2  | 3  | $format =~ s/%message%/$str/g; | |||
| 403 | 2  | 0  | $format =~ s/%callstack%/$callstack/g; | |||
| 404 | 2  | 2  | $format =~ s/%timestamp%/$timestamp/g; | |||
| 405 | 2  | 1  | $format =~ s/%env_(\w+)%/$ENV{$1}/g; | |||
| 406 | 2  | 9  | print $fout "$format\n" or Carp::croak(ref($self), ": Can't write to $file: $!"); | |||
| 407 | 2  | 24  | close $fout; | |||
| 408 | } | |||||
| 409 | } | |||||
| 410 | 3  | 4  | if(my $array = $logger->{'array'}) { | |||
| 411 | 0 0  | 0 0  | push @{$array}, { level => $level, message => $str }; | |||
| 412 | } | |||||
| 413 | 3  | 8  | if($logger->{'sendmail'}->{'to'}) { | |||
| 414 | # Send an email | |||||
| 415 | # TODO: throttle the number of emails | |||||
| 416 | 0  | 0  | if((!defined($logger->{'sendmail'}->{'level'})) || | |||
| 417 | ($syslog_values{$level} <= $syslog_values{$logger->{'sendmail'}->{'level'}})) { | |||||
| 418 | 0  | 0  | eval { | |||
| 419 | 0  | 0  | require Email::Simple; | |||
| 420 | 0  | 0  | require Email::Sender::Simple; | |||
| 421 | 0  | 0  | require Email::Sender::Transport::SMTP; | |||
| 422 | ||||||
| 423 | 0  | 0  | Email::Simple->import(); | |||
| 424 | 0  | 0  | Email::Sender::Simple->import('sendmail'); | |||
| 425 | 0  | 0  | Email::Sender::Transport::SMTP->import(); | |||
| 426 | ||||||
| 427 | 0  | 0  | my $email = Email::Simple->new(''); | |||
| 428 | 0  | 0  | $email->header_set('to', _sanitize_email_header($logger->{'sendmail'}->{'to'})); | |||
| 429 | 0  | 0  | if(my $from = $logger->{'sendmail'}->{'from'}) { | |||
| 430 | 0  | 0  | $email->header_set('from', _sanitize_email_header($from)); | |||
| 431 | } else { | |||||
| 432 | 0  | 0  | $email->header_set('from', 'noreply@localhost'); | |||
| 433 | } | |||||
| 434 | 0  | 0  | if(my $subject = $logger->{'sendmail'}->{'subject'}) { | |||
| 435 | 0  | 0  | $email->header_set('subject', _sanitize_email_header($subject)); | |||
| 436 | } | |||||
| 437 | 0  | 0  | $email->body_set(join(' ', @messages)); | |||
| 438 | ||||||
| 439 | # Configure SMTP transport (adjust for your SMTP server) | |||||
| 440 | my $transport = Email::Sender::Transport::SMTP->new({ | |||||
| 441 | host => $logger->{'sendmail'}->{'host'} || 'localhost', | |||||
| 442 | 0  | 0  | port => $logger->{'sendmail'}->{'port'} || 25 | |||
| 443 | }); | |||||
| 444 | ||||||
| 445 | 0  | 0  | sendmail($email, { transport => $transport }); | |||
| 446 | }; | |||||
| 447 | ||||||
| 448 | 0  | 0  | if ($@) { | |||
| 449 | 0  | 0  | Carp::carp("Failed to send email: $@"); | |||
| 450 | 0  | 0  | return; | |||
| 451 | } | |||||
| 452 | } | |||||
| 453 | } | |||||
| 454 | 3  | 3  | if(my $syslog = $logger->{'syslog'}) { | |||
| 455 | 1  | 3  | if((!defined($syslog->{'level'})) || ($syslog_values{$level} <= $syslog->{'level'})) { | |||
| 456 | 1  | 2  | if(!$self->{_syslog_opened}) { | |||
| 457 | # Open persistent syslog connection | |||||
| 458 | 1  | 2  | my $facility = delete $syslog->{'facility'} || 'local0'; | |||
| 459 | 1  | 1  | my $min_level = delete $syslog->{'level'}; | |||
| 460 | # CHI uses server, Sys::Syslog uses host :-( | |||||
| 461 | 1  | 1  | if($syslog->{'server'}) { | |||
| 462 | 0  | 0  | $syslog->{'host'} = delete $syslog->{'server'}; | |||
| 463 | } | |||||
| 464 | 1 1  | 0 2  | Sys::Syslog::setlogsock($syslog) if(scalar keys %{$syslog}); | |||
| 465 | 1  | 1  | $syslog->{'facility'} = $facility; | |||
| 466 | 1  | 0  | $syslog->{'level'} = $min_level; | |||
| 467 | ||||||
| 468 | 1  | 2  | openlog($self->{script_name}, 'cons,pid', 'user'); | |||
| 469 | 1  | 44  | $self->{_syslog_opened} = 1; # Flag to track active connection | |||
| 470 | } | |||||
| 471 | ||||||
| 472 | # Handle syslog-based logging | |||||
| 473 | 1  | 1  | eval { | |||
| 474 | 1  | 1  | my $priority = ($level eq 'error') ? 'err' : 'warning'; | |||
| 475 | 1  | 1  | my $facility = $syslog->{'facility'}; | |||
| 476 | 1  | 2  | Sys::Syslog::syslog("$priority|$facility", join(' ', @messages)); | |||
| 477 | }; | |||||
| 478 | 1  | 333  | if($@) { | |||
| 479 | 0  | 0  | my $err = $@; | |||
| 480 | 0  | 0  | $err .= ":\n" . Data::Dumper->new([$syslog])->Dump(); | |||
| 481 | 0  | 0  | Carp::carp($err); | |||
| 482 | } | |||||
| 483 | } | |||||
| 484 | } | |||||
| 485 | ||||||
| 486 | 3  | 9  | if(my $fout = $logger->{'fd'}) { | |||
| 487 | 0  | 0  | my $format = $self->{'format'} || '%level%> [%timestamp%] %class% %callstack% %message%'; | |||
| 488 | 0  | 0  | my $ulevel = uc($level); | |||
| 489 | 0  | 0  | my $callstack = (caller(1))[1] . ' ' . (caller(1))[2]; | |||
| 490 | ||||||
| 491 | 0  | 0  | $format =~ s/%level%/$ulevel/g; | |||
| 492 | 0  | 0  | $format =~ s/%class%/$class/g; | |||
| 493 | 0  | 0  | $format =~ s/%message%/$str/g; | |||
| 494 | 0  | 0  | $format =~ s/%callstack%/$callstack/g; | |||
| 495 | 0  | 0  | $format =~ s/%timestamp%/$timestamp/g; | |||
| 496 | 0  | 0  | $format =~ s/%env_(\w+)%/$ENV{$1}/g; | |||
| 497 | ||||||
| 498 | 0  | 0  | print $fout "$format\n" or Carp::croak(ref($self), ": Can't write to file descriptor: $!"); | |||
| 499 | } elsif((!$logger->{'file'}) && (!$logger->{'syslog'}) && (!$logger->{'sendmail'})) { | |||||
| 500 | 0  | 0  | croak(ref($self), ": Don't know how to deal with the $level message"); | |||
| 501 | } | |||||
| 502 | } elsif(!ref($logger)) { | |||||
| 503 | # If logger is a file path, append the log message to the file | |||||
| 504 | 2  | 20  | if(open(my $fout, '>>', $logger)) { | |||
| 505 | 2  | 3  | my $format = $self->{'format'} || '%level%> [%timestamp%] %class% %callstack% %message%'; | |||
| 506 | 2  | 2  | my $ulevel = uc($level); | |||
| 507 | 2  | 2  | my $callstack = (caller(1))[1] . ' ' . (caller(1))[2]; | |||
| 508 | ||||||
| 509 | 2  | 25  | $format =~ s/%level%/$ulevel/g; | |||
| 510 | 2  | 2  | $format =~ s/%class%/$class/g; | |||
| 511 | 2  | 3  | $format =~ s/%message%/$str/g; | |||
| 512 | 2  | 2  | $format =~ s/%callstack%/$callstack/g; | |||
| 513 | 2  | 2  | $format =~ s/%timestamp%/$timestamp/g; | |||
| 514 | 2  | 2  | $format =~ s/%env_(\w+)%/$ENV{$1}/g; | |||
| 515 | ||||||
| 516 | 2  | 6  | print $fout "$format\n" or Carp::croak(ref($self), ": Can't write to $logger: $!"); | |||
| 517 | 2  | 29  | close $fout; | |||
| 518 | } | |||||
| 519 | } elsif(Scalar::Util::blessed($logger)) { | |||||
| 520 | # If logger is an object, call the appropriate method on the object | |||||
| 521 | 4  | 10  | if(!$logger->can($level)) { | |||
| 522 | 0  | 0  | if(($level eq 'notice') && $logger->can('info')) { | |||
| 523 | # Map notice to info for Log::Log4perl | |||||
| 524 | 0  | 0  | $level = 'info'; | |||
| 525 | } else { | |||||
| 526 | 0  | 0  | croak(ref($self), ': ', ref($logger), " doesn't know how to deal with the $level message"); | |||
| 527 | } | |||||
| 528 | } | |||||
| 529 | 4  | 6  | $logger->$level(@messages); | |||
| 530 | } else { | |||||
| 531 | 0  | 0  | croak(ref($self), ": configuration error, no handler written for the $level message"); | |||
| 532 | } | |||||
| 533 | } elsif($self->{'array'}) { | |||||
| 534 | 0 0  | 0 0  | push @{$self->{'array'}}, { level => $level, message => $str }; | |||
| 535 | } | |||||
| 536 | ||||||
| 537 | 19  | 1050  | if($self->{'file'}) { | |||
| 538 | 0  | 0  | my $file = $self->{'file'}; | |||
| 539 | ||||||
| 540 | # Untaint the file name | |||||
| 541 | # if($file =~ /^([-\@\w.\/\\]+)$/) { | |||||
| 542 | 0  | 0  | if($file =~ /^([^<>|*?;!`$"\0-\037]+)$/) { | |||
| 543 | 0  | 0  | $file = $1; # untainted version | |||
| 544 | } else { | |||||
| 545 | 0  | 0  | croak(ref($self), ": Tainted or unsafe filename: $file"); | |||
| 546 | } | |||||
| 547 | ||||||
| 548 | 0  | 0  | if(open(my $fout, '>>', $file)) { | |||
| 549 | 0  | 0  | my $ulevel = uc($level); | |||
| 550 | 0  | 0  | my $callstack = (caller(1))[1] . ' ' . (caller(1))[2]; | |||
| 551 | 0  | 0  | my $format; | |||
| 552 | ||||||
| 553 | 0  | 0  | if(blessed($self) eq __PACKAGE__) { | |||
| 554 | 0  | 0  | $format = $self->{'format'} || '%level%> [%timestamp%] %callstack% %message%'; | |||
| 555 | } else { | |||||
| 556 | 0  | 0  | $format = $self->{'format'} || '%level%> [%timestamp%] %class% %callstack% %message%'; | |||
| 557 | } | |||||
| 558 | ||||||
| 559 | 0  | 0  | $format =~ s/%level%/$ulevel/g; | |||
| 560 | 0  | 0  | $format =~ s/%class%/$class/g; | |||
| 561 | 0  | 0  | $format =~ s/%message%/$str/g; | |||
| 562 | 0  | 0  | $format =~ s/%callstack%/$callstack/g; | |||
| 563 | 0  | 0  | $format =~ s/%timestamp%/$timestamp/g; | |||
| 564 | 0  | 0  | $format =~ s/%env_(\w+)%/$ENV{$1}/g; | |||
| 565 | ||||||
| 566 | 0  | 0  | print $fout "$format\n" or Carp::croak("ref($self): Can't write to ", $self->{'file'}, ": $!"); | |||
| 567 | 0  | 0  | close $fout; | |||
| 568 | } | |||||
| 569 | } | |||||
| 570 | 19  | 26  | if(my $fout = $self->{'fd'}) { | |||
| 571 | 2  | 1  | my $ulevel = uc($level); | |||
| 572 | 2  | 2  | my $callstack = (caller(1))[1] . ' ' . (caller(1))[2]; | |||
| 573 | 2  | 21  | my $format; | |||
| 574 | ||||||
| 575 | 2  | 3  | if(blessed($self) eq __PACKAGE__) { | |||
| 576 | 2  | 4  | $format = $self->{'format'} || '%level%> [%timestamp%] %callstack% %message%'; | |||
| 577 | } else { | |||||
| 578 | 0  | 0  | $format = $self->{'format'} || '%level%> [%timestamp%] %class% %callstack% %message%'; | |||
| 579 | } | |||||
| 580 | ||||||
| 581 | 2  | 4  | $format =~ s/%level%/$ulevel/g; | |||
| 582 | 2  | 1  | $format =~ s/%class%/$class/g; | |||
| 583 | 2  | 3  | $format =~ s/%message%/$str/g; | |||
| 584 | 2  | 3  | $format =~ s/%callstack%/$callstack/g; | |||
| 585 | 2  | 2  | $format =~ s/%timestamp%/$timestamp/g; | |||
| 586 | 2  | 2  | $format =~ s/%env_(\w+)%/$ENV{$1}/g; | |||
| 587 | ||||||
| 588 | 2  | 9  | print $fout "$format\n" or Carp::croak(ref($self), ": Can't write to file descriptor: $!"); | |||
| 589 | } | |||||
| 590 | } | |||||
| 591 | ||||||
| 592 - 597 | =head2 level Get/set the minimum level to log at. Returns the current level, as an integer. =cut  | |||||
| 598 | ||||||
| 599 | sub level | |||||
| 600 | { | |||||
| 601 | 1  | 2  | my ($self, $level) = @_; | |||
| 602 | ||||||
| 603 | 1  | 4  | if($level) { | |||
| 604 | 1  | 2  | if(!defined($syslog_values{$level})) { | |||
| 605 | 0  | 0  | Carp::carp(ref($self), ": invalid syslog level '$level'"); | |||
| 606 | 0  | 0  | return; | |||
| 607 | } | |||||
| 608 | 1  | 1  | $self->{'level'} = $syslog_values{$level}; | |||
| 609 | } | |||||
| 610 | 1  | 2  | return Return::Set::set_return($self->{'level'}, { 'type' => 'integer', 'min' => 0, 'max' => 7 }); | |||
| 611 | } | |||||
| 612 | ||||||
| 613 - 618 | =head2 is_debug Are we at a debug level that will emit debug messages? For compatibility with L<Log::Any>. =cut  | |||||
| 619 | ||||||
| 620 | sub is_debug | |||||
| 621 | { | |||||
| 622 | 2  | 64  | my $self = $_[0]; | |||
| 623 | ||||||
| 624 | 2  | 7  | return ($self->{'level'} && ($self->{'level'} >= $DEBUG)) ? 1 : 0; | |||
| 625 | } | |||||
| 626 | ||||||
| 627 - 631 | =head2 messages Return all the messages emitted so far =cut  | |||||
| 632 | ||||||
| 633 | sub messages | |||||
| 634 | { | |||||
| 635 | 2  | 205  | my $self = $_[0]; | |||
| 636 | ||||||
| 637 | 2 2  | 1 6  | return [ @{$self->{messages}} ]; # Return a shallow copy | |||
| 638 | } | |||||
| 639 | ||||||
| 640 - 646 | =head2 debug $logger->debug(@messages); Logs a debug message. =cut  | |||||
| 647 | ||||||
| 648 | sub debug { | |||||
| 649 | 9  | 17  | my $self = shift; | |||
| 650 | 9  | 10  | $self->_log('debug', @_); | |||
| 651 | } | |||||
| 652 | ||||||
| 653 - 659 | =head2 info $logger->info(@messages); Logs an info message. =cut  | |||||
| 660 | ||||||
| 661 | sub info { | |||||
| 662 | 7  | 11  | my $self = shift; | |||
| 663 | 7  | 5  | $self->_log('info', @_); | |||
| 664 | } | |||||
| 665 | ||||||
| 666 - 672 | =head2 notice $logger->notice(@messages); Logs a notice message. =cut  | |||||
| 673 | ||||||
| 674 | sub notice { | |||||
| 675 | 1  | 1  | my $self = shift; | |||
| 676 | 1  | 1  | $self->_log('notice', @_); | |||
| 677 | } | |||||
| 678 | ||||||
| 679 - 687 | =head2 error $logger->error(@messages); Logs an error message. This method also supports logging to syslog if configured. If not logging mechanism is set, falls back to C<Carp>. =cut  | |||||
| 688 | ||||||
| 689 | sub error { | |||||
| 690 | 0  | 0  | my $self = shift; | |||
| 691 | ||||||
| 692 | 0  | 0  | $self->_high_priority('error', @_); | |||
| 693 | } | |||||
| 694 | ||||||
| 695 - 701 | =head2 trace $logger->trace(@messages); Logs a trace message. =cut  | |||||
| 702 | ||||||
| 703 | sub trace { | |||||
| 704 | 1  | 1  | my $self = shift; | |||
| 705 | 1  | 2  | $self->_log('trace', @_); | |||
| 706 | } | |||||
| 707 | ||||||
| 708 - 718 | =head2 warn $logger->warn(@messages); $logger->warn(\@messages); $logger->warn(warning => \@messages); Logs a warning message. This method also supports logging to syslog if configured. If not logging mechanism is set, falls back to C<Carp>. =cut  | |||||
| 719 | ||||||
| 720 | sub warn { | |||||
| 721 | 4  | 27  | my $self = shift; | |||
| 722 | ||||||
| 723 | 4  | 6  | $self->_high_priority('warn', @_); | |||
| 724 | } | |||||
| 725 | ||||||
| 726 - 730 | =head2 _high_priority Helper to handle important messages. =cut  | |||||
| 731 | ||||||
| 732 | sub _high_priority | |||||
| 733 | { | |||||
| 734 | 4  | 3  | my $self = shift; | |||
| 735 | 4  | 2  | my $level = shift; # 'warn' or 'error' | |||
| 736 | 4  | 8  | my $params = Params::Get::get_params('warning', @_); # Get parameters | |||
| 737 | ||||||
| 738 | # Validate input parameters | |||||
| 739 | 4  | 51  | return unless ($params && (ref($params) eq 'HASH')); | |||
| 740 | ||||||
| 741 | # Only logging things higher than warn level | |||||
| 742 | 4  | 8  | return if($syslog_values{$level} > $WARNING); | |||
| 743 | ||||||
| 744 | 4  | 12  | my $warning = $params->{warning}; | |||
| 745 | 4  | 4  | if(!defined($warning)) { | |||
| 746 | 1  | 2  | if(scalar(@_) && !ref($_[0])) { | |||
| 747 | # Given an array | |||||
| 748 | 1  | 1  | $warning = join('', @_); | |||
| 749 | } else { | |||||
| 750 | 0  | 0  | return; | |||
| 751 | } | |||||
| 752 | } | |||||
| 753 | 4  | 7  | if(ref($warning) eq 'ARRAY') { | |||
| 754 | # Given "message => [ ref to array ]" | |||||
| 755 | 1 1  | 1 5  | $warning = join('', @{$warning}); | |||
| 756 | } | |||||
| 757 | ||||||
| 758 | 4  | 6  | if($self eq __PACKAGE__) { | |||
| 759 | # If called from a class method, use Croak/Carp to warn | |||||
| 760 | 0  | 0  | if($syslog_values{$level} <= $ERROR) { | |||
| 761 | 0  | 0  | Carp::croak($warning); | |||
| 762 | } | |||||
| 763 | 0  | 0  | Carp::carp($warning); | |||
| 764 | 0  | 0  | return; | |||
| 765 | } | |||||
| 766 | ||||||
| 767 | # Log the warning message | |||||
| 768 | 4  | 7  | $self->_log($level, $warning); | |||
| 769 | ||||||
| 770 | 4  | 5  | if($syslog_values{$level} <= $ERROR) { | |||
| 771 | # Fall back to Croak if no logger or syslog is defined | |||||
| 772 | 0  | 0  | if($self->{'croak_on_error'} || !defined($self->{logger})) { | |||
| 773 | 0  | 0  | Carp::croak($warning); | |||
| 774 | } | |||||
| 775 | } | |||||
| 776 | ||||||
| 777 | 4  | 19  | if($self->{'carp_on_warn'} || !defined($self->{logger})) { | |||
| 778 | # Fallback to Carp if no logger or syslog is defined | |||||
| 779 | 0  | 0  | Carp::carp($warning); | |||
| 780 | } | |||||
| 781 | } | |||||
| 782 | ||||||
| 783 | # Destructor to close syslog connection | |||||
| 784 | sub DESTROY { | |||||
| 785 | 21  | 2483  | my $self = $_[0]; | |||
| 786 | ||||||
| 787 | 21  | 182  | if($self->{_syslog_opened}) { | |||
| 788 | 1  | 2  | closelog(); | |||
| 789 | 1  | 8  | delete $self->{_syslog_opened}; | |||
| 790 | } | |||||
| 791 | } | |||||
| 792 | ||||||
| 793 - 848 | =head1 AUTHOR Nigel Horne C<njh@nigelhorne.com> =head1 SEE ALSO =over 4 =item * Test coverage report: L<https://nigelhorne.github.io/Log-Abstraction/coverage/> =back =head1 SUPPORT This module is provided as-is without any warranty. Please report any bugs or feature requests to C<bug-log-abstraction at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Log-Abstraction>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. You can find documentation for this module with the perldoc command. perldoc Log::Abstraction You can also look for information at: =over 4 =item * MetaCPAN L<https://metacpan.org/dist/Log-Abstraction> =item * RT: CPAN's request tracker L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Log-Abstraction> =item * CPAN Testers' Matrix L<http://matrix.cpantesters.org/?dist=Log-Abstraction> =item * CPAN Testers Dependencies L<http://deps.cpantesters.org/?module=Log::Abstraction> =back =head1 COPYRIGHT AND LICENSE Copyright (C) 2025 Nigel Horne This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut  | |||||
| 849 | ||||||
| 850 | 1; | |||||