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

##################################################
package Log::Log4perl::Layout::XMLLayout;
##################################################

use 5.006;
use strict;
use warnings;
use Carp;
use Log::Log4perl::Level;
use Log::Log4perl::DateFormat;
use Log::Log4perl::NDC;
use Log::Log4perl::MDC;
use File::Spec;

our $TIME_HIRES_AVAILABLE;
our $TIME_HIRES_AVAILABLE_WARNED = 0;

our $VERSION = do { my @r = (q$Revision: 0.03 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };



BEGIN {
    # Check if we've got Time::HiRes. If not, don't make a big fuss,
    # just set a flag so we know later on that we can't have fine-grained
    # time stamps
    $TIME_HIRES_AVAILABLE = 0;
    eval { require Time::HiRes; };
    if(!$@) {
        $TIME_HIRES_AVAILABLE = 1;
    }
}

##################################################
sub current_time {
##################################################
    # Return msecs
    if($TIME_HIRES_AVAILABLE) {
    	my($millis)=0;
    	my($secs, $micros)=Time::HiRes::gettimeofday();
    	{ use integer;
    	  $millis=$micros/1000;
    	}
        # we do not want to use BigInt:
        # determine millisecs since 1970 based on string operations
        return (sprintf("%s%0.3d", $secs, $millis));
    } else {
        return (time().'000');
    }
}

use base qw(Log::Log4perl::Layout);

no strict qw(refs);

##################################################
sub new {
##################################################
    my $class = shift;
    $class = ref ($class) || $class;

    my ($data) = @_;

    my ($location_info)=1;
    my ($encoding)=undef;

    if ((defined $data) && (ref $data)) {
       if (exists $data->{LocationInfo}{value} ) {
          $location_info = (uc($data->{'LocationInfo'}{value}) eq 'TRUE'?1:0);
        }
       if (exists $data->{'Encoding'}{value} ) {
          $encoding = $data->{'Encoding'}{value};
       }
    }
    my $self = {
        format      => undef,
        info_needed => {},
        stack       => []
    };

    bless $self, $class;
    $self->{'location_info'}=$location_info;
    $self->{'encoding'}=$encoding;
    $self->{'enc_set'}=0;

    return $self;
}


##################################################
sub render {
##################################################
    my($self, $message, $category, $priority, $caller_level) = @_;

    $caller_level = 0 unless defined  $caller_level;

    my %info    = ();

    $info{m}    = $message;
        # See 'define'
    chomp $info{m} if $self->{message_chompable};

    my @results = ();

    if($self->{'location_info'}) {
        my ($package, $filename, $line,
            $subroutine, $hasargs,
            $wantarray, $evaltext, $is_require,
            $hints, $bitmask) = caller($caller_level);

        # If caller() choked because of a whacko caller level,
        # correct undefined values to 'undef' in order to prevent
        # warning messages when interpolating later
        unless(defined $bitmask) {
            for($package,
                $filename, $line,
                $subroutine, $hasargs,
                $wantarray, $evaltext, $is_require,
                $hints, $bitmask) {
                $_ = 'undef' unless defined $_;
            }
        }

        $info{L} = $line;
        $info{F} = $filename;
        $info{C} = $package;
        $info{C} =~ s/::/./g;

        # For the name of the subroutine the logger was triggered,
        # we need to go one more level up
        $subroutine = (caller($caller_level+1))[3];
        $subroutine = "main" unless $subroutine;
        my(@namespace)=split(/::/, $subroutine);
        $info{M} = pop(@namespace);
    }

    $info{x} = Log::Log4perl::NDC->get();
    $info{x} =~ s/[\[\]]//g;
    $info{x} =~ s/::/./g;
    $info{c} = $category;
    $info{d} = current_time;
    $info{p} = $priority;

    # create XML-Code

    my($xml_code)= qq(
	timestamp="$info{d}"
	level="$info{p}"
	thread="$$">

	);
    if($self->{'location_info'}) {
    	$xml_code.= qq(

		method="$info{M}"
		file="$info{F}"
		line="$info{L}">
	);
   }
   $xml_code.= qq(\n\n);

   if(!($self->{'enc_set'})) {
      $xml_code=join("\n", qq({'encoding'}"?>)
                , $xml_code) if (defined $self->{'encoding'});
      $self->{'enc_set'}=1;
   }
   return ($xml_code);
}


1;

__END__