File Coverage

blib/lib/Log/Log4perl/Layout/XMLLayout.pm
Criterion Covered Total %
statement 57 97 58.7
branch 7 30 23.3
condition 2 6 33.3
subroutine 14 16 87.5
pod 1 3 33.3
total 81 152 53.2


line stmt bran cond sub pod time code
1             ##################################################
2             package Log::Log4perl::Layout::XMLLayout;
3             ##################################################
4            
5 1     1   93529 use 5.006;
  1         4  
  1         38  
6 1     1   5 use strict;
  1         2  
  1         42  
7 1     1   5 use warnings;
  1         2  
  1         25  
8 1     1   4 use Carp;
  1         1  
  1         72  
9 1     1   5 use Log::Log4perl::Level;
  1         2  
  1         8  
10 1     1   129 use Log::Log4perl::DateFormat;
  1         2  
  1         26  
11 1     1   5 use Log::Log4perl::NDC;
  1         2  
  1         24  
12 1     1   5 use Log::Log4perl::MDC;
  1         2  
  1         17  
13 1     1   5 use File::Spec;
  1         1  
  1         144  
14            
15             our $TIME_HIRES_AVAILABLE;
16             our $TIME_HIRES_AVAILABLE_WARNED = 0;
17            
18             our $VERSION = do { my @r = (q$Revision: 0.03 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
19            
20            
21            
22             BEGIN {
23             # Check if we've got Time::HiRes. If not, don't make a big fuss,
24             # just set a flag so we know later on that we can't have fine-grained
25             # time stamps
26 1     1   14 $TIME_HIRES_AVAILABLE = 0;
27 1         2 eval { require Time::HiRes; };
  1         6  
28 1 50       5 if(!$@) {
29 1         76 $TIME_HIRES_AVAILABLE = 1;
30             }
31             }
32            
33             ##################################################
34             sub current_time {
35             ##################################################
36             # Return msecs
37 0 0   0 0 0 if($TIME_HIRES_AVAILABLE) {
38 0         0 my($millis)=0;
39 0         0 my($secs, $micros)=Time::HiRes::gettimeofday();
40 1     1   908 { use integer;
  1         10  
  1         5  
  0         0  
41 0         0 $millis=$micros/1000;
42             }
43             # we do not want to use BigInt:
44             # determine millisecs since 1970 based on string operations
45 0         0 return (sprintf("%s%0.3d", $secs, $millis));
46             } else {
47 0         0 return (time().'000');
48             }
49             }
50            
51 1     1   77 use base qw(Log::Log4perl::Layout);
  1         2  
  1         99  
52            
53 1     1   5 no strict qw(refs);
  1         2  
  1         766  
54            
55             ##################################################
56             sub new {
57             ##################################################
58 4     4 1 4525 my $class = shift;
59 4   33     20 $class = ref ($class) || $class;
60            
61 4         7 my ($data) = @_;
62            
63 4         6 my ($location_info)=1;
64 4         5 my ($encoding)=undef;
65            
66 4 50 33     23 if ((defined $data) && (ref $data)) {
67 4 50       15 if (exists $data->{LocationInfo}{value} ) {
68 4 100       14 $location_info = (uc($data->{'LocationInfo'}{value}) eq 'TRUE'?1:0);
69             }
70 4 100       13 if (exists $data->{'Encoding'}{value} ) {
71 2         6 $encoding = $data->{'Encoding'}{value};
72             }
73             }
74 4         15 my $self = {
75             format => undef,
76             info_needed => {},
77             stack => []
78             };
79            
80 4         35 bless $self, $class;
81 4         12 $self->{'location_info'}=$location_info;
82 4         8 $self->{'encoding'}=$encoding;
83 4         7 $self->{'enc_set'}=0;
84            
85 4         11 return $self;
86             }
87            
88            
89             ##################################################
90             sub render {
91             ##################################################
92 0     0 0   my($self, $message, $category, $priority, $caller_level) = @_;
93            
94 0 0         $caller_level = 0 unless defined $caller_level;
95            
96 0           my %info = ();
97            
98 0           $info{m} = $message;
99             # See 'define'
100 0 0         chomp $info{m} if $self->{message_chompable};
101            
102 0           my @results = ();
103            
104 0 0         if($self->{'location_info'}) {
105 0           my ($package, $filename, $line,
106             $subroutine, $hasargs,
107             $wantarray, $evaltext, $is_require,
108             $hints, $bitmask) = caller($caller_level);
109            
110             # If caller() choked because of a whacko caller level,
111             # correct undefined values to 'undef' in order to prevent
112             # warning messages when interpolating later
113 0 0         unless(defined $bitmask) {
114 0           for($package,
115             $filename, $line,
116             $subroutine, $hasargs,
117             $wantarray, $evaltext, $is_require,
118             $hints, $bitmask) {
119 0 0         $_ = 'undef' unless defined $_;
120             }
121             }
122            
123 0           $info{L} = $line;
124 0           $info{F} = $filename;
125 0           $info{C} = $package;
126 0           $info{C} =~ s/::/./g;
127            
128             # For the name of the subroutine the logger was triggered,
129             # we need to go one more level up
130 0           $subroutine = (caller($caller_level+1))[3];
131 0 0         $subroutine = "main" unless $subroutine;
132 0           my(@namespace)=split(/::/, $subroutine);
133 0           $info{M} = pop(@namespace);
134             }
135            
136 0           $info{x} = Log::Log4perl::NDC->get();
137 0           $info{x} =~ s/[\[\]]//g;
138 0           $info{x} =~ s/::/./g;
139 0           $info{c} = $category;
140 0           $info{d} = current_time;
141 0           $info{p} = $priority;
142            
143             # create XML-Code
144            
145 0           my($xml_code)= qq(
146             timestamp="$info{d}"
147             level="$info{p}"
148             thread="$$">
149            
150             );
151 0 0         if($self->{'location_info'}) {
152 0           $xml_code.= qq(
153            
154             method="$info{M}"
155             file="$info{F}"
156             line="$info{L}">
157             );
158             }
159 0           $xml_code.= qq(\n\n);
160            
161 0 0         if(!($self->{'enc_set'})) {
162 0 0         $xml_code=join("\n", qq({'encoding'}"?>)
163             , $xml_code) if (defined $self->{'encoding'});
164 0           $self->{'enc_set'}=1;
165             }
166 0           return ($xml_code);
167             }
168            
169            
170             1;
171            
172             __END__