view release on metacpan or  search on metacpan

lib/Ansible.pm  view on Meta::CPAN

package Ansible;

@ISA = qw( Exporter );
@EXPORT = qw( readconfig );
@EXPORT_OK = qw( readconfig stringconfig $minus_one_indent_rx );

$VERSION = '0.101';

require Exporter;
use strict;
use Text::Tabs;
use Carp;
use Carp qw( verbose confess );
use IO::File;
use Scalar::Util qw( weaken );
my $iostrings;
our $allow_minus_one_indent = qr/class /;
our $allow_plus_one_indent = qr/service-policy |quit$/;
our $bad_indent_policy = 'DIE';


BEGIN    {
    eval " use IO::String ";
    $iostrings = $@ ? 0 : 1;
}


my $debug_get = 0;
my $debug_mget = 0;
my $debug_set = 0;
my $debug_context = 0;
my $debug_text = 0;
my $ddata = $debug_get
            || $debug_mget
            || $debug_set
            || $debug_context
            || $debug_text
            || 0; # add debugging data to data structures

my $spec = qr{^ };
my $text = " text";
my $subs = " subs";
my $next = " next";
my $cntx = " cntx";
my $word = " word";
my $seqn = " seqn";
my $dupl = " dupl";
my $debg = " debg";
my $bloc = " bloc";
my $UNDEFDESC = "! undefined\n";
my $undef = bless { $debg => $UNDEFDESC, $text => '' }, __PACKAGE__;
my $dseq = "O0000000";
our $nonext;

my $line;
my $fh;

use overload
    'bool'     => \&defined,
    '""'       => \&text,
    'fallback' => 1;

sub stringconfig {
    Carp::croak 'IO::Strings need to be installed to use "stringconfig"'
                . ' install it or use "readconfig" instead.' unless $iostrings;
    readconfig(IO::String->new(join("\n", @_)));
}

sub readconfig {
    my ($file) = @_;
    $fh = ref($file) ? $file : IO::File->new($file, "r");
    $line = <$fh>;
    return rc1(0, 'aaaa', $undef, "! whole enchalada\n");
}

sub rc1 {
    my ($indent, $seq, $parent, $dcon) = @_;
    my $config = bless { $bloc => 1 }, __PACKAGE__;
    $config->{$debg} = "BLOCK:$dseq:$dcon" if $ddata;

    $config->{$cntx} = $parent;
    weaken $config->{$cntx};

    $dseq ++;
    my ($last, $prev, $ciscobug);
    for ( ; $line; $prev = $line, $line = <$fh> ) {
        $_ = $line;
        s/^( *)//;
        my $in = length($1);
        s/^(no +)//;
		#新行向右缩进
        if ( $in > $indent ) {
			#如果存在上下文，则将新行视为上一配置的子节点；
            if ( $last ) {
                $last->{$subs} = rc1($in, "$last->{$seqn}aaa", $last, $line);
                undef $last;
                redo if $line;
            }
            else {
				#正常缩进不会出现此情况，以下代码用来捕捉特例缩进代码
                if ( $indent + 1 == $in && $allow_plus_one_indent && $line =~ /^\s*$allow_plus_one_indent/ ) {
                    $indent = $indent + 1;
                    redo;
                }
                if ( $indent != 0 || ($prev ne "!\n" && $prev !~ /^!.*<removed>$/) ) {
                    if ( $bad_indent_policy eq 'IGNORE' ) {
                        # okay then
                    }
                    elsif ( $bad_indent_policy eq 'WARN' ) {
                        warn "Unexpected indentation change <$.:$_>";
                    }
                    else {
                        confess "Unexpected indentation change <$.:$_>";
                    }
                }
                $ciscobug = 1;
                $indent = $in;
            }
        }
		#新行想左缩进
        elsif ( $in < $indent ) {
			#匹配到异常缩进并且重写缩进为0
            if ( $ciscobug && $in == 0 ) {
                $indent = 0;
            }
			#存在上下文环境
            elsif ( $last && $indent - 1 == $in && $allow_minus_one_indent && $line =~ /^\s*$allow_minus_one_indent/ ) {
                confess unless $last->{$seqn};
                $last->{$subs} = rc1($in, "$last->{$seqn}aaa", $last, $line);
                undef $last;
                redo if $line;
            }
            else {
                return $config;
            }
        }
        next if /^$/;
        next if /^\s*!/;
        my $context = $config;
        my (@x) = split;
        my $owords = @x;
        while ( @x && ref $context->{$x[0]} ) {
            $context = $context->{$x[0]};
            shift @x;
        }
        if ( ! @x ) {
            # A duplicate line.  Not fun.
            # As far as we know this can only occur as a remark inside
            # filter list.
            # Q: what's the point of keeping track of these? Need to be
            # able to accurately dump filter list definitions
            #
            $context->{$dupl} = []
                unless $context->{$dupl};
            my $n = bless {
                              $ddata
                              ? ($debg => "$dseq:DUP:$line",
                                 $word => $context->{$word},)
                              : (),
                          }, __PACKAGE__;
            $dseq ++;

            push(@{ $context->{$dupl} }, $n);
            $context = $n;
        }
        elsif ( defined $context->{$x[0]} ) {
            confess "already $.: '$x[0]' $line";
        }
        while ( @x ) {
            my $x = shift @x;
            confess unless defined $x;
            confess unless defined $dseq;
            $line = "" unless defined $line;
            $context = $context->{$x} = bless {
                                                  $ddata
                                                  ? ($debg => "$dseq:$x:$line",
                                                     $word => $x,)
                                                  : (),
                                              }, __PACKAGE__;
            $dseq ++;
        }
        $context->{$seqn} = $seq ++;
        $context->{$text} = $line;
        confess if $context->{$cntx};

        $context->{$cntx} = $config;
        weaken $context->{$cntx};

        unless ( $nonext ) {
            if ( $last ) {
                $last->{$next} = $context;
                weaken $last->{$next};
            }
            else {
                $config->{$next} = $context;
                weaken $config->{$next};
            }
        }

        $last = $context;

        if ( $line &&
             ($line =~ /(\^C)/ && $line !~ /\^C.*\^C/)
             ||
             ($line =~ /banner [a-z\-]+ ((?!\^C).+)/) ) {
            #
            # big special case for banners 'cause they don't follow
            # normal indenting rules
            #
            die unless defined $1;
            my $sep = qr/\Q$1\E/;
            my $sub = $last->{$subs} = bless { $bloc => 1 }, __PACKAGE__;
            $sub->{$cntx} = $last;
            weaken $sub->{$cntx};
            my $subnull = $sub->{''} = bless { $bloc => 1, $dupl => [] }, __PACKAGE__;
            $subnull->{$cntx} = $sub;
            weaken $subnull->{$cntx};
            for ( ;; ) {
                $line = <$fh>;
                last unless $line;
                my $l = bless {
                                  $ddata ? ($debg => "$dseq:DUP:$line") : (),
                              }, __PACKAGE__;
                $dseq ++;
                $l->{$seqn} = $seq ++;
                $l->{$text} = $line;
                $l->{$cntx} = $subnull;
                weaken($l->{$cntx});
                push(@{ $subnull->{$dupl} }, $l);
                last if $line =~ /$sep[\r]?$/;
            }
            warn "parse probably failed"
                unless $line && $line =~ /$sep[\r]?$/;
        }
    }
    return $config;
}

#sub word { $_[0]->{$word} };
sub block { $_[0]->{$bloc} }
sub seqn { $_[0]->{$seqn} || $_[0]->endpt->{$seqn} || confess };
sub subs { $_[0]->{$subs} || $_[0]->zoom->{$subs} || $undef };
sub next { $_[0]->{$next} || $_[0]->zoom->{$next} || $undef };
#sub undefined { $_[0] eq $undef }
#sub defined { $_[0] ne $undef }
sub defined { $_[0]->{$debg} ? $_[0]->{$debg} ne $UNDEFDESC : 1 }

sub destroy {
    warn "Cisco::Reconfig::destroy is deprecated";
}

sub single {
    my ($self) = @_;
    return $self if defined $self->{$text};
    my (@p) = grep (! /$spec/o, keys %$self);
    return undef if @p > 1;
    return $self unless @p;
    return $self->{$p[0]}->single || $self;
}

sub kids {
    my ($self) = @_;
    return $self if ! $self;
    my (@p) = $self->sortit(grep (! /$spec/o, keys %$self));
    return $self if ! @p;
    return(map { $self->{$_} } @p);
}

sub zoom {
    my ($self) = @_;
    return $self if defined $self->{$text};
    my (@p) = $self->sortit(grep (! /$spec/o, keys %$self));
    return $self if @p > 1;
    return $self unless @p;
    return $self->{$p[0]}->zoom;
}

sub endpt {
    my ($self) = @_;
    return $self if ! $self;
    my (@p) = grep (! /$spec/o, keys %$self);
    return $self if defined($self->{$text}) && ! @p;
    confess unless @p;
    return $self->{$p[0]}->endpt;
}


sub text {