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


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Logging operations for Net::DRI
2             ##
3             ## Copyright (c) 2009-2010,2012 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Logging;
16              
17 71     71   1463 use strict;
  71         82  
  71         1632  
18 71     71   210 use warnings;
  71         68  
  71         1418  
19              
20 71     71   195 use base qw/Net::DRI::BaseClass/;
  71         73  
  71         4396  
21 71     71   248 use Net::DRI::Util;
  71         88  
  71         1207  
22 71     71   220 use Net::DRI::Exception;
  71         77  
  71         54265  
23              
24             __PACKAGE__->make_exception_if_not_implemented(qw/name setup_channel output/);
25              
26             ## Taken from Log::Log4Perl
27             our %LEVELS=qw/debug 0 info 1 notice 2 warning 3 error 4 critical 5 alert 6 emergency 7/;
28              
29             ####################################################################################################
30             ## Public API
31              
32             sub new
33             {
34 69     69 1 120 my $c=shift;
35 69   50     300 my $self=shift || {};
36 69 50 33     238 if (! exists $self->{level} || ! defined $self->{level} ) { $self->{level} =3; }
  69         113  
37 69 50 33     195 if (! exists $self->{xml_indent} || ! defined $self->{xml_indent} ) { $self->{xml_indent} =0; }
  69         86  
38 69 50 33     276 if (! exists $self->{encoding} || ! defined $self->{encoding} ) { $self->{encoding} ='UTF-8'; }
  69         101  
39 69 50 33     192 if (! exists $self->{format_header} || ! defined $self->{format_header} ) { $self->{format_header} ='%FULLTIME [%ULEVEL] <%TYPE>'; }
  69         81  
40 69 50 33     174 if (! exists $self->{format_transport} || ! defined $self->{format_transport} ) { $self->{format_transport}='%TRID %UDIRECTION %MESSAGE'; }
  69         86  
41 69 50 33     195 if (! exists $self->{format_protocol} || ! defined $self->{format_protocol} ) { $self->{format_protocol} ='%TRID %UDIRECTION %MESSAGE'; }
  69         86  
42 69 50 33     171 if (! exists $self->{sanitize_data} || ! defined $self->{sanitize_data} ) { $self->{sanitize_data} = {}; }
  69         98  
43 69         98 bless $self,$c;
44 69         450 $self->level($self->{level}); ## convert the level token to a numerical value
45 69         176 return $self;
46             }
47              
48             sub level
49             {
50 69     69 1 97 my ($self,$level)=@_;
51 69 50       155 if (defined $level)
52             {
53 69 50       166 if (exists $LEVELS{$level}) { $level=$LEVELS{$level}; }
  0         0  
54 69 50 33     560 if ($level!~/^\d+$/ || $level > 7) { $self->output('error','logging','Invalid level value "'.$level.'", switching to default'); $level=3; }
  0         0  
  0         0  
55 69         111 $self->{level}=$level;
56             }
57 69         103 return $self->{level};
58             }
59              
60             ####################################################################################################
61             ## Internal API
62              
63             sub string_header
64             {
65 0     0 0   my ($self,$level,$type,$data)=@_;
66 0           my $f=$self->{format_header};
67 0           $f=~s/%FULLTIME/Net::DRI::Util::fulltime()/eg;
  0            
68 0           $f=~s/%ULEVEL/uc($level)/eg;
  0            
69 0           $f=~s/%TYPE/$type/g;
70 0           return $f;
71             }
72              
73             sub string_data
74             {
75 0     0 0   my ($self,$hdr,$type,$data)=@_;
76 0 0 0       if (! ref $data || ! exists $self->{'format_'.$type}) { return $hdr.q{ }.$data; }
  0            
77 0           my $msg=$data->{message};
78 0           my $ct=q{};
79 0           my $ref=ref $msg;
80 0 0         if ($ref)
81             {
82 0 0         if ($ref eq 'Net::DRI::Data::Raw')
83             {
84 0           $ct=$msg->hint();
85             } else
86             {
87 0 0         if (! $msg->can('as_string')) { Net::DRI::Exception::method_not_implemented('as_string',ref $msg); }
  0            
88             }
89 0           $msg=$msg->as_string($self->{sanitize_data});
90             }
91              
92             ## 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}
93 0 0 0       if (! length($ct) && substr($msg,0,5) eq '
  0            
94              
95 0 0         if ($ct eq 'xml')
96             {
97 0 0         if ($self->{xml_indent})
98             {
99 0           $msg=Net::DRI::Util::xml_indent($msg);
100             } else
101             {
102 0           $msg=~s/^\s+//mg;
103 0           $msg=~s/\s+$//mg;
104 0           $msg=~s/\n/ /g;
105 0           $msg=~s/>
106             }
107             }
108              
109 0 0         $data->{all}=join q{ },map { $_.q{=}.(defined $data->{$_} ? $data->{$_} : '') } sort { $a cmp $b } keys %{$data}; ## this should be handy during debugging
  0            
  0            
  0            
110 0 0         if (exists $data->{direction}) { $data->{udirection}=uc $data->{direction}; $data->{adirection}=$data->{direction} eq 'in'? 'C<=S' : 'C=>S';}
  0 0          
  0            
111 0           my @r;
112 0           foreach my $l (split /\n/,$msg)
113             {
114 0           my $f=$hdr.q{ }.$self->{'format_'.$type};
115 0           $data->{message}=$l;
116 0 0         $f=~s/%([A-Z]+)/$data->{lc $1} || ''/eg;
  0            
117 0           push @r,$f;
118             }
119 0           return join qq{\n}, @r;
120             }
121              
122             sub tostring
123             {
124 0     0 0   my ($self,$level,$type,$data)=@_;
125 0           my $hdr=$self->string_header($level,$type);
126 0           my $r=$self->string_data($hdr,$type,$data);
127 0           return Net::DRI::Util::encode($self->{encoding},$r);
128             }
129              
130             sub should_log
131             {
132 0     0 0   my ($self,$level)=@_;
133 0 0         return ($LEVELS{$level} >= $self->{level})? 1 : 0;
134             }
135              
136             ####################################################################################################
137             1;
138              
139             __END__