File Coverage

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

Criterion	Covered	Total	%
statement	103	197	52.2
branch	44	100	44.0
condition	9	29	31.0
subroutine	18	33	54.5
pod	22	24	91.6
total	196	383	51.1

package Treex::PML::Schema::Decl;

########################################################################
# PML Schema type declaration
########################################################################

use strict;
use warnings;

use vars qw($VERSION);
BEGIN {
  $VERSION='2.24'; # version template
}
no warnings 'uninitialized';
use Scalar::Util qw( weaken );
use Carp;
use Treex::PML::Schema::Constants;
use base qw(Treex::PML::Schema::XMLNode);

=head1 NAME

Treex::PML::Schema::Decl - implements PML schema type declaration

=head1 DESCRIPTION

This is an abstract class from which all specific type declaration
classes inherit.

=head1 INHERITANCE

This class inherits from L.

=head1 METHODS

=over 3

=cut

sub new { croak("Can't create ".__PACKAGE__) }

# compatibility with old Treex::PML::Type

sub type_decl { return $_[0] };

=item $decl->get_schema ()

=item $decl->schema ()

Return C the declaration belongs to.

=cut

sub schema    { return $_[0]->{-schema} }

=item $decl->get_schema ()

Same as C<< $decl->schema() >>.

=cut

sub get_schema { return $_[0]->schema }

=item $decl->get_decl_type ()

Return the type of declaration as an integer constant (see
L).

=item $decl->get_decl_type_str ()

Return the type of declaration as string; one of: type, root,
structure, container, sequence, list, alt, cdata, choice, constant,
attribute, member, element.

=cut

sub get_decl_type     { return(undef); } # VIRTUAL
sub get_decl_type_str { return(undef); } # VIRTUAL

=item $decl->is_atomic ()

Return 1 if the declaration is of atomic type (cdata, choice,
constant), 0 if it is a structured type (structure, container,
sequence, list, alt), or undef, if it is an auxiliary declaration
(root, type, attribute, member, element).

=cut

sub is_atomic { croak "is_atomic(): UNKNOWN TYPE"; } # VIRTUAL

=item $decl->get_content_decl ()

For declarations with content (type, root, container, list, alt,
attribute, member, element), return the content declaration; return
undef for other declarations. This method transparently resolves
references to named types.

=cut

sub get_content_decl {
  my $self = shift;
  my $no_resolve = shift;
  if ($self->{-decl}) {
    return $self->{ $self->{-decl} };
  } elsif (my $resolved = $self->{-resolved}) {
    return $resolved;
  } elsif (my $type_ref = $self->{type}) {
    my $schema = $self->{-schema};
    if ($schema) {
      my $type = $schema->{type}{ $type_ref };
      if ($no_resolve) {
        return $type;
      } elsif ($type) {
        weaken($self->{-resolved} = $type->get_content_decl);
        return $self->{-resolved};
      } else {
        return undef;
      }
    } else {
      croak "Declaration not associated with a schema";
    }
  }
  return(undef);
}

=item $decl->get_knit_content_decl ()

If the data type has a role '#KNIT', return a type declaration for the
knitted content (Note: PML 1.1.2 allows role '#KNIT' role on list,
element, and member declarations, but element knitting is not
currenlty implemented). Otherwise return the same as get_content_decl.

=cut


sub get_knit_content_decl {
  my $self = shift;
  return (defined($self->{role}) and $self->{role} eq '#KNIT') ?
    $self->get_type_ref_decl
      : $self->get_content_decl;
}

=item $decl->get_type_ref ()

If the declaration has content and the content is specified via a
reference to a named type, return the name of the referred type.
Otherwise return undef.

=cut

sub get_type_ref {
  return $_[0]->{type};
}

=item $decl->get_type_ref_decl ()

Retrun content declaration object (if any), but only if it is
specified via a reference to a named type. In all other cases, return
undef.

=cut

sub get_type_ref_decl {
  my $self = shift;
  my $no_resolve = shift;
  if (my $resolved = $self->{-resolved}) {
    return $resolved;
  } elsif (my $type_ref = $self->{type}) {
    my $schema = $self->{-schema};
    if ($schema) {
      my $type = $schema->{type}{ $type_ref };
      return $no_resolve ? $type
        : $type ?
          ($self->{-resolved} = $type->get_content_decl)
          : undef ;
    }
  }
  return(undef);
}

=item $decl->get_base_type_name ()

If the declaration is a nested (even deeply) part of a named type
declaration, return the name of that named type.

=cut

sub get_base_type_name {
  my $path = $_[0]->{-path};
  if ($path=~m{^!([^/]+)}) {
    return $1;
  } else {
    return(undef);
  }
}

=item $decl->get_parent_decl ()

If this declaration is nested, return its parent declaration.

=cut

sub get_parent_decl { return $_[0]->{-parent} }

=item $decl->get_decl_path ()

Return a cannonical attribute path leading to the declaration
(starting either at a named type or the root type declaration).

=cut

sub get_decl_path { return $_[0]->{-path};  }

=item $decl->get_role

If the declaration is associated with a role, return it.

=cut

sub get_role      { return $_[0]->{role}||'' }


=item $decl->find (attribute-path,noresolve)

Locate a nested declaration specified by C starting
from the current type. See C<$schema-Efind_type_by_path> for details
about locating declarations.

=cut

sub find {
  my ($self, $path,$noresolve) = @_;
  # find node type
  my $type = $self->type_decl;
  return $self->schema->find_type_by_path($path,$noresolve,$type);
}

=item $decl->find_role (role, opts)

Search declarations with a given role nested within this declaration.
In scalar context, return the first declaration that matches, in array
context return all such declarations.

The last argument C can be used to pass some flags to the
algorithm. Currently only the flag C is available. If
true, then the function never recurses into content declaration of
declarations with the role #CHILDNODES.

=cut

sub find_role {
  my ($self, $role, $opts) = @_;
  return $self->schema->find_role($role,$self->type_decl,$opts);
}

=item $decl->convert_from_hash (class, hash, schema, path)

Compatibility method building the schema object from a nested hash
structure created by XML::Simple which was used in older
implementations. This is useful for upgrading objects stored in old
binary dumps. Not to be used directly.

=cut

sub convert_from_hash {
  my ($class, $decl, $schema, $path) = @_;
  my $sub;
  my $decl_type;
  if ($sub = $decl->{structure}) {
    $decl_type = 'structure';
    bless $sub, 'Treex::PML::Schema::Struct';
    $sub->{'-attributes'}=[qw(role name type)];
    if (my $members = $sub->{member}) {
      my ($name, $mdecl);
      while (($name, $mdecl) = each %$members) {
        bless $mdecl, 'Treex::PML::Schema::Member';
        $mdecl->{'-xml_name'}='member';
        $mdecl->{'-attributes'}=[qw(name required as_attribute type role)];
        weaken($mdecl->{-parent}=$sub);
        weaken($mdecl->{-schema}=$schema);
        $class->convert_from_hash($mdecl,
                         $schema,
                         $path.'/'.$name
                        );
        if (!$mdecl->{-decl} and $mdecl->{role} eq '#KNIT') {
#          warn("Member $decl->{-parent}{-path}/$decl->{-name} with role=\"#KNIT\" must have a content type declaration: assuming !\n");
          Treex::PML::Schema::__fix_knit_type($schema,$mdecl);
        }
      }
    }
  } elsif ($sub = $decl->{container}) {
    $decl_type = 'container';
    bless $sub, 'Treex::PML::Schema::Container';
    $sub->{'-attributes'}=[qw(role name type)];
    if (my $members = $sub->{attribute}) {
      my ($name, $mdecl);
      while (($name, $mdecl) = each %$members) {
        bless $mdecl, 'Treex::PML::Schema::Attribute';
        $mdecl->{'-xml_name'}='attribute';
        $mdecl->{'-attributes'}=[qw(name required type role)];
        weaken($mdecl->{-schema}=$schema);
        weaken($mdecl->{-parent}=$sub);
        $class->convert_from_hash($mdecl,
                         $schema,
                         $path.'/'.$name
                        );
      }
    }
    $class->convert_from_hash($sub, $schema, $path.'/#content');
  } elsif ($sub = $decl->{sequence}) {
    $decl_type = 'sequence';
    bless $sub, 'Treex::PML::Schema::Seq';
    $sub->{'-attributes'}=[qw(role content_pattern type)];
    if (my $members = $sub->{element}) {
      my ($name, $mdecl);
      while (($name, $mdecl) = each %$members) {
        bless $mdecl, 'Treex::PML::Schema::Element';
        $mdecl->{'-xml_name'}='element';
        $mdecl->{'-attributes'}=[qw(name type role)];
        weaken($mdecl->{-schema}=$schema);
        weaken($mdecl->{-parent}=$sub);
        $class->convert_from_hash($mdecl,
                         $schema,
                         $path.'/'.$name
                        );
      }
    }
  } elsif ($sub = $decl->{list}) {
    $decl_type = 'list';
    bless $sub, 'Treex::PML::Schema::List';
    $sub->{'-attributes'}=[qw(role ordered type)];
    $class->convert_from_hash($sub, $schema, $path.'/LM');
    if (!$sub->{-decl} and $sub->{role} eq '#KNIT') {
#      warn("List $sub->{-name} with role=\"#KNIT\" must have a content type declaration: assuming !\n");
      Treex::PML::Schema::__fix_knit_type($schema,$sub,$path.'/LM');
    }
  } elsif ($sub = $decl->{alt}) {
    $decl_type = 'alt';
    bless $sub, 'Treex::PML::Schema::Alt';
    $sub->{'-attributes'}=[qw(role type)];
    $class->convert_from_hash($sub, $schema, $path.'/AM');
  } elsif ($sub = $decl->{choice}) {
    $decl_type = 'choice';
    # convert from an ARRAY to a hash
    if (ref($sub) eq 'ARRAY') {
      $sub = $decl->{choice} = bless { values => [
                                         map {
                                           ref($_) eq 'HASH' ? $_->{content} : $_
                                         } @$sub
                                       ],
                                     }, 'Treex::PML::Schema::Choice';
    } elsif (ref($sub)) {
      bless $sub, 'Treex::PML::Schema::Choice';
      if (ref($sub->{value}) eq 'ARRAY') {
        $sub->{values} = [
          map { $_->{content} } @{$sub->{value}}
        ];
        delete $sub->{value};
      }
    } else {
      croak __PACKAGE__.": Invalid  element in type '$path'?\n";
    }
  } elsif ($sub = $decl->{cdata}) {
    $decl_type = 'cdata';
    bless $sub, 'Treex::PML::Schema::CDATA';
    $sub->{'-attributes'}=['format'];
  } elsif (exists $decl->{constant}) { # can be 0
    $sub = $decl->{constant};
    $decl_type = 'constant';
    unless (ref($sub)) {
      $sub = $decl->{constant} = bless { value => $sub }, 'Treex::PML::Schema::Constant';
    }
    ## this is just a scalar value
    # bless $sub, 'Treex::PML::Schema::Constant';
  }
  $sub->{'-xml_name'}=$decl_type;
  weaken( $decl->{-schema} = $schema );
  $decl->{-decl} = $decl_type;
  unless (exists($sub->{-schema}) and exists($sub->{-parent})) {
    weaken( $sub->{-schema} = $schema ) unless $sub->{-schema};
    weaken( $sub->{-parent} = $decl ) unless $sub->{-parent};
    $sub->{-path} = $path;
  }
  return $decl;
}


=item $decl->get_normal_fields ()

This method is provided for convenience.

For a structure type, return names of its members, for a container
return names of its attributes plus the name '#content' referring to
the container's content value. In both cases, eliminate fields of
values with role C<#CHILDNODES> and strip a possible C<.rf> suffix of
fields with role C<#KNIT>.

=cut

sub get_normal_fields {
  my ($self,$path)=@_;
  my $type = defined($path) ? $self->find($path) : $self;
  my $struct;
  my $members;
  return unless ref $type;
  my $decl_is = $type->get_decl_type;
  if ($decl_is == PML_TYPE_DECL ||
      $decl_is == PML_ROOT_DECL ||
      $decl_is == PML_ATTRIBUTE_DECL ||
      $decl_is == PML_MEMBER_DECL ||
      $decl_is == PML_ELEMENT_DECL ) {
    if ($type = $type->get_content_decl) {
      $decl_is = $type->get_decl_type;
    } else {
      return ();
    }
  }
  my @members = ();
  if ($decl_is == PML_STRUCTURE_DECL) {
    @members =
      map { $_->get_knit_name }
        grep { $_->get_role ne '#CHILDNODES' }
          $type->get_members;
  } elsif ($decl_is == PML_CONTAINER_DECL) {
    my $cdecl = $type->get_content_decl;
    @members = ($type->get_attribute_names,
                ($cdecl && $type->get_role ne '#CHILDNODES') ? '#content' : ());
  }
}

=item $decl->get_childnodes_decls ()

If the $decl has the role #NODE, this method locates a sub-declaration
with role #CHILDNODES and returns a list of declarations of the child
nodes.

=cut

sub get_childnodes_decls {
  my ($self) = @_;
  if ($self->get_decl_type == PML_ELEMENT_DECL) {
    $self = $self->get_content_decl;
  }
  return unless $self->get_role eq '#NODE';
  my ($ch) = $self->find_members_by_role('#CHILDNODES');
  if ($ch) {
    my $ch_is = $ch->get_decl_type;
    if ($ch_is == PML_MEMBER_DECL) {
      $ch = $ch->get_content_decl;
      $ch_is = $ch->get_decl_type;
    }
    if ($ch_is == PML_SEQUENCE_DECL) {
      return $ch->get_elements;
    } elsif ($ch_is == PML_LIST_DECL) {
      return $ch->get_content_decl;
    }
  }
  return;
}


=item $decl->get_attribute_paths (\%opts)

Return attribute paths leading from this declaration to all (possibly
deeply) nested declarations of atomic type. This method is an alias for

  $decl->schema->get_paths_to_atoms([$decl],\%opts)

See L for details.

=cut

sub get_attribute_paths { # OLD NAME
  my ($self,$opts)=@_;
  return $self->get_paths_to_atoms($opts);
}

=item $decl->get_paths_to_atoms (\%opts)

Same as

  $decl->schema->get_paths_to_atoms([$decl],\%opts)

See L for details.

=cut

sub get_paths_to_atoms {
  my ($self,$opts)=@_;
  return $self->schema->get_paths_to_atoms([$self],$opts);
}

=item $decl->validate_object($object);

See C method of L.

=cut

sub validate_object {
  croak "Not implemented for the class ".__PACKAGE__;
}

=item $decl->for_each_decl (sub{ ... })

This method traverses all nested sub-declarations and calls a given
subroutine passing the sub-declaration object as a parameter.

=cut

sub for_each_decl {
  my ($self,$sub)=@_;
  $sub->($self);
  # (a container or #KNIT member can have both type and children)
  # traverse descendant type declarations
  for my $d (qw(member attribute element)) {
    if (ref $self->{$d}) {
      foreach (values %{$self->{$d}}) {
        $_->for_each_decl($sub);
      }
      last if $d eq 'attribute'; # there may be content
      return; # otherwise
    }
  }
  for my $d (qw(list alt structure container sequence),
             qw(cdata choice constant)) {
    if (exists $self->{$d}) {
      $self->{$d}->for_each_decl($sub);
      return;
    }
  }
}

=item $decl->write ({option => value})

This method serializes a declaration to XML. See Treex::PML::Schema->write for
details and Treex::PML::Schema::XMLNode->write for implementation.

=cut


=back

=cut


1;
__END__