File Coverage

blib/lib/Treex/PML/Schema/Container.pm

Criterion	Covered	Total	%
statement	49	112	43.7
branch	4	46	8.7
condition	0	9	0.0
subroutine	17	26	65.3
pod	14	16	87.5
total	84	209	40.1

package Treex::PML::Schema::Container;

use strict;
use warnings;

use vars qw($VERSION);
BEGIN {
  $VERSION='2.24'; # version template
}
no warnings 'uninitialized';
use Carp;

use Treex::PML::Schema::Constants;
use base qw( Treex::PML::Schema::Decl );
use UNIVERSAL::DOES;
use Treex::PML::Factory;

=head1 NAME

Treex::PML::Schema::Container - implements declaration of a container.

=head1 INHERITANCE

This class inherits from L, but provides
several methods which make its interface largely compatible with
the C class.

=head1 METHODS

See the super-class for the complete list.

=over 3

=item $decl->get_decl_type ()

Returns the constant PML_CONTAINER_DECL.

=item $decl->get_decl_type_str ()

Returns the string 'container'.

=item $decl->get_content_decl ()

Return declaration of the content type.

=item $decl->is_atomic ()

Returns 0.

=cut

sub get_decl_type { return PML_CONTAINER_DECL; }
sub get_decl_type_str { return 'container'; }
sub is_atomic { 0 }

sub init {
  my ($self,$opts)=@_;
  $self->{-parent}{-decl} = 'container';
}
sub serialize_get_children {
  my ($self,$opts)=@_;
  my @children = $self->SUPER::serialize_get_children($opts);
  return ((grep { $_->[0] eq 'attribute' } @children),
	  (grep { $_->[0] ne 'attribute' } @children));
}

=item $decl->get_attributes ()

Return a list of the associated attribute declarations
(C).

=cut

sub get_attributes {
  my $members = $_[0]->{attribute};
  return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $_->{'-#'} ] } values %$members : ();
}

=item $decl->has_attributes ()

Return true if the container declares attributes.

=cut

sub has_attributes {
  my $members = $_[0]->{attribute};
  return $members ? scalar(%$members) : 0;
}


=item $decl->get_attribute_names ()

Return a list of names of attributes associated with the container.

=cut

sub get_attribute_names {
  my $members = $_[0]->{attribute};
  return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $members->{$_}->{'-#'} ] } keys %$members : ();
}

=item $decl->get_attribute_by_name (name)

Return the declaration of the attribute with a given name.

=cut

sub get_attribute_by_name {
  my ($self, $name) = @_;
  my $members = $_[0]->{attribute};
  return $members ? $members->{$name} : undef;
}

=item $decl->find_attributes_by_content_decl (decl)

Lookup and return those attribute declarations whose content
declaration is decl.

=cut

sub find_attributes_by_content_decl {
  my ($self, $decl) = @_;
  return grep { $decl == $_->get_content_decl } $self->get_attributes;
}

=item $decl->find_attributes_by_type_name (name)

Lookup and return those attribute declarations whose content is
specified via a reference to the named type with a given name.

=cut

sub find_attributes_by_type_name {
  my ($self, $type_name) = @_;
  # using directly $member->{type}
  return grep { $type_name eq $_->{type} } $self->get_attributes;
}

=item $decl->find_attributes_by_role (role)

Lookup and return declarations of all members with a given role.

=cut

sub find_attributes_by_role {
  my ($self, $role) = @_;
  # using directly $member->{role}
  return grep { $role eq $_->{role} } $self->get_attributes;
}

sub validate_object {
  my ($self, $object, $opts) = @_;

  my ($path,$tag,$flags);
  my $log = [];
  if (ref($opts)) {
    $flags = $opts->{flags};
    $path = $opts->{path};
    $tag = $opts->{tag};
    $path.="/".$tag if $tag ne q{};
  }

  if (not UNIVERSAL::isa($object,'HASH')) {
    push @$log, "$path: Unexpected container object (should be a HASH): $object";
  } else {
    my @attributes = $self->get_attributes;
    foreach my $attr (@attributes) {
      my $name = $attr->get_name;
      my $val = $object->{$name};
      my $adecl = $attr->get_content_decl;
      if ($attr->is_required or $val ne q{}) {
	if (ref($val)) {
	  push @$log, "$path/$name: invalid content for attribute: ".ref($val);
	} elsif ($adecl) {
	  $adecl->validate_object($val, {
	    flags => $flags,
	    path => $path,
	    tag => $name,
	    log => $log });
	}
      }
    }
    my $cdecl = $self->get_content_decl;
    if ($cdecl) {
      my $content = $object->{'#content'};
      my $skip_content = 0;
      if ($self->get_role eq '#NODE' and !($flags & PML_VALIDATE_NO_TREES)) {
	if (not UNIVERSAL::DOES::does($object,'Treex::PML::Node')) {
	  push @$log,"$path: container declared as #NODE should be a Treex::PML::Node object: $object";
	} else {
	  my $cdecl_is = $cdecl->get_decl_type;
	  if ($cdecl->get_role eq '#CHILDNODES') {
	    if ($content ne q{}) {
	      push @$log, "$path: #NODE container containing a #CHILDNODES should have empty #content: $content";
	    }
	    if ($flags & PML_VALIDATE_NO_CHILDNODES) {
	      $skip_content = 1;
	    } elsif ($cdecl_is == PML_SEQUENCE_DECL) {
	      $content = Treex::PML::Factory->createSeq([map { Treex::PML::Seq::Element->new($_->{'#name'},$_) } $object->children]);
	    } elsif ($cdecl_is == PML_LIST_DECL) {
	      $content = Treex::PML::Factory->createList([$object->children],1);
	    } else {
	      push @$log, "$path: #CHILDNODES should be either a list or sequence";
	    }
	  }
	}
      }
      unless ($skip_content) {
	$cdecl->validate_object($content,{
	  flags => $flags,
	  path => $path,
	  tag => '#content',
	  log =>$log
	 });
      }
    }
  }
  if ($opts and ref($opts->{log})) {
    push @{$opts->{log}}, @$log;
  }
  return @$log ? 0 : 1;
}

=back

=head1 COMPATIBILITY METHODS

=over 3

=item $decl->get_members ()

Return declarations of all associated attributes and of the content
type.

=cut

sub get_members {
  my $self = shift;
  return ($self->get_attributes, $self->get_content_decl);
}

=item $decl->get_member_by_name (name)

If name is equal to '#content', return the content type declaration,
otherwise acts like C.

=cut

sub get_member_by_name {
  my ($self, $name) = @_;
  if ($name eq '#content') {
    return $self->get_content_decl
  } else {
    return $self->get_attribute_by_name($name);
  }
}

=item $decl->get_member_names ()

Return a list of all attribute names plus the string '#content'.

=cut

sub get_member_names {
  my $self = shift;
  return ($self->get_attribute_names, ($self->get_content_decl ? ('#content') : ()))
}


=item $decl->find_members_by_content_decl (decl)

Lookup and return those member (attribute or content) declarations
whose content declaration is decl.

=item $decl->find_members_by_type_name (name)

Lookup and return those member (attribute or content) declarations
whose content is specified via a reference to the named type with a
given name.

=item $decl->find_members_by_role (role)

Lookup and return declarations of all members (attribute or content)
with a given role.

=cut

*find_members_by_content_decl = \&Treex::PML::Schema::Struct::find_members_by_content_decl;
*find_members_by_type_name = \&Treex::PML::Schema::Struct::find_members_by_type_name;
*find_members_by_role = \&Treex::PML::Schema::Struct::find_members_by_role;

=back

=cut

1;
__END__