File Coverage

blib/lib/Net/ISC/DHCPClient.pm
Criterion Covered Total %
statement 17 244 6.9
branch 0 150 0.0
condition 0 15 0.0
subroutine 6 14 42.8
pod 0 4 0.0
total 23 427 5.3


line stmt bran cond sub pod time code
1             package Net::ISC::DHCPClient;
2              
3 1     1   64740 use 5.014;
  1         4  
4 1     1   6 use strict;
  1         2  
  1         20  
5 1     1   5 use warnings;
  1         2  
  1         61  
6              
7              
8             =head1 NAME
9              
10             Net::ISC::DHCPClient - ISC dhclient lease reader
11              
12             =head1 VERSION
13              
14             Version 0.12
15              
16             =cut
17              
18             our $VERSION = '0.12';
19              
20              
21 1     1   447 use Net::ISC::DHCPClient::InetLease;
  1         2  
  1         31  
22 1     1   392 use Net::ISC::DHCPClient::Inet6Lease;
  1         2  
  1         30  
23 1     1   483 use Time::Local;
  1         2236  
  1         2615  
24              
25              
26             sub new {
27 0     0 0   my ($class, %opts) = @_;
28              
29 0 0         die "Missing leases_path!" if (!defined($opts{leases_path}));
30              
31 0           my $self = {};
32              
33             # Incoming arguments:
34 0 0         $self->{INTERFACE} = defined($opts{interface}) ? $opts{interface} : undef;
35 0           $self->{leases_path} = $opts{leases_path};
36              
37             # Internal storage:
38 0           $self->{leases_af_inet} = undef;
39 0           $self->{leases_af_inet6} = undef;
40              
41 0           bless ($self, $class);
42              
43 0           return $self;
44             }
45              
46              
47             sub is_dhcp($$;$)
48             {
49 0     0 0   my ($self, $af, $inteface_to_query) = @_;
50              
51 0 0 0       die "Address family is: inet or inet6!" if (!($af eq 'inet' || $af eq 'inet6'));
52              
53 0 0 0       if (defined($inteface_to_query) &&
      0        
54             defined($self->{INTERFACE}) &&
55             $self->{INTERFACE} ne $inteface_to_query) {
56 0           die sprintf("Cannot query interface %s, has %s.", $inteface_to_query, $self->{INTERFACE});
57             }
58 0 0         if (defined($self->{INTERFACE})) {
59 0 0         if ($af eq 'inet') {
60 0           $self->leases_af_inet();
61 0           return scalar(@{$self->{leases_af_inet}}) > 0;
  0            
62             }
63 0 0         if ($af eq 'inet6') {
64 0           $self->leases_af_inet6();
65 0           return scalar(@{$self->{leases_af_inet6}}) > 0;
  0            
66             }
67              
68 0           return 0;
69             }
70              
71 0 0         die "Need interface!" if (!defined($inteface_to_query));
72              
73             # Iterate all found leases and look for given interface
74 0           my $leases_to_check;
75 0 0         $leases_to_check = $self->{leases_af_inet} if ($af eq 'inet');
76 0 0         $leases_to_check = $self->{leases_af_inet6} if ($af eq 'inet6');
77 0           for my $lease (@$leases_to_check) {
78 0 0         return 1 if ($lease->{INTERFACE} eq $inteface_to_query);
79             }
80              
81 0           return 0;
82             }
83              
84             sub leases_af_inet($)
85             {
86 0     0 0   my ($self) = @_;
87              
88 0 0         return $self->{leases_af_inet} if ($self->{leases_af_inet});
89              
90             $self->{leases_af_inet} = $self->_read_lease_file($self->{leases_path},
91             $self->{INTERFACE},
92 0           'inet');
93              
94 0           return $self->{leases_af_inet};
95             }
96              
97             sub leases_af_inet6($)
98             {
99 0     0 0   my ($self) = @_;
100              
101 0 0         return $self->{leases_af_inet6} if ($self->{leases_af_inet6});
102              
103             $self->{leases_af_inet6} = $self->_read_lease_file($self->{leases_path},
104             $self->{INTERFACE},
105 0           'inet6');
106              
107 0           return $self->{leases_af_inet6};
108             }
109              
110              
111             sub _read_lease_file($$$$)
112             {
113 0     0     my ($self, $path, $interface, $af) = @_;
114 0           my @isc_lease_files;
115             my @netplan_lease_files;
116 0           my $leases = [];
117              
118             # Search for matching .lease files
119 0           my $leasefile_re1;
120             my $leasefile_re2;
121 0           my $leasefile_re3;
122 0 0         if ($af eq 'inet') {
    0          
123 0 0         if ($interface) {
124 0           $leasefile_re1 = qr/^dhclient-(.*)?-($interface)\.lease$/;
125 0           $leasefile_re2 = qr/^dhclient\.($interface)\.leases$/;
126 0           $leasefile_re3 = qr/^internal-(.*)?-($interface)\.lease$/;
127             } else {
128 0           $leasefile_re1 = qr/^dhclient-(.*)?-(.+)\.lease$/;
129 0           $leasefile_re2 = qr/^dhclient\.(.+)\.leases$/;
130 0           $leasefile_re3 = qr/^internal-(.*)?-($interface)\.lease$/;
131             }
132             } elsif ($af eq 'inet6') {
133 0 0         if ($interface) {
134 0           $leasefile_re1 = qr/^dhclient6-(.*)?-($interface)\.lease$/;
135 0           $leasefile_re2 = qr/^dhclient6\.($interface)\.leases$/;
136             } else {
137 0           $leasefile_re1 = qr/^dhclient6-(.*)?-(.+)\.lease$/;
138 0           $leasefile_re2 = qr/^dhclient6\.(.+)\.leases$/;
139             }
140             } else {
141 0           die "Unknown AF! '$af'";
142             }
143              
144 0           my @paths_to_attempt;
145 0 0         if (ref($path) eq "ARRAY") {
146 0           @paths_to_attempt = @$path;
147             } else {
148 0           @paths_to_attempt = ($path);
149             }
150 0           foreach my $lease_path (@paths_to_attempt) {
151 0 0 0       next if (! -d $lease_path || ! -X $lease_path);
152 0 0         opendir(my $dh, $lease_path) or
153             die "Cannot read lease directory $lease_path. Error: $!";
154 0           my @all_files = readdir($dh);
155 0 0         @isc_lease_files = grep { /$leasefile_re1/ && -f "$lease_path/$_" } @all_files;
  0            
156 0 0         @isc_lease_files = grep { /$leasefile_re2/ && -f "$lease_path/$_" } @all_files if (!@isc_lease_files);
  0 0          
157 0 0         @netplan_lease_files = grep { /$leasefile_re3/ && -f "$lease_path/$_" } @all_files if ($leasefile_re3);
  0 0          
158 0           closedir($dh);
159              
160 0 0         if (@isc_lease_files) {
161 0           @isc_lease_files = map("$lease_path/$_", @isc_lease_files);
162             }
163 0 0         if (@netplan_lease_files) {
164 0           @netplan_lease_files = map("$lease_path/$_", @netplan_lease_files);
165             }
166 0 0 0       last if (@isc_lease_files || @netplan_lease_files);
167             }
168              
169 0           for my $leaseFile (@isc_lease_files) {
170 0 0         open (LEASEFILE, $leaseFile) or
171             die "Cannot open leasefile $leaseFile. Error: $!";
172              
173 0           my $currentLease;
174 0           my $hasIscLeaseData = 0;
175 0           my $ia_type = [];
176 0           while () {
177 0           chomp();
178 0 0         if (/^lease? \{/) {
179 0           $hasIscLeaseData = 1;
180 0           $currentLease = Net::ISC::DHCPClient::InetLease->new();
181 0           next;
182             }
183 0 0         if (/^lease6 \{/) {
184 0           $hasIscLeaseData = 1;
185 0           $currentLease = Net::ISC::DHCPClient::Inet6Lease->new();
186 0           next;
187             }
188 0 0         if (/^\}/) {
189             # dhclient will append lease information, newest is last.
190             # unshift() will place newest first.
191 0 0         unshift(@$leases, $currentLease) if ($hasIscLeaseData);
192 0           $hasIscLeaseData = 0;
193 0           next;
194             }
195              
196 0 0         if (!$hasIscLeaseData) {
197 0           next;
198             }
199              
200 0           s/^\s+//; # Eat starting whitespace
201 0 0         $self->_isc_af_inet_lease_parser($currentLease, $_) if ($af eq 'inet');
202 0 0         $self->_isc_af_inet6_lease_parser($currentLease, $ia_type, $_) if ($af eq 'inet6');
203             } # end while ()
204 0           close (LEASEFILE);
205             }
206              
207 0           for my $leaseFile (@netplan_lease_files) {
208 0 0         open (LEASEFILE, $leaseFile) or
209             die "Cannot open leasefile $leaseFile. Error: $!";
210              
211 0           my $currentLease;
212 0           my $ia_type = [];
213 0           while () {
214 0           chomp();
215 0 0         next if (!/^([^=]+)=(.*)$/);
216              
217 0           my $freshLease = 0;
218 0 0         if (!$currentLease) {
219 0           $currentLease = Net::ISC::DHCPClient::InetLease->new();
220 0           $freshLease = 1;
221             }
222 0 0         $self->_netplan_af_inet_lease_parser($currentLease, $1, $2) if ($af eq 'inet');
223 0 0         if ($freshLease) {
224             # Netplan lease file doesn't have interface information in
225             # the file. Parse the filename for interface.
226 0 0         if ($leaseFile =~ /-([^-.]+)\.lease$/) {
227 0           $currentLease->{INTERFACE} = $1;
228             }
229             }
230             } # end while ()
231 0           close (LEASEFILE);
232              
233             # There will be only 1 lease in the netplan lease file
234 0 0         unshift(@$leases, $currentLease) if ($currentLease);
235             }
236              
237 0           return $leases;
238             }
239              
240             sub _isc_af_inet_lease_parser($$$)
241             {
242 0     0     my ($self, $currentLease, $line) = @_;
243              
244             SWITCH: {
245             # interface "eth1";
246 0 0         /^interface\s+"(.+)";/ && do {
  0            
247 0           $currentLease->{INTERFACE} = $1;
248 0           last SWITCH;
249             };
250             # fixed-address 213.28.228.27;
251 0 0         /^fixed-address\s+(.+);/ && do {
252 0           $currentLease->{FIXED_ADDRESS} = $1;
253 0           last SWITCH;
254             };
255             # option subnet-mask 255.255.255.0;
256 0 0         (/^option\s+(\S+)\s*(.+);/) && do {
257 0           $currentLease->{OPTION}{$1} = $2;
258 0           last SWITCH;
259             };
260             # renew 5 2002/12/27 06:25:31;
261 0 0         (m#^renew\s+(\d+)\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);#) && do {
262 0           my $leaseTime = timegm($7, $6, $5, $4, $3-1, $2);
263 0           $currentLease->{RENEW} = $leaseTime;
264 0           last SWITCH;
265             };
266             # rebind 5 2002/12/27 06:25:31;
267 0 0         (m#^rebind\s+(\d+)\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);#) && do {
268 0           my $leaseTime = timegm($7, $6, $5, $4, $3-1, $2);
269 0           $currentLease->{REBIND} = $leaseTime;
270 0           last SWITCH;
271             };
272             # renew 5 2002/12/27 06:25:31;
273 0 0         (m#^expire\s+(\d+)\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);#) && do {
274 0           my $leaseTime = timegm($7, $6, $5, $4, $3-1, $2);
275 0           $currentLease->{EXPIRE} = $leaseTime;
276 0           last SWITCH;
277             };
278             }
279             }
280              
281             sub _isc_af_inet6_lease_parser($$$$)
282             {
283 0     0     my ($self, $currentLease, $ia_type, $line) = @_;
284              
285 0           my $context = '';
286 0           my $addr = '';
287 0 0         $context = $ia_type->[0] if (defined($ia_type->[0]));
288 0 0         $addr = $ia_type->[1] if (defined($ia_type->[1]));
289              
290             SWITCH: {
291             # interface "eth1";
292 0 0         /^interface\s+"(.+)";/ && do {
  0            
293 0           $currentLease->{INTERFACE} = $1;
294 0           last SWITCH;
295             };
296 0 0         /^ia-na\s+(\S+)\s*\{/ && do {
297             # Identity Association: Non-temporary Address
298 0           push(@$ia_type, 'non-temporary');
299 0           $currentLease->{IA}->{'non-temporary'} = {};
300 0           last SWITCH;
301             };
302 0 0         /^ia-pd\s+(\S+)\s*\{/ && do {
303             # Identity Association: Prefix Delegation
304 0           push(@$ia_type, 'prefix');
305 0           $currentLease->{IA}->{'prefix'} = {};
306 0           last SWITCH;
307             };
308 0 0         /^\}/ && do {
309 0           pop(@$ia_type);
310 0           last SWITCH;
311             };
312             # starts 1517742816;
313             # Note: either IA or address
314 0 0         /^(starts)\s+(\d+);/ && do {
315 0 0         if (defined($ia_type->[1])) {
316 0           $currentLease->{IA}->{$context}->{$addr}->{$1} = $2;
317             } else {
318 0           $currentLease->{IA}->{$context}->{$1} = $2;
319             }
320 0           last SWITCH;
321             };
322             # renew 302400;
323 0 0         /^(renew)\s+(\d+);/ && do {
324 0           $currentLease->{IA}->{$context}->{$1} = $2;
325 0           last SWITCH;
326             };
327             # rebind 483840;
328 0 0         /^(rebind)\s+(\d+);/ && do {
329 0           $currentLease->{IA}->{$context}->{$1} = $2;
330 0           last SWITCH;
331             };
332             # preferred-life 604800;
333 0 0         /^(preferred-life)\s+(\d+);/ && do {
334 0           $currentLease->{IA}->{$context}->{$addr}->{$1} = $2;
335 0           last SWITCH;
336             };
337             # max-life 2592000;
338 0 0         /^(max-life)\s+(\d+);/ && do {
339 0           $currentLease->{IA}->{$context}->{$addr}->{$1} = $2;
340 0           last SWITCH;
341             };
342 0 0         /^(iaaddr)\s+(\S+)\s*\{/ && do {
343             # Identity Association Address
344 0           push(@$ia_type, $1);
345 0           $currentLease->{IA}->{$context}->{$1}->{addr} = $2;
346 0           last SWITCH;
347             };
348 0 0         /^(iaprefix)\s+(\S+)\s*\{/ && do {
349             # Identity Association Prefix
350 0           push(@$ia_type, $1);
351 0           $currentLease->{IA}->{$context}->{$1}->{addr} = $2;
352 0           last SWITCH;
353             };
354 0 0         /^option\s+dhcp6\.(\S+)\s+(.+)$/ && do {
355             # option dhcp6.
356             # Collect only global options, skip the IA options
357 0 0         $currentLease->{OPTION}->{$1} = $2 if (!$context);
358 0           last SWITCH;
359             };
360             }
361             }
362              
363             sub _netplan_af_inet_lease_parser($$$$)
364             {
365 0     0     my ($self, $currentLease, $variable, $value) = @_;
366              
367             SWITCH: {
368             # ADDRESS=62.248.219.173
369 0 0         $variable eq "ADDRESS" && do {
  0            
370 0           $currentLease->{FIXED_ADDRESS} = $value;
371 0           last SWITCH;
372             };
373             # NETMASK=255.255.255.0
374 0 0         $variable eq "NETMASK" && do {
375 0           $currentLease->{OPTION}{'subnet-mask'} = $value;
376 0           last SWITCH;
377             };
378             # ROUTER=62.248.219.1
379 0 0         $variable eq "ROUTER" && do {
380 0           $currentLease->{OPTION}{'routers'} = $value;
381 0           last SWITCH;
382             };
383             # SERVER_ADDRESS=195.74.3.56
384 0 0         $variable eq "SERVER_ADDRESS" && do {
385 0           $currentLease->{OPTION}{'dhcp-server-identifier'} = $value;
386 0           last SWITCH;
387             };
388             # DNS=195.197.54.100 212.54.0.3
389 0 0         $variable eq "DNS" && do {
390             # Have the IP-list comma separated
391 0           $currentLease->{OPTION}{'domain-name-servers'} = ($value =~ s/ +/,/gr);
392 0           last SWITCH;
393             };
394             # NTP=193.66.253.102 193.66.253.82
395 0 0         $variable eq "NTP" && do {
396             # Have the IP-list comma separated
397 0           $currentLease->{OPTION}{'ntp-servers'} = ($value =~ s/ +/,/gr);
398 0           last SWITCH;
399             };
400             # DOMAINNAME=elisa-laajakaista.fi
401 0 0         $variable eq "SERVER_ADDRESS" && do {
402 0           $currentLease->{OPTION}{'domain-name'} = $value;
403 0           last SWITCH;
404             };
405             # T1=3600
406 0 0         $variable eq "T1" && do {
407             # Take current time, and add the value on it.
408             # Nowhere near the actual value, but it's better than nothing!
409 0           my $leaseTime = time() + int($value);
410 0           $currentLease->{RENEW} = $leaseTime;
411 0           last SWITCH;
412             };
413             # T2=6300
414 0 0         $variable eq "T2" && do {
415             # Take current time, and add the value on it.
416             # Nowhere near the actual value, but it's better than nothing!
417 0           my $leaseTime = time() + int($value);
418 0           $currentLease->{REBIND} = $leaseTime;
419 0           last SWITCH;
420             };
421             # LIFETIME=7200
422 0 0         $variable eq "LIFETIME" && do {
423             # Take current time, and add the value on it.
424             # Nowhere near the actual value, but it's better than nothing!
425 0           my $leaseTime = time() + int($value);
426 0           $currentLease->{OPTION}{'dhcp-lease-time'} = int($value);
427 0           $currentLease->{EXPIRE} = $leaseTime;
428 0           last SWITCH;
429             };
430             }
431             }
432              
433              
434             =head1 AUTHOR
435              
436             Jari Turkia, C<< >>
437              
438             =head1 BUGS
439              
440             Please report any bugs or feature requests to C, or through
441             the web interface at L. I will be notified, and then you'll
442             automatically be notified of progress on your bug as I make changes.
443              
444              
445              
446              
447             =head1 SUPPORT
448              
449             You can find documentation for this module with the perldoc command.
450              
451             perldoc Net::ISC::DHCPClient
452              
453              
454             You can also look for information at:
455              
456             =over 4
457              
458             =item * RT: CPAN's request tracker (report bugs here)
459              
460             L
461              
462             =item * AnnoCPAN: Annotated CPAN documentation
463              
464             L
465              
466             =item * CPAN Ratings
467              
468             L
469              
470             =item * Search CPAN
471              
472             L
473              
474             =back
475              
476              
477             =head1 ACKNOWLEDGEMENTS
478              
479              
480             =head1 LICENSE AND COPYRIGHT
481              
482             Copyright 2017 Jari Turkia.
483              
484             This program is free software; you can redistribute it and/or modify it
485             under the terms of the the Artistic License (2.0). You may obtain a
486             copy of the full license at:
487              
488             L
489              
490             Any use, modification, and distribution of the Standard or Modified
491             Versions is governed by this Artistic License. By using, modifying or
492             distributing the Package, you accept this license. Do not use, modify,
493             or distribute the Package, if you do not accept this license.
494              
495             If your Modified Version has been derived from a Modified Version made
496             by someone other than you, you are nevertheless required to ensure that
497             your Modified Version complies with the requirements of this license.
498              
499             This license does not grant you the right to use any trademark, service
500             mark, tradename, or logo of the Copyright Holder.
501              
502             This license includes the non-exclusive, worldwide, free-of-charge
503             patent license to make, have made, use, offer to sell, sell, import and
504             otherwise transfer the Package with respect to any patent claims
505             licensable by the Copyright Holder that are necessarily infringed by the
506             Package. If you institute patent litigation (including a cross-claim or
507             counterclaim) against any party alleging that the Package constitutes
508             direct or contributory patent infringement, then this Artistic License
509             to you shall terminate on the date that such litigation is filed.
510              
511             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
512             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
513             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
514             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
515             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
516             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
517             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
518             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
519              
520              
521             =cut
522              
523              
524             # vim: tabstop=4 shiftwidth=4 softtabstop=4 expandtab:
525              
526             1; # End of Net::ISC::DHCPClient