File Coverage

blib/lib/Log/Syslog/Abstract.pm
Criterion Covered Total %
statement 87 89 97.7
branch 21 26 80.7
condition n/a
subroutine 19 19 100.0
pod n/a
total 127 134 94.7


line stmt bran cond sub pod time code
1             package Log::Syslog::Abstract;
2 6     6   123935 use warnings;
  6         18  
  6         253  
3 6     6   36 use strict;
  6         12  
  6         211  
4 6     6   35 use Carp;
  6         15  
  6         547  
5              
6 6     6   34 use vars qw( $VERSION @ISA @EXPORT_OK );
  6         13  
  6         1448  
7             $VERSION = '1.200';
8              
9             require Exporter;
10             @ISA = qw( Exporter ); ## no critic(ProhibitExplicitISA)
11              
12             @EXPORT_OK = qw(
13             openlog
14             syslog
15             closelog
16             );
17              
18             my $_DETECTED = 0;
19             sub import
20             {
21 5 50   5   68 if( ! $_DETECTED ) {
22              
23 5         9 my ($openlog, $syslog, $closelog);
24              
25             # Try Unix::Syslog first, then Sys::Syslog
26 5     5   473 eval qq{use Unix::Syslog qw( :macros ); }; ## no critic (StringyEval)
  1         1  
  1         19  
  5         438  
27 5 100       5544 if( ! $@ ) { ## no critic (PunctuationVars)
28 1         3 ($openlog, $syslog, $closelog) = _wrap_for_unix_syslog();
29             } else {
30 4     4   1351 eval qq{use Sys::Syslog ();}; ## no critic (StringyEval)
  3         33714  
  3         34  
  4         233  
31 4 100       185 if( ! $@ ) { ## no critic (PunctuationVars)
32 3         11 ($openlog, $syslog, $closelog) = _wrap_for_sys_syslog();
33             } else {
34 1         42 croak q{Unable to detect either Unix::Syslog or Sys::Syslog};
35             }
36             }
37              
38 6     6   46 no warnings 'once'; ## no critic (NoWarnings)
  6         18  
  6         6029  
39 4         13 *openlog = $openlog;
40 4         10 *syslog = $syslog;
41 4         8 *closelog = $closelog;
42              
43 4         8 $_DETECTED = 1;
44             }
45              
46 4         549 return __PACKAGE__->export_to_level(1, @_);
47             }
48              
49             sub _wrap_for_unix_syslog
50             {
51              
52             my $openlog = sub {
53 4     4   4480 my ($id, $flags, $facility) = @_;
54              
55             ## no critic (ProhibitPostfixControls)
56 4 100       39 croak q{first argument must be an identifier string} unless defined $id;
57 3 100       23 croak q{second argument must be flag string} unless defined $flags;
58 2 100       18 croak q{third argument must be a facility string} unless defined $facility;
59              
60 1         3 my $numeric_flags = _convert_flags( $flags );
61 1         4 my $numeric_facility = _convert_facility( $facility );
62              
63 1         6 return Unix::Syslog::openlog( $id, $numeric_flags, $numeric_facility);
64 1     1   5 };
65              
66             my $syslog = sub {
67 1     1   1103 my $facility = shift;
68 1         3 my $numeric_facility = _convert_facility( $facility );
69 1         4 return Unix::Syslog::syslog( $numeric_facility, @_);
70 1         4 };
71              
72 1         2 my $closelog = \&Unix::Syslog::closelog;
73              
74 1         3 return ($openlog, $syslog, $closelog);
75             }
76              
77             sub _wrap_for_sys_syslog
78             {
79              
80             my $openlog = sub {
81 1 50   1   66 if( $Sys::Syslog::VERSION < 0.16 ) {
82             # Older Sys::Syslog versions still need
83             # setlogsock(). RHEL5 still ships with 0.13 :(
84 1         6 Sys::Syslog::setlogsock([ 'unix', 'tcp', 'udp' ]);
85             }
86 1         7 return Sys::Syslog::openlog(@_);
87 3     3   28 };
88             my $syslog = sub {
89 1     1   1387 return Sys::Syslog::syslog(@_);
90 3         10 };
91             my $closelog = sub {
92 1     1   999 return Sys::Syslog::closelog(@_);
93 3         13 };
94              
95 3         12 return ($openlog, $syslog, $closelog);
96             }
97              
98             {
99             my $flag_map;
100              
101             sub _convert_flags
102             {
103 4     4   2008 my($flags) = @_;
104              
105 4 100       13 if( ! defined $flag_map ) {
106 1         3 $flag_map = _make_flag_map();
107             }
108              
109 4         10 my $num = 0;
110 4         15 foreach my $thing (split(/,/, $flags)) {
111 6 50       14 if ( ! exists $flag_map->{$thing} ) {
112 0         0 next;
113             }
114 6         14 $num |= $flag_map->{$thing};
115             }
116 4         19 return $num;
117             }
118              
119             sub _make_flag_map
120             {
121             return {
122 1     1   3 pid => Unix::Syslog::LOG_PID(),
123             ndelay => Unix::Syslog::LOG_NDELAY(),
124             };
125             }
126             }
127              
128             {
129             my $fac_map;
130              
131             sub _convert_facility
132             {
133 33     33   15958 my($facility) = @_;
134              
135 33 100       75 if( ! defined $fac_map ) {
136 1         4 $fac_map = _make_fac_map();
137             }
138              
139 33         38 my $num = 0;
140 33         90 foreach my $thing (split(/\|/, $facility)) {
141 34 50       80 if ( ! exists $fac_map->{$thing} ) {
142 0         0 next;
143             }
144 34         85 $num |= $fac_map->{$thing};
145             }
146 33         148 return $num;
147              
148             }
149              
150             my %special = (
151             error => 'err',
152             panic => 'emerg',
153             );
154              
155             # Some of the Unix::Syslog 'macros' tag exports aren't
156             # constants, so we need to ignore them if found.
157             my %blacklisted = map { $_ => 1 } qw(
158             LOG_MASK
159             LOG_UPTO
160             LOG_PRI
161             LOG_MAKEPRI
162             LOG_FAC
163             );
164              
165             sub _make_fac_map
166             {
167 1     1   1 my %map;
168              
169             # Ugh. Make sure we map only the available constants
170             # on this platform. Some are not defined properly on
171             # all platforms.
172 1 50       1 foreach my $constant ( grep { /^LOG_/ && !exists $blacklisted{$_} } @{ $Unix::Syslog::EXPORT_TAGS{macros}} ) {
  41         177  
  1         5  
173 36         59 my $name = lc $constant;
174 36         116 $name =~ s/^log_//;
175              
176 36         1710 my $value = eval "Unix::Syslog::$constant()";
177 36 100       275 if( defined $value ) {
178 30         69 $map{$name} = $value;
179             }
180             }
181              
182             # Some strings supported by Sys::Syslog don't
183             # correspond to a Unix::Syslog LOG_XXXX constant.
184 1         8 while( my($new_key, $existing_key) = each %special ) {
185 2         12 $map{$new_key} = $map{$existing_key};
186             }
187              
188 1         4 return \%map;
189             }
190             }
191              
192             1;
193             __END__