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   53297 use 5.014;
  1         3  
4 1     1   4 use strict;
  1         2  
  1         15  
5 1     1   4 use warnings;
  1         1  
  1         51  
6              
7              
8             =head1 NAME
9              
10             Net::ISC::DHCPClient - ISC dhclient lease reader
11              
12             =head1 VERSION
13              
14             Version 0.14
15              
16             =cut
17              
18             our $VERSION = '0.14';
19              
20              
21 1     1   355 use Net::ISC::DHCPClient::InetLease;
  1         3  
  1         24  
22 1     1   323 use Net::ISC::DHCPClient::Inet6Lease;
  1         2  
  1         23  
23 1     1   381 use Time::Local;
  1         1856  
  1         2106  
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 GitHub https://github.com/HQJaTu/Net-ISC-DHCPClient.
441             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
442              
443              
444              
445              
446             =head1 SUPPORT
447              
448             You can find documentation for this module with the perldoc command.
449              
450             perldoc Net::ISC::DHCPClient
451              
452              
453             You can also look for information at:
454              
455             =over 4
456              
457             =item * RT: CPAN's request tracker (report bugs here)
458              
459             L
460              
461             =item * AnnoCPAN: Annotated CPAN documentation
462              
463             L
464              
465             =item * CPAN Ratings
466              
467             L
468              
469             =item * Search CPAN
470              
471             L
472              
473             =back
474              
475              
476             =head1 ACKNOWLEDGEMENTS
477              
478              
479             =head1 LICENSE AND COPYRIGHT
480              
481             Copyright 2017 Jari Turkia.
482              
483             This program is free software; you can redistribute it and/or modify it
484             under the terms of the the Artistic License (2.0). You may obtain a
485             copy of the full license at:
486              
487             L
488              
489             Any use, modification, and distribution of the Standard or Modified
490             Versions is governed by this Artistic License. By using, modifying or
491             distributing the Package, you accept this license. Do not use, modify,
492             or distribute the Package, if you do not accept this license.
493              
494             If your Modified Version has been derived from a Modified Version made
495             by someone other than you, you are nevertheless required to ensure that
496             your Modified Version complies with the requirements of this license.
497              
498             This license does not grant you the right to use any trademark, service
499             mark, tradename, or logo of the Copyright Holder.
500              
501             This license includes the non-exclusive, worldwide, free-of-charge
502             patent license to make, have made, use, offer to sell, sell, import and
503             otherwise transfer the Package with respect to any patent claims
504             licensable by the Copyright Holder that are necessarily infringed by the
505             Package. If you institute patent litigation (including a cross-claim or
506             counterclaim) against any party alleging that the Package constitutes
507             direct or contributory patent infringement, then this Artistic License
508             to you shall terminate on the date that such litigation is filed.
509              
510             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
511             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
512             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
513             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
514             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
515             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
516             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
517             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
518              
519              
520             =cut
521              
522              
523             # vim: tabstop=4 shiftwidth=4 softtabstop=4 expandtab:
524              
525             1; # End of Net::ISC::DHCPClient