File Coverage

blib/lib/XML/Validator/Schema/SimpleTypeNode.pm

Criterion	Covered	Total	%
statement	15	68	22.0
branch	0	32	0.0
condition	0	14	0.0
subroutine	5	11	45.4
pod	0	6	0.0
total	20	131	15.2

package XML::Validator::Schema::SimpleTypeNode;
use base 'XML::Validator::Schema::Node';
use strict;
use warnings;

use XML::Validator::Schema::Util qw(_attr _err);
use Carp qw(confess);

=head1 NAME

XML::Validator::Schema::SimpleTypeNode

=head1 DESCRIPTION

Temporary node in the schema parse tree to represent a simpleType.

=cut

# Hash mapping facet names to allowable values
our %FACET_VALUE = (length =>         "nonNegativeInteger",
                    minLength =>      "nonNegativeInteger",
                    maxLength =>      "nonNegativeInteger",
                    totalDigits =>    "positiveInteger",
                    fractionDigits => "nonNegativeInteger");

sub parse {
    my ($pkg, $data) = @_;
    my $self = $pkg->new();

    my $name = _attr($data, 'name');
    $self->name($name) if $name;

    $self->{restrictions} = {};

    return $self;
}

sub parse_restriction {
    my ($self, $data) = @_;

    my $base = _attr($data, 'base');
    _err("Found restriction without required 'base' attribute.")
      unless $base;
    $self->{base} = $base;
}

sub parse_facet {
    my ($self, $data) = @_;
    my $facet = $data->{LocalName};

    my $value = _attr($data, 'value');
    _err("Found facet <$facet> without required 'value' attribute.")
      unless defined $value;
    $self->check_facet_value($facet, $value, $FACET_VALUE{$facet}) if defined $FACET_VALUE{$facet};

    push @{$self->{restrictions}{$facet} ||= []}, $value;
}

sub compile {
    my ($self) = shift;

    if ( $self->{mother}->{is_union} ) {
        my $mum=$self->{mother};
	$self->{name} = $mum->{name} .
 	                $mum->{next_instance};
        $self->{mother}->{next_instance} ++;
    }

    # If my only child is a union, everything is already compiled

    if ( $self->{got_union} ) {
        # all compilation done at lower level
        # it looks sort of inappropriate to return a string when
        # everything is expecting a SimpleType in here. But my view is that
        # a union isn't really a simpletype and it isn't appropriate to
        # handle a union directly in SimpleType.  This alerts ElementNode
        # to the fact that it has to do a little extra work.
        return 'union';
    }
    # compile a new type
    my $base = $self->root->{type_library}->find(name => $self->{base});
    my $type = $base->derive();

    # smoke 'em if you got 'em
    $type->{name} =  $self->{name} if $self->{name};

    # add restrictions
    foreach my $facet (keys %{$self->{restrictions}}) {
        foreach my $value (@{$self->{restrictions}{$facet}}) {
            if ($facet eq 'pattern') {
                $type->restrict($facet, qr/^$value$/);
            } else {
                $type->restrict($facet, $value);
            }
        }
    }

    # register in the library if this is a named type
    $self->root->{type_library}->add(name => $self->{name},
                                     obj  => $type)
      if $self->{name};

    if ( $self->{mother}->{is_union} ) {
        # update great-gran with this simple type member
        # However this node is a SimpleTypeNode, and to make simple
        # re-use of 'check' possible in ElementNode, what we should
        # be pushing is an ElementNode

        my $gg = $self->{mother}->{mother}->{mother};
        # Make a new elementnode to stuff into members
        my $mbr = XML::Validator::Schema::ElementNode->new();

        $mbr->{type} = $type;
        # make this simpletype the daughter of the new member element:
        $mbr->add_daughter($self);
        push(@{$gg->{members}},$mbr);
    }

    return $type;
}

sub check_facet_value {
  my ($self, $facet, $value, $type_name) = @_;
  my ($ok, $msg) = $self->root->{type_library}->find(name => $type_name)->check($value);
  _err("Facet <$facet> value $value is not a $type_name")
    unless $ok;
}

sub check_constraints {
  my ($self) = @_;
  my $r = $self->{restrictions};

  # Schema Component Constraint: fractionDigits-totalDigits
  if (exists $r->{fractionDigits} && exists $r->{totalDigits}) {
    _err("Facet  value $r->{fractionDigits}[0] is greater than facet  value $r->{totalDigits}[0]")
      if ($r->{fractionDigits}[0] > $r->{totalDigits}[0]);
  }

  # Schema Component Constraint: length-minLength-maxLength
  _err("Facet  is defined in addition to facets  or ")
    if (exists $r->{length} && (exists $r->{minLength} || exists $r->{maxLength}));

  # Schema Component Constraint: minLength-less-than-equal-to-maxLength
  if (exists $r->{minLength} && exists $r->{maxLength}) {
    _err("Facet  value $r->{minLength}[0] is greater than than facet  value $r->{maxLength}[0]")
      if ($r->{minLength}[0] > $r->{maxLength}[0]);
  }
}

1;