File Coverage

blib/lib/XML/Pastor/SimpleType.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

use utf8;
use strict;
use warnings;
no warnings qw(uninitialized);

#======================================================
package XML::Pastor::SimpleType;

use XML::LibXML;
use XML::Pastor::Type;

use Scalar::Util qw(reftype);
use XML::Pastor::Util  qw(getAttributeHash getChildrenHashDOM);

our @ISA = qw(XML::Pastor::Type);





#----------------------------------------------
# xml_validate_value
#----------------------------------------------
sub xml_validate_value {
	my $self 	= shift;
	my $path	= shift || '';
	my $type	= $self->XmlSchemaType();
	my $value	= $self->__value;
	    $value	= $self->normalize_whitespace($value);

	unless (defined $type) {
		return ($self->xml_validate_further(@_) && $self->xml_validate_ancestors(@_));
	}

	if (defined(my $prop = $type->length)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $len (@$prop) {
			($len == length($value)) or die "Pastor : Validate : $path : Length must be exactly '$len' for value '$value'";
		}
	}

	if (defined(my $prop = $type->minLength)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $minLen (@$prop) {
			(length($value) >= $minLen) or die "Pastor : Validate : $path : Length must be minimum '$minLen' for value '$value'";
		}
	}

	if (defined(my $prop = $type->maxLength)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $maxLen (@$prop) {
			(length($value) <= $maxLen) or die "Pastor : Validate : $path : Length must be maximum '$maxLen' for value '$value'";
		}
	}

	if (defined(my $prop = $type->regex)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		my $pass=0;
		foreach my $regex (@$prop) {
			if ($value =~ /$regex/) {
				$pass =1;
				last;
			}
		}
		$pass or die "Pastor : Validate : $path : Value does not match any of the given regexes. Value is '$value'";
	}

	if (defined(my $prop = $type->pattern)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		my $pass=0;
		foreach my $pattern (@$prop) {
			if ($value =~ /$pattern/) {
				$pass =1;
				last;
			}
		}
		$pass or die "Pastor : Validate : $path : Value does not match any of the given patterns. Value is '$value'";
	}


	if (defined(my $enumeration = $type->enumeration)) {
		(exists $enumeration->{$value}) or die "Pastor : Validate : $path : Not in the permitted enumeration : value '$value'";
	}


	if (defined(my $prop = $type->minInclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $min (@$prop) {
			($value >= $min) or die "Pastor : Validate : $path : Value must be at least (minimum) '$min' : But value is '$value'";
		}
	}

	if (defined(my $prop = $type->maxInclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $max (@$prop) {
			($value <= $max) or die "Pastor : Validate : $path : Value must be at most (maximum) '$max' : But value is '$value'";
		}
	}

	if (defined(my $prop = $type->minExclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $min (@$prop) {
			($value > $min) or die "Pastor : Validate : $path : Value must be greater than '$min' : But value is '$value'";
		}
	}

	if (defined(my $prop = $type->maxExclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $max (@$prop) {
			($value < $max) or die "Pastor : Validate : $path : Value must be less than '$max' : But value is '$value'";
		}
	}


	# Digits part is shamelessly copied from XML::Validator::Schema by Sam Tregar
   if (defined($type->totalDigits) || defined($type->fractionDigits)) {
        # strip leading and trailing zeros for numeric constraints
        my $digits = $value;
        $digits  =~ s/^([+-]?)0*(\d*\.?\d*?)0*$/$1$2/g;

        if (defined(my $prop=$type->totalDigits)) {
			$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
            foreach my $tdigits (@$prop) {
                die "Pastor : Validate : $path : Value has more total digits than the allowed '$tdigits'"
                  if $digits =~ tr!0-9!! > $tdigits;
            }
        }

        if (defined(my $prop=$type->fractionDigits)) {
			$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
            foreach my $fdigits (@$prop) {
                die "Pastor : Validate : $path : Value has more fraction digits than the allowed '$fdigits'"
                  if $digits =~ /\.\d{$fdigits}\d/;
            }
        }
    }


	return 1;
}



#-----------------------------------------------------------------------------
# By default, this just returns TRUE. But it could be overriden by descendants (like 'date').
#-----------------------------------------------------------------------------
sub xml_validate_further {
	return 1;
}


#-----------------------------------------------------------------------------
# Validate the ancestors. Base classes need to be validated.
#-----------------------------------------------------------------------------
sub xml_validate_ancestors {
	my $self	= shift;
	my $value	= $self->__value;
	my @ancestors = $self->get_ancestors();

	foreach my $class (@ancestors) {
		next unless (UNIVERSAL::can($class, 'new') && UNIVERSAL::can($class, 'xml_validate'));

		my $obj=$class->new(__value => $value);
		return 0 unless $obj->xml_validate(@_);
	}

	return 1;
}


#-----------------------------------------------------------------------------
# Normalize white space.
#-----------------------------------------------------------------------------
sub normalize_whitespace {
    my $self 	= shift;
    my $value 	= shift;
	my $type	= $self->XmlSchemaType();

	if (defined($type) and defined(my $prop = $type->whiteSpace)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $ws (@$prop) {
	        if ($ws =~ /^replace$/i) {
    	        $value =~ s![\t\n\r]! !g;
        	} elsif ($ws =~ /^collapse$/i) {
            	$value =~ s!\s+! !g;
	            $value =~ s!^\s!!g;
    	        $value =~ s!\s$!!g;
        	}
	        return $value;	# only the first one gets treated!
		}
	}else {
		my @ancestors = $self->get_ancestors();
		foreach my $class(@ancestors) {
			next unless UNIVERSAL::can($class, 'normalize_whitespace') && UNIVERSAL::can($class, 'new');
			my $object = $class->new(__value=>$value);
			my $nvalue = $object->normalize_whitespace($value);

			return $nvalue if ($nvalue ne $value);
		}
	}

    return $value;
}

1;

__END__