File Coverage

blib/lib/BigIP/ParseConfig.pm

Criterion	Covered	Total	%
statement	12	146	8.2
branch	0	56	0.0
condition	0	44	0.0
subroutine	4	30	13.3
pod	22	22	100.0
total	38	298	12.7

package BigIP::ParseConfig;

# BigIP::ParseConfig, F5/BigIP configuration parser
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.

our $VERSION = '1.1.9';
my  $AUTOLOAD;



use warnings;
use strict;



# Initialize the module
sub new {
    my $class = shift;

    my $self = {};
    bless $self, $class;

    $self->{'ConfigFile'} = shift;

    return $self;
}

# Return a list of objects
sub monitors   { return shift->_objectlist( 'monitor' ); }
sub nodes      { return shift->_objectlist( 'node' ); }
sub partitions { return shift->_objectlist( 'partition' ); }
sub pools      { return shift->_objectlist( 'pool' ); }
sub profiles   { return shift->_objectlist( 'profile' ); }
sub routes     { return shift->_objectlist( 'route' ); }
sub rules      { return shift->_objectlist( 'rule' ); }
sub users      { return shift->_objectlist( 'user' ); }
sub virtuals   { return shift->_objectlist( 'virtual' ); }

# Return an object hash
sub monitor    { return shift->_object( 'monitor', shift ); }
sub node       { return shift->_object( 'node', shift ); }
sub partition  { return shift->_object( 'partition', shift ); }
sub pool       { return shift->_object( 'pool', shift ); }
sub profile    { return shift->_object( 'profile', shift ); }
sub route      { return shift->_object( 'route', shift ); }
sub rule       { return shift->_object( 'rule', shift ); }
sub user       { return shift->_object( 'user', shift ); }
sub virtual    { return shift->_object( 'virtual', shift ); }

# Return a list of pool members
sub members {
    my $self = shift;
    my $pool = shift;

    $self->{'Parsed'} ||= $self->_parse();

    return 0 unless $self->{'Parsed'}->{'pool'}->{$pool}->{'members'};

    if ( ref $self->{'Parsed'}->{'pool'}->{$pool}->{'members'} eq 'ARRAY' ) {
        return @{$self->{'Parsed'}->{'pool'}->{$pool}->{'members'}};
    }
    else {
        return $self->{'Parsed'}->{'pool'}->{$pool}->{'members'};
    }
}

# Modify an object
sub modify {
    my $self = shift;

    my ( $arg );
    %{$arg} = @_;

    return 0 unless $arg->{'type'} && $arg->{'key'};

    my $obj = $arg->{'type'};
    my $key = $arg->{'key'};
    delete $arg->{'type'};
    delete $arg->{'key'};

    $self->{'Parsed'} ||= $self->_parse();

    return 0 unless $self->{'Parsed'}->{$obj}->{$key};

    foreach my $attr ( keys %{$arg} ) {
        next unless $self->{'Parsed'}->{$obj}->{$key}->{$attr};
        $self->{'Modify'}->{$obj}->{$key}->{$attr} = $arg->{$attr};
    }

    return 1;
}

# Write out a new configuration file
sub write {
    my $self = shift;
    my $file = shift || $self->{'ConfigFile'};

    die "No changes found; no write necessary" unless $self->{'Modify'};

    foreach my $obj ( qw( self partition route user monitor auth profile node pool rule virtual ) ) {
        foreach my $key ( sort keys %{$self->{'Parsed'}->{$obj}} ) {
            if ( $self->{'Modify'}->{$obj}->{$key} ) {
                $self->{'Output'} .= "$obj $key {\n";
                foreach my $attr ( $self->_order( $obj ) ) {
                    next unless $self->{'Parsed'}->{$obj}->{$key}->{$attr};
                    $self->{'Modify'}->{$obj}->{$key}->{$attr} ||= $self->{'Parsed'}->{$obj}->{$key}->{$attr};
                    if ( ref $self->{'Modify'}->{$obj}->{$key}->{$attr} eq 'ARRAY' ) {
                        if ( @{$self->{'Modify'}->{$obj}->{$key}->{$attr}} > 1 ) {
                            $self->{'Output'} .= "   $attr\n";
                            foreach my $val ( @{$self->{'Modify'}->{$obj}->{$key}->{$attr}} ) {
                                $self->{'Output'} .= "      $val\n";
                                if ( $self->{'Parsed'}->{$obj}->{$key}->{'_xtra'}->{$val} ) {
                                    $self->{'Output'} .= '         ' . $self->{'Parsed'}->{$obj}->{$key}->{'_xtra'}->{$val}  . "\n";
                                }
                            }
                        }
                        else {
                            $self->{'Output'} .= "   $attr " . $self->{'Modify'}->{$obj}->{$key}->{$attr}[0] . "\n";
                        }
                    }
                    else {
                        $self->{'Output'} .= "   $attr " . $self->{'Modify'}->{$obj}->{$key}->{$attr} . "\n";
                    }
                }
                $self->{'Output'} .= "}\n";
            }
            else {
                $self->{'Output'} .= $self->{'Raw'}->{$obj}->{$key};
            }
        }
    }

    open FILE, ">$file" || return 0;
    print FILE $self->{'Output'};
    close FILE;

    return 1;
}



# Return an object hash
sub _object {
    my $self = shift;
    my $obj  = shift;
    my $var  = shift;

    $self->{'Parsed'} ||= $self->_parse();

    return $self->{'Parsed'}->{$obj}->{$var} || 0;
}

# Return a list of objects
sub _objectlist {
    my $self = shift;
    my $obj  = shift;

    $self->{'Parsed'} ||= $self->_parse();

    if ( $self->{'Parsed'}->{$obj} ) {
        return keys %{$self->{'Parsed'}->{$obj}};
    }
    else {
        return 0;
    }
}

# Define object attribute ordering
sub _order {
    my $self = shift;

    for ( shift ) {
        /auth/      && return qw( bind login search servers service ssl user );
        /monitor/   && return qw( default base debug filter mandatoryattrs password security username interval timeout manual dest recv send );
        /node/      && return qw( monitor screen );
        /partition/ && return qw( description );
        /pool/      && return qw( lb nat monitor members );
        /self/      && return qw( netmask unit floating vlan allow );
        /user/      && return qw( password description id group home shell role );
        /virtual/   && return qw( translate snat pool destination ip rules profiles persist );

        return 0;
    };
}

# Parse the configuration file
sub _parse {
    my $self = shift;
    my $file = shift || $self->{'ConfigFile'};

    die "File not found: $self->{'ConfigFile'}\n" unless -e $self->{'ConfigFile'};

    open FILE, $file || return 0;
    my @file = ;
    close FILE;

    my ( $data, $parsed );

    until ( !$file[0] ) {
        my $ln = shift @file;

        my ( $P );

        if ( $ln =~ /^(auth|monitor|node|partition|pool|profile|route|rule|self|user|virtual)\s+(.*)\s+{$/ ) {
            $data->{'obj'} = $1;
            $data->{'key'} = $2;
        }

        if ( $data->{'obj'} && $data->{'key'} ) {
            $self->{'Raw'}->{$data->{'obj'}}->{$data->{'key'}} .= $ln;

            if ( $ln =~ /^\s{3}(\w+)\s+(.+?)$/ ) {
                # Patch for older-styled pool syntax
                if ( $1 eq 'member' ) {
                    push @{$parsed->{$data->{'obj'}}->{$data->{'key'}}->{'members'}}, $2;
                    $self->{'ConfigVer'} ||= '9.2';
                    next;
                };
                $parsed->{$data->{'obj'}}->{$data->{'key'}}->{$1} = $2;
            }

            if ( $ln =~ /^\s{3}(\w+)$/ ) { $data->{'list'} = $1; }

            if ( $ln =~ /^\s{6}((\w+|\d+).+?)$/ && $data->{'list'} ) {
                no strict 'refs';
                push @{$parsed->{$data->{'obj'}}->{$data->{'key'}}->{$data->{'list'}}}, $1;
                use strict 'refs';

                $data->{'last'} = $1;
            }

            if ( $ln =~ /^\s{9}((\w+|\d+).+?)$/ && $data->{'list'} ) {
                $parsed->{$data->{'obj'}}->{$data->{'key'}}->{'_xtra'}->{$data->{'last'}} = $1;
            }
        }
    }

    # Fill in ill-formatted objects
    foreach my $obj ( keys %{$self->{'Raw'}} ) {
        foreach my $key ( keys %{$self->{'Raw'}->{$obj}} ) {
            $parsed->{$obj}->{$key} ||= $self->{'Raw'}->{$obj}->{$key};
        }
    }

    return $parsed;
}



1;