File Coverage

blib/lib/Mon/Protocol.pm

Criterion	Covered	Total	%
statement	9	131	6.8
branch	0	32	0.0
condition	0	17	0.0
subroutine	3	16	18.7
pod	10	10	100.0
total	22	206	10.6

=head1 NAME

Mon::Protocol - Methods for parsing / dumping a protocol block

=head1 SYNOPSIS

    use Mon::Protocol;

=head1 DESCRIPTION


=head1 METHODS

=over 4

=item new

Creates a new object. A hash can be supplied which sets the
default values. An example which contains all of the variables
that you can initialize:

    $c = new Mon::Protocol;

=item dump_data

Returns the current internal structure as a string dump suitable for passing
to C.

=item C

Parses a command block (from begin_block to end_block), as generated by
dump_data.

=item C(I)

Sets or returns the type of the current command block. See @TYPES for valid
type codes.

In the future, it is possible that this module will perform additional
checking based on the type, for now it is left to the application to interpret
this.

=item C

Returns an array containing all section names within the block.

=item C(I)

Returns a hash containing the key/value pairs of the specific section.

=item C(I)

Completely removes the specified section from the block.

=item C(I,I<$hash_ref>)

Adds the key/value pairs in the hash to the specified section.

	$foo->add_to_section("_hostgroup", { "ns1.baz.com" -> "ok" });

=item C(I,I<$key>)

Deletes the key/value pair from the section.

	$foo->delete_from_section("_hostgroup", "ns1.baz.com");

=item C

Should any of the functions return an error (-1), this function can be used to
retrieve a more elaborate error message and to reset the internal error state.

=back

=cut
#
# Perl module for parsing / dumping a mon protocol block
#
# $Id: Protocol.pm 1.3 Thu, 11 Jan 2001 08:42:17 -0800 trockij $
#
# Copyright (C) 1999 Lars Marowsky-Brée
#
#    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.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#

package Mon::Protocol;
require Exporter;
require 5.004;
use IO::File;
use Socket;
use Text::ParseWords;

sub new;
sub dump_data;
sub parse_data;
sub type;
sub get_section;
sub get_section_list;
sub add_to_section;
sub delete_section;
sub delete_from_section;
sub error;
sub DESTROY;
sub _esc_str;
sub _un_esc_str;

@ISA = qw(Exporter);
@EXPORT_OK = qw($VERSION @);

$VERSION = "0.11";

@TYPES = qw(cmd_monitor cmd_alert cmd_logger res_monitor res_alert res_logger);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    my %vars = @_;

    $self->{'type'} = $vars{'type'} || "UNKNOWN";

    bless ($self, $class);
    return $self;
}


sub dump_data {
    my ($self) = shift;

    my ($tmp);

    $tmp.="begin_block=".$self->{'type'}."\n";

    my ($section);
    foreach $section (sort keys %{$self->{'data'}}) {
       $tmp.="begin=".$section."\n";

       my ($key,$data);

       while ( ($key,$data) = each %{$self->{'data'}->{$section}} ) {
	  $tmp .= "$key=". _esc_str ($data) . "\n";
       }
       $tmp.="end=".$section."\n";

    }

    $tmp.="end_block=".$self->{'type'}."\n";

    return $tmp;
}


sub parse_data {
    my ($self) = shift;

    my ($raw) = @_;
    my (@l) = split(/\n/o,$raw);

    my ($l,%tmp,$type);

    $l = shift @l;

    if ($l =~ /^begin_block=(\S+)$/oi) {
       $type = lc($1);
    } else {
       $self->{'error'} = "No begin_block found";
       return -1;
    }

    my ($section,$in_section) = ("",0);
LINE:    while ($l = shift @l) {
       next if ($l =~ /^\s*$/o);
       if ($in_section == 0) {
          if ($l =~ /^begin=(\S+)$/oi) {
	     $section = lc($1);
	     $in_section = 1;
	  } elsif ($l =~ /^end_block=(\S+)$/oi) {
	     if (lc($1) eq $type) {
	        $in_section = -1;
		last LINE;
	     } else {
	        $self->{'error'} = "end_block does not match begin.";
	        return -1;
	     }
	  } else {
	    $self->{'error'} = "Garbled input at global level.";
	    return -1;
	  }
       } else {
         if ($l =~ /^end=(\S+)$/oi) {
	    if (lc($1) eq $section) {
	       $in_section = 0;
	       $section = "";
	       next LINE;
	    } else {
	       $self->{'error'} = "end section does not match begin.";
	       return -1;
	    }
	 }

	 my ($key,$value);

	 if (($key,$value) = $l =~ /^([^=]+)=(.*)/o) {
	    $key = lc($key);
	    $tmp{$section}{$key} = _un_esc_str ($value);
	 } else {
	    $self->{'error'} = "Garbled input at section level: $l";
	    return -1;
	 }
       }

    }

    $self->{'type'} = $type;
    %{$self->{'data'}} = %tmp;

    return 0;
}

sub type {
    my ($self) = shift;

    if (@_) {
       my ($type) = lc(shift);

       if (grep($_ eq $type,@TYPES)) {
          $self->{'type'} = $type;
       } else {
          $self->{'type'} = "UNKNOWN";
	  $self->{'error'} = "Unknown type supplied.";
	  return -1;
       }
    }

    return $self->{'type'};
}

sub get_section {
    my ($self) = shift;
    my ($section) = lc(shift);

    if (defined($self->{'data'}->{$section})) {
       return %{$self->{'data'}->{$section}};
    } else {
       $self->{'error'} = "$section: No such section.";
       return -1;
    }
}

sub get_section_list {
    my ($self) = shift;
    return sort keys %{$self->{'data'}};
}

sub add_to_section {
    my ($self) = shift;

    my $section = lc(shift);
    my ($rdata) = @_;

    my ($key,$value);
    while ( ($key,$value) = each %$rdata) {
       $key = lc($key);
       $self->{'data'}->{$section}->{$key} = $value;
    }

    return 1;
}

sub delete_section {
    my ($self) = shift;
    my ($section) = lc(shift);

    if (defined($self->{'data'}->{$section})) {
       delete $self->{'data'}->{$section};
       return 0;
    } else {
       $self->{'error'} = "$section: No such section.";
       return -1;
    }
}

sub delete_from_section {
    my ($self) = shift;
    my ($section) = lc(shift);
    my ($key) = lc(shift);

    if (defined($self->{'data'}->{$section}->{$key})) {
       delete $self->{'data'}->{$section}->{$key};
       return 0;
    } else {
       $self->{'error'} = "$section/$key: No such key in section.";
       return -1;
    }
}

sub error {
    my ($self) = shift;
    my $err = $self->{'error'};
    $self->{'error'}= "";
    return $err;
}

sub DESTROY {
    my $self = shift;
}


#
# convert a string to a hex-escaped string, returning
# the escaped string.
#
# $str is the string to be escaped
# if $inquotes is true, backslashes are doubled, making
#       the escaped string suitable to be enclosed in
#       single quotes and later passed to Text::quotewords.
#       For example,   var='quoted value'
#
sub _esc_str {
    my $str = shift;
    my $inquotes = shift;

    my $escstr = "";

    for (my $i = 0; $i < length ($str); $i++)
    {
    	my $c = substr ($str, $i, 1);

	if (ord ($c) < 32 ||
	    ord ($c) > 126 ||
	    $c eq "\"" ||
	    $c eq "\'")
	{
	    $c = sprintf ("\\%02x", ord($c));
	}
	elsif ($inquotes && $c eq "\\")
	{
	    $c = "\\\\";
	}

	$escstr .= $c;
    }

    $escstr;
}


#
# convert a hex-escaped string into an unescaped string,
# returning the unescaped string
#
sub _un_esc_str {
    my $str = shift;

    $str =~ s{\\([0-9a-f]{2})}{chr(hex($1))}eg;

    $str;
}

1;