File Coverage

lib/POE/Filter/DHCPd/Lease.pm

Criterion	Covered	Total	%
statement	60	62	96.7
branch	19	26	73.0
condition	3	3	100.0
subroutine	14	15	93.3
pod	5	5	100.0
total	101	111	90.9

package POE::Filter::DHCPd::Lease;

=head1 NAME

POE::Filter::DHCPd::Lease - parses leases from isc dhcpd leases file

=head1 VERSION

0.0703

=cut

our $VERSION = '0.0703';

use strict;
use warnings;
use base qw/POE::Filter/;
use Time::Local;
use constant BUFFER => 0;
use constant LEASE  => 1;
use v5.10;

our $DATE    = qr# (\d{4})/(\d\d)/(\d\d) \s (\d\d):(\d\d):(\d\d) #mx;
our $START   = qr#^ lease \s ([\d\.]+) \s \{ #mx;
our $END     = qr# } [\n\r]+ #mx;
our $PARSER  = qr / (?: (?starts) \s\d+\s (?.+?)
                    | (?ends)    \s\d+\s (?.+?)
                    | ^\s*(?binding) \s state \s (?\S+)
                    | ^\s*(?next) \s binding \s state \s (?\S+)
                    | hardware \s (?ethernet) \s (?\S+)
                    | option \s agent.(?remote-id) \s (?.+?)
                    | option \s agent.(?circuit-id) \s (?.+?)
                    | client-(?hostname) \s "(?[^"]+)"
                    ) /mx;

=head1 METHODS

=head2 new

 my $filter = POE::Filter::DHCPd::Lease->new;

=cut

sub new {
    my $class = shift;
    return bless [ q(), undef ], $class;
}

=head2 get_one_start

 $self->get_one_start($stream);

C<$stream> is an array-ref of data, that will eventually be parsed into a
qualified lease, returned by L or L.

=cut

sub get_one_start {
    my $self = shift;
    my $data = shift; # array-ref of data

    $self->[BUFFER] .= join '', @$data;
    return;
}

=head2 get_one

 $leases = $self->get_one;

C<$leases> is an array-ref, containing zero or one leases.

 starts      => epoch value
 ends        => epoch value
 binding     => "active" or "free"
 hw_ethernet => 12 chars, without ":"
 hostname    => the client hostname
 circuit_id  => circuit id from relay agent (option 82)
 remote_id   => remote id from relay agent (option 82)

=cut

sub get_one {
    my $self = shift;
    # look for as many lines as we can find in the current buffer
    while(1) {
        my $string;
        # look for lines with \r\n endings
        if($self->[BUFFER] =~ /^(.*?\x0d?\x0a)/s) {
            my $length = length $1;
            $string = substr($self->[BUFFER],0,$length,'');
        }

        return [] unless $string;

        if(!$self->[LEASE] and $string =~ /$START/) {
            $self->[LEASE] = { ip => $1 };
        } elsif ($self->[LEASE]) {
            if ($string =~ /$PARSER;/) {
                $self->[LEASE]{$+{name}} =  $+{value};
            } elsif($string =~ /.*?$END/) {
                return $self->_done();
            }
        }

    }

    return [];
}

sub _done {
    my $self = shift;

    my $lease = delete $self->[LEASE];

    for my $k (qw/starts ends/) {
        next unless($lease->{$k});
        if(my @values = $lease->{$k} =~ $DATE) {
            $values[1]--; # decrease month
            $lease->{$k} = timelocal(reverse @values);
        }
    }

    if(my $mac =  _mac(delete $lease->{'ethernet'})) {
        $lease->{'hw_ethernet'} = $mac;
    }
    # compatibility with old parser output
    $lease->{'circuit_id'} = delete $lease->{'circuit-id'} if ($lease->{'circuit-id'});
    $lease->{'remote_id'} = delete $lease->{'remote-id'} if ($lease->{'remote-id'});

    return [ $lease ];

}

sub _mac {
    my $str = shift or return;

    $str =  join "", map { sprintf "%02s", $_ } split /:/, $str;
    $str =~ tr/[0-9a-fA-F]//cd;

    return length $str == 12 ? lc($str) : undef;
}

=head2 get

See L.

=head2 put

Returns an empty string. Should not be used.

=cut

sub put {
    return q();
}

=head2 get_pending

 my $buffer = $self->get_pending;

Returns any data left in the buffer.

=cut

sub get_pending {
    return shift->[BUFFER];
}

=head1 AUTHOR

Jan Henning Thorsen, C<<  >>

=head1 COPYRIGHT & LICENSE

Copyright 2007 Jan Henning Thorsen, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;