view release on metacpan or  search on metacpan

lib/Cisco/Reconfig.pm  view on Meta::CPAN

package Cisco::Reconfig;

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

$VERSION = '0.912';

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 $last;
	my $config = bless { $bloc => 1 }, __PACKAGE__;

	$config->{$debg} = "BLOCK:$dseq:$dcon" if $ddata;

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

	$dseq++;
	my $prev;
	my $ciscobug;
	for(;$line;$prev = $line, $line = <$fh>) {
		$_ = $line;
		s/^( *)//;
		my $in = length($1);
		s/^(no +)//;
		my $no = $1;
		if ($in > $indent) {
			if ($last) {
				$last->{$subs} = rc1($in, "$last->{$seqn}aaa", $last, $line);
				undef $last;
				redo if $line;
			} else {
				# This really shouldn't happen.  But it does.  It's a violation of
				# the usual indentation rules.
				#
				# An exclamation marks a reset of the indentation to zero.
				#
				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) {
			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;