File Coverage

blib/lib/Log/Agent/Formatting.pm
Criterion Covered Total %
statement 26 33 78.7
branch 9 12 75.0
condition n/a
subroutine 5 7 71.4
pod 0 3 0.0
total 40 55 72.7


line stmt bran cond sub pod time code
1             ###########################################################################
2             #
3             # Formatting.pm
4             #
5             # Copyright (C) 1999 Raphael Manfredi.
6             # Copyright (C) 2002-2015 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 14     14   63 use strict;
  14         26  
  14         576  
15             require Exporter;
16              
17             ########################################################################
18             package Log::Agent::Formatting;
19              
20 14     14   65 use vars qw(@ISA @EXPORT_OK);
  14         30  
  14         3929  
21              
22             @ISA = qw(Exporter);
23             @EXPORT_OK = qw(format_args tag_format_args);
24              
25             require Log::Agent::Message;
26              
27             #
28             # adjust_fmt
29             #
30             # We process syslog's %m macro as being the current error message ($!) in
31             # the first argument only. Doing it at this level means it will be supported
32             # independently from the driver they'll choose. It's also done BEFORE any
33             # log-related system call, thus ensuring that $! retains its original value.
34             #
35             if ($] >= 5.005) {
36 94     94 0 182 eval q{ # if VERSION >= 5.005
  94         153  
  94         240  
37             # 5.005 and later version grok /(?
38             sub adjust_fmt {
39             my $fmt = shift;
40             $fmt =~ s/((?
41             return $fmt;
42             }
43             }
44             } else {
45             eval q{ # else /* VERSION < 5.005 */
46             # pre-5.005 does not grok /(?
47             sub adjust_fmt {
48             my $fmt = shift;
49             $fmt =~ s/%%/\01/g;
50             $fmt =~ s/%m/$Log::Agent::OS_Error/g;
51             $fmt =~ s/\01/%%/g;
52             return $fmt;
53             }
54             }
55             } # endif /* VERSION >= 5.005 */
56              
57             #
58             # whine
59             #
60             # This is a local hack of carp
61             #
62             sub whine {
63 0     0 0 0 my $msg = shift;
64 0 0       0 unless (chomp $msg) {
65 0         0 my($package, $filename, $line) = caller 2;
66 0         0 $msg .= " at $filename line $line.";
67             }
68 0         0 warn "$msg\n";
69             }
70              
71             #
72             # tag_format_args
73             #
74             # Arguments:
75             #
76             # $caller caller information, done firstly
77             # $priority priority information, done secondly
78             # $tags list of user-defined tags, done lastly
79             # $ary arguments for sprintf()
80             #
81             # Returns a Log::Agent::Message object, which, when stringified, prints
82             # the string itself.
83             #
84             sub tag_format_args {
85 94     94 0 167 my ($caller, $priority, $tags, $ary) = @_;
86 94         2556 my $msg = adjust_fmt(shift @$ary);
87              
88             # This bit of tomfoolery is intended to make debugging of
89             # programs a bit easier by prechecking input to sprintf()
90             # for errors. I usually prefer lazy error checking, but
91             # this seems to be an appropriate exception.
92 94 100       498 if (my @arglist = $msg =~ /\%[^\%]*[csduoxefgXEGbpniDUOF]|\%\%/g) {
93 14     14   80 BEGIN { no warnings }
  14     0   31  
  14         3131  
  0         0  
94 6         20 my $argcnt = grep !/\%\%/, @arglist;
95 6 50       17 if (grep {! defined} @$ary[0..($argcnt - 1)]) {
  5         16  
96 0         0 whine("Use of uninitialized value in sprintf");
97             }
98 6         26 $msg = sprintf $msg, @$ary;
99             }
100              
101 94         521 my $str = Log::Agent::Message->make($msg);
102 94 100       272 $caller->insert($str) if defined $caller;
103 94 100       205 $priority->insert($str) if defined $priority;
104 94 100       343 if (defined $tags) {
105 4         10 foreach my $tag (@$tags) {
106 6         32 $tag->insert($str);
107             }
108             }
109 94         2219 return $str;
110             }
111              
112             1;