File Coverage

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

Criterion	Covered	Total	%
statement	30	55	54.5
branch	0	10	0.0
condition	0	6	0.0
subroutine	12	18	66.6
pod	7	10	70.0
total	49	99	49.4

package Treex::PML::Schema::Choice;

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 );

=head1 NAME

Treex::PML::Schema::Choice - implements declaration of an enumerated
type (choice).

=head1 INHERITANCE

This class inherits from L.

=head1 METHODS

See the super-class for the complete list.

=over 3

=item $decl->is_atomic ()

Returns 1.

=item $decl->get_decl_type ()

Returns the constant PML_CHOICE_DECL.

=item $decl->get_decl_type_str ()

Returns the string 'choice'.

=item $decl->get_values ()

Return list of possible values.

=item $decl->set_values (\@values)

Set possible values.

=item $decl->get_content_decl ()

Returns undef.

=item $decl->validate_object($object)

See C in L.

=back

=cut

sub is_atomic { 1 }
sub get_decl_type { return PML_CHOICE_DECL; }
sub get_decl_type_str { return 'choice'; }
sub get_content_decl { return(undef); }
sub get_values { return @{ $_[0]->{values} }; }
sub set_values {
  my ($self,$values) = @_;
  croak(__PACKAGE__."::set_values : argument is not an array reference\n") unless ref($values) eq 'ARRAY';
  @{ $self->{values} }=@$values;
}
sub init {
  my ($self,$opts)=@_;
  $self->{-parent}{-decl} = 'choice';
}
sub post_process {
  my ($choice,$opts)=@_;
  $choice->{values} = delete $choice->{value};
}

sub validate_object {
  my ($self, $object, $opts) = @_;
  my $ok = 0;
  my $values = $self->{values};
  if ($values) {
    foreach (@{$values}) {
      if ($_ eq $object) {
	$ok = 1;
	last;
      }
    }
  }
  if (!$ok and ref($opts) and ref($opts->{log})) {
    my $path = $opts->{path};
    my $tag = $opts->{tag};
    $path.="/".$tag if $tag ne q{};
    push @{$opts->{log}}, "$path: Invalid value: '$object'";
  }
  return $ok;
}

sub serialize_get_children {
  my ($choice,$opts)=@_;
  return map ['value',$_],@{$choice->{values}};
}


1;
__END__