File Coverage

blib/lib/Net/DRI/Logging.pm

Criterion	Covered	Total	%
statement	40	93	43.0
branch	10	44	22.7
condition	9	32	28.1
subroutine	7	11	63.6
pod	2	6	33.3
total	68	186	36.5

## Domain Registry Interface, Logging operations for Net::DRI
##
## Copyright (c) 2009-2010,2012 Patrick Mevzek . All rights reserved.
##
## This file is part of Net::DRI
##
## Net::DRI is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## See the LICENSE file that comes with this distribution for more details.
####################################################################################################

package Net::DRI::Logging;

use strict;
use warnings;

use base qw/Net::DRI::BaseClass/;
use Net::DRI::Util;
use Net::DRI::Exception;

__PACKAGE__->make_exception_if_not_implemented(qw/name setup_channel output/);

## Taken from Log::Log4Perl
our %LEVELS=qw/debug 0 info 1 notice 2 warning 3 error 4 critical 5 alert 6 emergency 7/;

####################################################################################################
## Public API

sub new
{
 my $c=shift;
 my $self=shift || {};
 if (! exists $self->{level}            || ! defined $self->{level} )            { $self->{level}           =3; }
 if (! exists $self->{xml_indent}       || ! defined $self->{xml_indent} )       { $self->{xml_indent}      =0; }
 if (! exists $self->{encoding}         || ! defined $self->{encoding} )         { $self->{encoding}        ='UTF-8'; }
 if (! exists $self->{format_header}    || ! defined $self->{format_header} )    { $self->{format_header}   ='%FULLTIME [%ULEVEL] <%TYPE>'; }
 if (! exists $self->{format_transport} || ! defined $self->{format_transport} ) { $self->{format_transport}='%TRID %UDIRECTION %MESSAGE'; }
 if (! exists $self->{format_protocol}  || ! defined $self->{format_protocol} )  { $self->{format_protocol} ='%TRID %UDIRECTION %MESSAGE'; }
 if (! exists $self->{sanitize_data}    || ! defined $self->{sanitize_data} )    { $self->{sanitize_data}   = {}; }
 bless $self,$c;
 $self->level($self->{level}); ## convert the level token to a numerical value
 return $self;
}

sub level
{
 my ($self,$level)=@_;
 if (defined $level)
 {
  if (exists $LEVELS{$level}) { $level=$LEVELS{$level}; }
  if ($level!~/^\d+$/ || $level > 7) { $self->output('error','logging','Invalid level value "'.$level.'", switching to default'); $level=3; }
  $self->{level}=$level;
 }
 return $self->{level};
}

####################################################################################################
## Internal API

sub string_header
{
 my ($self,$level,$type,$data)=@_;
 my $f=$self->{format_header};
 $f=~s/%FULLTIME/Net::DRI::Util::fulltime()/eg;
 $f=~s/%ULEVEL/uc($level)/eg;
 $f=~s/%TYPE/$type/g;
 return $f;
}

sub string_data
{
 my ($self,$hdr,$type,$data)=@_;
 if (! ref $data || ! exists $self->{'format_'.$type}) { return $hdr.q{ }.$data; }
 my $msg=$data->{message};
 my $ct=q{};
 my $ref=ref $msg;
 if ($ref)
 {
  if ($ref eq 'Net::DRI::Data::Raw')
  {
   $ct=$msg->hint();
  } else
  {
   if (! $msg->can('as_string')) { Net::DRI::Exception::method_not_implemented('as_string',ref $msg); }
  }
  $msg=$msg->as_string($self->{sanitize_data});
 }

 ## If this is deemed to be too brittle, a type() method could be added to Protocol/Message and correctly set to "xml" by Message classes in RRI,EPP,OpenSRS/XCP,IRIS/{XCP,LWZ}
 if (! length($ct) && substr($msg,0,5) eq '

 if ($ct eq 'xml')
 {
  if ($self->{xml_indent})
  {
   $msg=Net::DRI::Util::xml_indent($msg);
  } else
  {
   $msg=~s/^\s+//mg;
   $msg=~s/\s+$//mg;
   $msg=~s/\n/ /g;
   $msg=~s/>
  }
 }

 $data->{all}=join q{ },map { $_.q{=}.(defined $data->{$_} ? $data->{$_} : '') } sort { $a cmp $b } keys %{$data}; ## this should be handy during debugging
 if (exists $data->{direction}) { $data->{udirection}=uc $data->{direction}; $data->{adirection}=$data->{direction} eq 'in'? 'C<=S' : 'C=>S';}
 my @r;
 foreach my $l (split /\n/,$msg)
 {
  my $f=$hdr.q{ }.$self->{'format_'.$type};
  $data->{message}=$l;
  $f=~s/%([A-Z]+)/$data->{lc $1} || ''/eg;
  push @r,$f;
 }
 return join qq{\n}, @r;
}

sub tostring
{
 my ($self,$level,$type,$data)=@_;
 my $hdr=$self->string_header($level,$type);
 my $r=$self->string_data($hdr,$type,$data);
 return Net::DRI::Util::encode($self->{encoding},$r);
}

sub should_log
{
 my ($self,$level)=@_;
 return ($LEVELS{$level} >= $self->{level})? 1 : 0;
}

####################################################################################################
1;

__END__