File Coverage

blib/lib/PPM/XML/ValidatingElement.pm

Criterion	Covered	Total	%
statement	6	97	6.1
branch	0	14	0.0
condition	0	3	0.0
subroutine	2	8	25.0
pod	6	6	100.0
total	14	128	10.9

package PPM::XML::ValidatingElement;
use PPM::XML::Element;
use vars qw( $VERSION @ISA );
$VERSION = '0.01_01';

###############################################################################
#
# PPM::XML::ValidatingElement
#
# Base class for validating elements.  Allows for applying DTD type
# restrictions to elements parsed using the XML::Parser module.
#
###############################################################################

###############################################################################
# Define the validating element class.
###############################################################################
@ISA = qw( PPM::XML::Element );

###############################################################################
# Recursively validate myself and all child elements with all four types of
# validation.  Returns non-zero on success and zero on any errors.
###############################################################################
sub rvalidate
{
    my $self = shift;
    my $func = shift;
    my $success = 1;

    $success &= $self->validate_possible_attrs( $func );
    $success &= $self->validate_required_attrs( $func );
    $success &= $self->validate_possible_kids( $func );
    $success &= $self->validate_required_kids( $func );

    foreach (@{$self->{Kids}})
    {
        if ((ref $_) !~ /::Characters$/o)
            { $success &= $_->rvalidate( $func ); }
    }

    return $success;
}

###############################################################################
# Validate the element with all four types of validation.  Returns non-zero on
# success any zero if any errors occurred.
###############################################################################
sub validate
{
    my $self = shift;
    my $func = shift;
    my $success = 1;

    $success &= $self->validate_possible_attrs( $func );
    $success &= $self->validate_required_attrs( $func );
    $success &= $self->validate_possible_kids( $func );
    $success &= $self->validate_required_kids( $func );

    return $success;
}

###############################################################################
# Validate possible attributes.  Returns non-zero on sucess, and zero if any
# errors occurred.
###############################################################################
sub validate_possible_attrs
{
    my $self = shift;
    my $func = shift;
    my $attr;
    my $type = ref $self;
    my $success = 1;

    my $elem = $type;
    $elem =~ s/.*:://;

    my @allattrs;
    push( @allattrs, @{"$type\::oattrs"}, @{"$type\::rattrs"} );

    # Check our list of attributes against the list of possible attributes we
    # can have.
    foreach $attr (keys %{$self})
    {
        if ( ($attr ne 'Kids') and ($attr ne 'Text') )
        {
            if (!grep( /^$attr$/, @allattrs ))
            {
                &$func( "Element '$elem' doesn't allow the '$attr' attribute." );
                $success = 0;
            }
        }
    }

    return $success;
}

###############################################################################
# Validate required attributes.  Returns non-zero on success and zero if any
# errors occurred.
###############################################################################
sub validate_required_attrs
{
    my $self = shift;
    my $func = shift;
    my $attr;
    my $type = ref $self;
    my $success = 1;

    my $elem = $type;
    $elem =~ s/.*:://;

    # Check the list of required attributes against the list of attributes
    # which were parsed.
    foreach $attr (@{"$type\::rattrs"})
    {
        if (!grep( /^$attr$/, (keys %{$self}) ))
        {
            &$func( "Element '$elem' must have a '$attr' attribute." );
            $success = 0;
        }
    }

    return $success;
}

###############################################################################
# Validate possible child elements.  Returns non-zero on success and zero if
# any errors occurred.
###############################################################################
sub validate_possible_kids
{
    my $self = shift;
    my $func = shift;
    my $kid;
    my $type = ref $self;
    my $success = 1;

    my $elem = $type;
    $elem =~ s/.*:://;

    my $base = $type;
    $base =~ s/::[^:]*?$//;

    my @allkids;
    push( @allkids, @{"$type\::okids"}, @{"$type\::rkids"} );

    foreach $kid (@{ $self->{Kids} })
    {
        my $kid_type = ref $kid;
        $kid_type =~ s/.*:://;
        next if ($kid_type eq 'Characters');    # Don't validate character data

        if (!grep( /^$kid_type$/, @allkids ))
        {
            &$func( "Element '$elem' cannot contain a child element '$kid_type'" );
            $success = 0;
        }
    }

    return $success;
}

###############################################################################
# Validate required child elements.  Returns non-zero on success and zero if
# any errors occurred.
###############################################################################
sub validate_required_kids
{
    my $self = shift;
    my $func = shift;
    my $kid;
    my $type = ref $self;
    my $success = 1;

    my $elem = $type;
    $elem =~ s/.*:://;

    my $base = $type;
    $base =~ s/::[^:]*?$//;

    foreach $kid (@{"$type\::rkids"})
    {
        my @kidlist = map( ref, @{$self->{Kids}} );

        if (!grep( /^$base\::$kid$/, @kidlist ))
        {
            &$func( "Element '$elem' must contain a '$kid' element." );
            $success = 0;
        }
    }

    return $success;
}

__END__