File Coverage

blib/lib/Log/Agent/Prefixer.pm
Criterion Covered Total %
statement 15 22 68.1
branch 11 14 78.5
condition 1 3 33.3
subroutine 3 9 33.3
pod 0 8 0.0
total 30 56 53.5


line stmt bran cond sub pod time code
1             ###########################################################################
2             #
3             # Prefixer.pm
4             #
5             # Copyright (C) 1999 Raphael Manfredi.
6             # Copyright (C) 2002-2017 Mark Rogaski, mrogaski@cpan.org;
7             # all rights reserved.
8             #
9             # See the README file included with the
10             # distribution for license information.
11             #
12             ##########################################################################
13            
14 8     8   57 use strict;
  8         16  
  8         3090  
15            
16             ########################################################################
17             package Log::Agent::Prefixer;
18            
19             #
20             # Ancestor for logging channels wishing to implement native prefixing
21             #
22            
23             #
24             # Attribute access: those attributes must be filled by our heirs
25             #
26            
27 0     0 0 0 sub prefix { $_[0]->{'prefix'} }
28 64     64 0 272 sub stampfmt { $_[0]->{'stampfmt'} }
29 0     0 0 0 sub showpid { $_[0]->{'showpid'} }
30 0     0 0 0 sub no_ucfirst { $_[0]->{'no_ucfirst'} }
31 0     0 0 0 sub no_prefixing { $_[0]->{'no_prefixing'} }
32 0     0 0 0 sub no_newline { $_[0]->{'no_newline'} }
33 0     0 0 0 sub crlf { $_[0]->{'crlf'} }
34            
35             #
36             # ->prefixing_string
37             #
38             # Compute prefixing string: stamping and "prefix: " to be emitted before
39             # the logged string.
40             #
41             # Usage:
42             #
43             # $str = $self->prefixing_string(); # no ucfirst support possible
44             # $str = $self->prefixing_string(\$log_message);
45             #
46             # Leading char of to-be-logged string is upper-cased in-place if
47             # neither prefix nor pid are present, and behaviour was not disabled
48             # via a -no_ucfirst, and the second call form with a scalar ref is used.
49             #
50             sub prefixing_string {
51 71     71 0 123 my $self = shift;
52            
53             #
54             # This routine is called often...
55             # Bypass the attribute access routines.
56             #
57            
58 71         117 my $prefix = $self->{prefix};
59 71 100       143 $prefix = '' unless defined $prefix;
60 71 100       255 if ($self->{showpid}) {
    100          
61 14 50       30 if ($prefix eq '') {
62 0         0 $prefix = $$;
63             } else {
64 14         52 $prefix .= "[$$]";
65             }
66             } elsif ($prefix eq '') {
67 14         19 my $rstr = $_[0];
68 14 50 33     89 $$rstr =~ s/^(.)/\u$1/ if ref $rstr && !$self->{no_ucfirst};
69             }
70 71         109 my $stamp = &{$self->{stampfmt}};
  71         173  
71             return
72 71 50       427 ($stamp eq '' ? '' : "$stamp ") .
    100          
73             ($prefix eq '' ? '' : "$prefix: ");
74             }
75            
76             1; # for require