File Coverage

blib/lib/Net/Syslogd.pm
Criterion Covered Total %
statement 24 158 15.1
branch 0 62 0.0
condition 0 28 0.0
subroutine 8 22 36.3
pod 14 14 100.0
total 46 284 16.2


line stmt bran cond sub pod time code
1             package Net::Syslogd;
2              
3             ########################################################
4             # AUTHOR = Michael Vincent
5             # www.VinsWorld.com
6             ########################################################
7              
8 1     1   10599 use strict;
  1         2  
  1         29  
9 1     1   4 use warnings;
  1         0  
  1         21  
10 1     1   513 use Socket qw(AF_INET);
  1         2980  
  1         192  
11              
12             my $AF_INET6 = eval { Socket::AF_INET6() };
13              
14             our $VERSION = '0.16';
15             our @ISA;
16              
17             my $HAVE_IO_Socket_IP = 0;
18 1     1   624 eval "use IO::Socket::IP -register";
  1         28830  
  1         11  
19             if(!$@) {
20             $HAVE_IO_Socket_IP = 1;
21             push @ISA, "IO::Socket::IP"
22             } else {
23             require IO::Socket::INET;
24             push @ISA, "IO::Socket::INET";
25             }
26              
27             ########################################################
28             # Start Variables
29             ########################################################
30 1     1   6 use constant SYSLOGD_DEFAULT_PORT => 514;
  1         1  
  1         57  
31 1     1   3 use constant SYSLOGD_RFC_SIZE => 1024; # RFC Limit
  1         1  
  1         31  
32 1     1   3 use constant SYSLOGD_REC_SIZE => 2048; # Recommended size
  1         1  
  1         25  
33 1     1   2 use constant SYSLOGD_MAX_SIZE => 65467; # Actual limit (65535 - IP/UDP)
  1         1  
  1         1456  
34              
35             my @FACILITY = qw(kernel user mail system security internal printer news uucp clock security2 FTP NTP audit alert clock2 local0 local1 local2 local3 local4 local5 local6 local7);
36             my @SEVERITY = qw(Emergency Alert Critical Error Warning Notice Informational Debug);
37             our $LASTERROR;
38             ########################################################
39             # End Variables
40             ########################################################
41              
42             ########################################################
43             # Start Public Module
44             ########################################################
45              
46             sub new {
47 0     0 1   my $self = shift;
48 0   0       my $class = ref($self) || $self;
49              
50             # Default parameters
51 0           my %params = (
52             'Proto' => 'udp',
53             'LocalPort' => SYSLOGD_DEFAULT_PORT,
54             'Timeout' => 10,
55             'Family' => AF_INET
56             );
57              
58 0 0         if (@_ == 1) {
59 0           $LASTERROR = "Insufficient number of args - @_";
60             return undef
61 0           } else {
62 0           my %cfg = @_;
63 0           for (keys(%cfg)) {
64 0 0         if (/^-?localport$/i) {
    0          
    0          
    0          
65 0           $params{LocalPort} = $cfg{$_}
66             } elsif (/^-?localaddr$/i) {
67 0           $params{LocalAddr} = $cfg{$_}
68             } elsif (/^-?family$/i) {
69 0 0         if ($cfg{$_} =~ /^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/) {
  0            
70 0 0         if ($cfg{$_} =~ /^(?:(?:(:?ip)?v?4)|${\AF_INET})$/) {
  0            
71 0           $params{Family} = AF_INET
72             } else {
73 0 0         if (!$HAVE_IO_Socket_IP) {
74 0           $LASTERROR = "IO::Socket::IP required for IPv6";
75             return undef
76 0           }
77 0           $params{Family} = $AF_INET6;
78 0 0         if ($^O ne 'MSWin32') {
79 0           $params{V6Only} = 1
80             }
81             }
82             } else {
83 0           $LASTERROR = "Invalid family - $cfg{$_}";
84             return undef
85 0           }
86             } elsif (/^-?timeout$/i) {
87 0 0         if ($cfg{$_} =~ /^\d+$/) {
88 0           $params{Timeout} = $cfg{$_}
89             } else {
90 0           $LASTERROR = "Invalid timeout - $cfg{$_}";
91             return undef
92 0           }
93             # pass through
94             } else {
95 0           $params{$_} = $cfg{$_}
96             }
97             }
98             }
99              
100 0 0         if (my $udpserver = $class->SUPER::new(%params)) {
101 0           return bless {
102             %params, # merge user parameters
103             '_UDPSERVER_' => $udpserver
104             }, $class
105             } else {
106 0           $LASTERROR = "Error opening socket for listener: $@";
107             return undef
108 0           }
109             }
110              
111             sub get_message {
112 0     0 1   my $self = shift;
113 0   0       my $class = ref($self) || $self;
114              
115 0           my $message;
116              
117 0           foreach my $key (keys(%{$self})) {
  0            
118             # everything but '_xxx_'
119 0 0         $key =~ /^\_.+\_$/ and next;
120 0           $message->{$key} = $self->{$key}
121             }
122              
123 0           my $datagramsize = SYSLOGD_MAX_SIZE;
124 0 0         if (@_ == 1) {
125 0           $LASTERROR = "Insufficient number of args: @_";
126             return undef
127 0           } else {
128 0           my %args = @_;
129 0           for (keys(%args)) {
130             # -maxsize
131 0 0         if (/^-?(?:max)?size$/i) {
    0          
132 0 0         if ($args{$_} =~ /^\d+$/) {
    0          
    0          
133 0 0 0       if (($args{$_} >= 1) && ($args{$_} <= SYSLOGD_MAX_SIZE)) {
134 0           $datagramsize = $args{$_}
135             }
136             } elsif ($args{$_} =~ /^rfc$/i) {
137 0           $datagramsize = SYSLOGD_RFC_SIZE
138             } elsif ($args{$_} =~ /^rec(?:ommend)?(?:ed)?$/i) {
139 0           $datagramsize = SYSLOGD_REC_SIZE
140             } else {
141 0           $LASTERROR = "Not a valid size: $args{$_}";
142             return undef
143 0           }
144             # -timeout
145             } elsif (/^-?timeout$/i) {
146 0 0         if ($args{$_} =~ /^\d+$/) {
147 0           $message->{Timeout} = $args{$_}
148             } else {
149 0           $LASTERROR = "Invalid timeout - $args{$_}";
150             return undef
151 0           }
152             }
153             }
154             }
155              
156 0           my $Timeout = $message->{Timeout};
157 0           my $udpserver = $self->{_UDPSERVER_};
158 0           my $datagram;
159              
160 0 0         if ($Timeout != 0) {
161             # vars for IO select
162 0           my ($rin, $rout, $ein, $eout) = ('', '', '', '');
163 0           vec($rin, fileno($udpserver), 1) = 1;
164              
165             # check if a message is waiting
166 0 0         if (! select($rout=$rin, undef, $eout=$ein, $Timeout)) {
167 0           $LASTERROR = "Timed out waiting for datagram";
168 0           return(0)
169             }
170             }
171              
172             # read the message
173 0 0         if ($udpserver->recv($datagram, $datagramsize)) {
174              
175 0           $message->{_UDPSERVER_} = $udpserver;
176 0           $message->{_MESSAGE_}{PeerPort} = $udpserver->SUPER::peerport;
177 0           $message->{_MESSAGE_}{PeerAddr} = $udpserver->SUPER::peerhost;
178 0           $message->{_MESSAGE_}{datagram} = $datagram;
179              
180 0           return bless $message, $class
181             }
182              
183 0           $LASTERROR = sprintf "Socket RECV error: $!";
184             return undef
185 0           }
186              
187             sub process_message {
188 0     0 1   my $self = shift;
189 0   0       my $class = ref($self) || $self;
190              
191             ### Allow to be called as subroutine
192             # Net::Syslogd->process_message($data)
193 0 0 0       if (($self eq $class) && ($class eq __PACKAGE__)) {
194 0           my %th;
195 0           $self = \%th;
196 0           ($self->{_MESSAGE_}{datagram}) = @_
197             }
198             # Net::Syslogd::process_message($data)
199 0 0         if ($class ne __PACKAGE__) {
200 0           my %th;
201 0           $self = \%th;
202 0           ($self->{_MESSAGE_}{datagram}) = $class;
203 0           $class = __PACKAGE__
204             }
205              
206             # Syslog RFC 3164 correct format:
207             # <###>Mmm dd hh:mm:ss hostname tag msg
208             #
209             # NOTE: This module parses the tag and msg as a single field called msg
210             ######
211             # Cisco:
212             # service timestamps log uptime
213             # <189>82: 00:20:10: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
214             # service timestamps log datetime
215             # <189>83: *Oct 16 21:41:00: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
216             # service timestamps log datetime msec
217             # <189>88: *Oct 16 21:46:48.671: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
218             # service timestamps log datetime year
219             # <189>86: *Oct 16 2010 21:45:56: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
220             # service timestamps log datetime show-timezone
221             # <189>92: *Oct 16 21:49:30 UTC: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
222             # service timestamps log datetime msec year
223             # <189>90: *Oct 16 2010 21:47:50.439: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
224             # service timestamps log datetime msec show-timezone
225             # <189>93: *Oct 16 21:51:13.823 UTC: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
226             # service timestamps log datetime year show-timezone
227             # <189>94: *Oct 16 2010 21:51:49 UTC: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
228             # service timestamps log datetime msec year show-timezone
229             # <189>91: *Oct 16 2010 21:48:41.663 UTC: %SYS-5-CONFIG_I: Configured from console by cisco on vty0 (192.168.200.1)
230             # IPv4 only
231             # my $regex = '<(\d{1,3})>[\d{1,}: \*]*((?:[JFMASONDjfmasond]\w\w) {1,2}(?:\d+)(?: \d{4})* (?:\d{2}:\d{2}:\d{2}[\.\d{1,3}]*)(?: [A-Z]{1,3})*)?:*\s*(?:((?:[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})|(?:[a-zA-Z0-9\-]+)) )?(.*)';
232             # IPv6
233 0           my $regex = '<(\d{1,3})>[\d{1,}: \*]*((?:[JFMASONDjfmasond]\w\w) {1,2}(?:\d+)(?: \d{4})? (?:\d{2}:\d{2}:\d{2}[\.\d{1,3}]*)(?: [A-Z]{1,3}:)?)?:?\s*(?:((?:[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})|(?:[a-zA-Z0-9\-]+)|(?:(?:(?:[0-9A-Fa-f]{1,4}:){7}(?:[0-9A-Fa-f]{1,4}|:))|(?:(?:[0-9A-Fa-f]{1,4}:){6}(?::[0-9A-Fa-f]{1,4}|(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(?:(?:[0-9A-Fa-f]{1,4}:){5}(?:(?:(?::[0-9A-Fa-f]{1,4}){1,2})|:(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(?:(?:[0-9A-Fa-f]{1,4}:){4}(?:(?:(?::[0-9A-Fa-f]{1,4}){1,3})|(?:(?::[0-9A-Fa-f]{1,4})?:(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(?:(?:[0-9A-Fa-f]{1,4}:){3}(?:(?:(?::[0-9A-Fa-f]{1,4}){1,4})|(?:(?::[0-9A-Fa-f]{1,4}){0,2}:(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(?:(?:[0-9A-Fa-f]{1,4}:){2}(?:(?:(?::[0-9A-Fa-f]{1,4}){1,5})|(?:(?::[0-9A-Fa-f]{1,4}){0,3}:(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(?:(?:[0-9A-Fa-f]{1,4}:){1}(?:(?:(?::[0-9A-Fa-f]{1,4}){1,6})|(?:(?::[0-9A-Fa-f]{1,4}){0,4}:(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(?::(?:(?:(?::[0-9A-Fa-f]{1,4}){1,7})|(?:(?::[0-9A-Fa-f]{1,4}){0,5}:(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(?:\.(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:)))(?:%.+)?) )?(.*)';
234              
235             # If more than 1 argument, parse the options
236 0 0         if (@_ != 1) {
237 0           my %args = @_;
238 0           for (keys(%args)) {
239             # -datagram
240 0 0 0       if ((/^-?data(?:gram)?$/i) || (/^-?pdu$/i)) {
241 0           $self->{_MESSAGE_}{datagram} = $args{$_}
242             }
243             # -regex
244 0 0         if (/^-?regex$/i) {
245 0 0         if ($args{$_} =~ /^rfc(?:3164)?$/i) {
246             # Strict RFC 3164
247 0           $regex = '<(\d{1,3})>((?:[JFMASONDjfmasond]\w\w) {1,2}(?:\d+)(?: \d{4})? (?:\d{2}:\d{2}:\d{2}))?:*\s*(?:((?:[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})|(?:[a-zA-Z0-9\-]+)) )?(.*)'
248             } else {
249 0           $regex = $args{$_};
250             # strip leading / if found
251 0           $regex =~ s/^\///;
252             # strip trailing / if found
253 0           $regex =~ s/\/$//
254             }
255             }
256             }
257             }
258              
259 0           my $Cregex = qr/$regex/;
260              
261             # Parse message
262 0           $self->{_MESSAGE_}{datagram} =~ /$Cregex/;
263              
264 0           $self->{_MESSAGE_}{priority} = $1;
265 0   0       $self->{_MESSAGE_}{time} = $2 || 0;
266 0   0       $self->{_MESSAGE_}{hostname} = $3 || 0;
267 0           $self->{_MESSAGE_}{message} = $4;
268 0           $self->{_MESSAGE_}{severity} = $self->{_MESSAGE_}{priority} % 8;
269 0           $self->{_MESSAGE_}{facility} = ($self->{_MESSAGE_}{priority} - $self->{_MESSAGE_}{severity}) / 8;
270              
271 0           $self->{_MESSAGE_}{hostname} =~ s/\s+//;
272 0           $self->{_MESSAGE_}{time} =~ s/:$//;
273              
274 0           return bless $self, $class
275             }
276              
277             sub server {
278 0     0 1   my $self = shift;
279 0           return $self->{_UDPSERVER_}
280             }
281              
282             sub datagram {
283 0     0 1   my $self = shift;
284 0           return $self->{_MESSAGE_}{datagram}
285             }
286              
287             sub remoteaddr {
288 0     0 1   my $self = shift;
289 0           return $self->{_MESSAGE_}{PeerAddr}
290             }
291              
292             sub remoteport {
293 0     0 1   my $self = shift;
294 0           return $self->{_MESSAGE_}{PeerPort}
295             }
296              
297             sub priority {
298 0     0 1   my $self = shift;
299 0           return $self->{_MESSAGE_}{priority}
300             }
301              
302             sub facility {
303 0     0 1   my ($self, $arg) = @_;
304              
305 0 0 0       if (defined($arg) && ($arg >= 1)) {
306 0           return $self->{_MESSAGE_}{facility}
307             } else {
308 0           return $FACILITY[$self->{_MESSAGE_}{facility}]
309             }
310             }
311              
312             sub severity {
313 0     0 1   my ($self, $arg) = @_;
314              
315 0 0 0       if (defined($arg) && ($arg >= 1)) {
316 0           return $self->{_MESSAGE_}{severity}
317             } else {
318 0           return $SEVERITY[$self->{_MESSAGE_}{severity}]
319             }
320             }
321              
322             sub time {
323 0     0 1   my $self = shift;
324 0           return $self->{_MESSAGE_}{time}
325             }
326              
327             sub hostname {
328 0     0 1   my $self = shift;
329 0           return $self->{_MESSAGE_}{hostname}
330             }
331              
332             sub message {
333 0     0 1   my $self = shift;
334 0           return $self->{_MESSAGE_}{message}
335             }
336              
337             sub error {
338 0     0 1   return $LASTERROR
339             }
340              
341             ########################################################
342             # End Public Module
343             ########################################################
344              
345             1;
346              
347             __END__