view release on metacpan or  search on metacpan

lib/Treex/PML/Schema/Copy.pm  view on Meta::CPAN

	exists $parent->{type}{$name}
	  or (exists $parent->{derive}{$name}
		and $parent->{derive}{$name}{type} ne $name)
	  or exists $parent->{param}{$name};
#      print STDERR "copying type $name into \n";
      $t->{-name}=$name;
      $parent->{type}{$name}=$t;
    }
    for my $t (@new_templates) {
      my $name = $prefix.$t->{-name};
      die "Template $name copied from $template_name already exists\n" if
	exists $parent->{template}{$name};
#      print STDERR "copying template $name\n";
      $t->{-name}=$name;
      $parent->{template}{$name}=$t;
    }
  }
}
# traverse declarations as long as there is one
# containing a hash key $what or one occurring in an array-ref $what
# with a Hash value containing the key $name
sub _lookup_upwards {
  my ($parent, $what, $name)=@_;
  if (ref($what) eq 'ARRAY') {
    while ($parent) {
      return $parent if
	first { (ref($parent->{$_}) eq 'HASH') and exists($parent->{$_}{$name}) } @$what;
      $parent = $parent->{-parent};
    }
  } else {
    while ($parent) {
      return $parent if (ref($parent->{$what}) eq 'HASH') and exists($parent->{$what}{$name});
      $parent = $parent->{-parent};
    }
  }
  return;
}

sub _apply_prefix {
  my ($copy,$template,$prefix,$type) = @_;
  if (ref($type)) {
    if (UNIVERSAL::isa($type,'HASH')) {
      if (exists($type->{-name}) and $type->{-name} eq 'template') {
	# hopefully a template
	if ($type->{type}) {
	  _apply_prefix($copy,$template,$prefix,$_) for (values %{$type->{type}});
	}
	return;
      }
      my $ref = $type->{type};
      if (defined($ref) and length($ref)) {
	my $owner = _lookup_upwards($type->{-parent},['type','derive','param'],$ref);
	if (defined $owner and $owner==$template) {
	  # the type is defined exactly on the level of the template
	  if (exists $copy->{let}{$ref}) {
	    my $let = $copy->{let}{$ref};
	    if ($let->{type}) {
	      $type->{type}=$let->{type}
	    } else {
	      delete $type->{type};
	      foreach my $d (qw(list alt structure container sequence cdata choice constant)) {
		if (exists $type->{$d}) {
		  delete $type->{$d};
		  last;
		}
	      }
	      delete $type->{-decl};
	      delete $type->{-resolved};
	      foreach my $d (qw(list alt structure container sequence cdata choice constant)) {
		if (exists $let->{$d}) {
		  $type->{$d} = $type->copy_decl($let->{$d});
		  $type->{-decl}=$d;
		  last;
		}
	      }
	    }
	  } else {
	    $type->{type} = $prefix.$ref; # do apply prefix
	  }
	} else {
	  $type->{type} = $prefix.$ref; # do apply prefix
	}
      }
      # traverse descendant type declarations
      for my $d (qw(member attribute element)) {
	if (ref($type->{$d})) {
	  _apply_prefix($copy,$template,$prefix,$_) for (values %{$type->{$d}});
	  return;
	}
      }
      for my $d (qw(list alt structure container sequence)) {
	if (ref($type->{$d})) {
	  _apply_prefix($copy,$template,$prefix,$type->{$d});
	  return;
	}
      }
    }
  } elsif (UNIVERSAL::isa($type,'ARRAY')) {
    foreach my $d (@$type) {
      _apply_prefix($copy,$template,$prefix,$d);
    }
  }
}


1;
__END__

=head1 NAME

Treex::PML::Schema::Copy - a class representing copy instructions in a Treex::PML::Schema

=head1 DESCRIPTION

This is an auxiliary class  representing copy instructions in a Treex::PML::Schema.
Note that all copy instructions are removed from the schema during parsing.

=head1 METHODS

=over 5

=item $decl->get_decl_type ()

Returns the constant PML_COPY_DECL.

=item $decl->get_decl_type_str ()

Returns the string 'copy'.