File Coverage

blib/lib/Treex/PML/Schema/Derive.pm
Criterion Covered Total %
statement 22 131 16.7
branch 0 60 0.0
condition 0 33 0.0
subroutine 8 12 66.6
pod 3 4 75.0
total 33 240 13.7


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::Derive;
2              
3 1     1   3 use strict;
  1         1  
  1         21  
4 1     1   2 use warnings;
  1         1  
  1         18  
5              
6 1     1   3 use vars qw($VERSION);
  1         0  
  1         31  
7             BEGIN {
8 1     1   18 $VERSION='2.21'; # version template
9             }
10 1     1   3 no warnings 'uninitialized';
  1         1  
  1         24  
11 1     1   3 use Carp;
  1         1  
  1         36  
12 1     1   4 use Treex::PML::Schema::Constants;
  1         0  
  1         70  
13 1     1   2 use base qw(Treex::PML::Schema::XMLNode);
  1         1  
  1         897  
14              
15 0     0 1   sub get_decl_type { return(PML_DERIVE_DECL); }
16 0     0 1   sub get_decl_type_str { return('derive'); }
17              
18             sub init {
19 0     0 0   my ($derive,$opts)=@_;
20 0 0         if (!exists($derive->{type})) {
21 0           die " must have a type attribute\n";
22             }
23 0 0         if (!exists($derive->{name})) {
24 0           $derive->{name}=$derive->{type};
25             }
26             }
27              
28             sub simplify {
29 0     0 1   my ($derive,$opts)=@_;
30 0   0       $derive->{name} ||= $derive->{-name};
31 0           my $schema = $derive->{-parent};
32             return if
33             (($schema->get_decl_type == PML_TEMPLATE_DECL and $opts->{no_template_derive}) or
34 0 0 0       ($schema->get_decl_type == PML_SCHEMA_DECL and $opts->{no_derive}));
      0        
      0        
35              
36 0           my $name = $derive->{name};
37 0           my $type;
38 0           my $source = $derive->{type};
39 0 0 0       unless (defined($source) and length($source)) {
40 0           croak "Derive must specify source type in the attribute 'type' in $schema->{URL}\n";
41             }
42 0 0 0       if (defined($name) and length($name)) {
43 0 0 0       if (exists ($schema->{type}{$name}) and $source ne $name) {
44 0           croak "Refusing to derive already existing type '$name' from '$source' in $schema->{URL}\n";
45             }
46 0           $type = $schema->{type}{$name} = $schema->copy_decl($schema->{type}{$source});
47 0           $type->{-name} = $name;
48             } else {
49 0           $name = $source;
50 0           $type = $schema->{type}{$name};
51             }
52              
53             # deriving possible for structures, sequences and choices
54 0 0         if ($derive->{structure}) {
    0          
    0          
    0          
55 0 0         if ($type->{structure}) {
56 0           my $derive_structure = $derive->{structure};
57 0           my $target_structure = $type->{structure};
58 0           foreach my $attr (qw(role name)) {
59 0 0         if (exists $derive_structure->{$attr}) {
60 0           $target_structure->{$attr} = $derive_structure->{$attr};
61 0           push @{$target_structure->{-attributes}},$attr
62 0 0         unless grep { $_ eq $attr } @{$target_structure->{-attributes}};
  0            
  0            
63             }
64             }
65 0   0       $target_structure->{member} ||= {};
66 0           my $members = $target_structure->{member};
67 0           while (my ($member,$value) = each %{$derive_structure->{member}}) {
  0            
68 0           $members->{$member} = $target_structure->copy_decl($value); # FIXME: no need if we remove derives in the end
69             }
70 0 0         if (ref $derive_structure->{delete}) {
71 0           for my $member (@{$derive_structure->{delete}}) {
  0            
72 0           delete $members->{$member};
73             }
74             }
75             } else {
76              
77 0           croak "Cannot derive structure type '$name' from a non-structure '$source'\n";
78             }
79             } elsif ($derive->{sequence}) {
80 0 0         if ($type->{sequence}) {
81 0           my $derive_sequence = $derive->{sequence};
82 0           my $target_sequence = $type->{sequence};
83 0 0         if (exists $derive_sequence->{role}) {
84 0           $target_sequence->{role} = $derive_sequence->{role};
85 0           push @{$target_sequence->{-attributes}},'role'
86 0 0         unless grep { $_ eq 'role' } @{$target_sequence->{-attributes}};
  0            
  0            
87             }
88 0 0         $target_sequence->{content_pattern} = $derive_sequence->{content_pattern} if exists $derive_sequence->{content_pattern};
89 0   0       $target_sequence->{element} ||= {};
90 0           my $elements = $target_sequence->{element};
91 0           while (my ($element,$value) = each %{$derive_sequence->{element}}) {
  0            
92 0           $elements->{$element} = $target_sequence->copy_decl($value); # FIXME: no need if we remove derives in the end
93             }
94 0 0         if (ref $derive_sequence->{delete}) {
95 0           for my $element (@{$derive_sequence->{delete}}) {
  0            
96 0           delete $elements->{$element};
97             }
98             }
99             } else {
100 0           require Data::Dumper;
101             # print STDERR Data::Dumper::Dumper([$type]);
102 0           croak "Cannot derive sequence type '$name' from a non-sequence '$source'\n";
103             }
104             } elsif ($derive->{container}) {
105 0 0         if ($type->{container}) {
106 0           my $derive_container = $derive->{container};
107 0           my $target_container = $type->{container};
108 0           for my $attr (qw(type role)) {
109 0 0         next unless exists $derive_container->{$attr};
110 0 0 0       if ($attr eq 'type' and !exists($target_container->{type})) {
111 0           foreach my $d (qw(list alt structure container sequence cdata)) {
112 0 0         if (exists $target_container->{$d}) {
113 0           delete $target_container->{$d};
114 0           last;
115             }
116             }
117 0           delete $target_container->{-decl};
118 0           delete $target_container->{-resolved};
119             }
120 0           $target_container->{$attr} = $derive_container->{$attr};
121 0           push @{$target_container->{-attributes}},$attr
122 0 0         unless grep { $_ eq $attr } @{$target_container->{-attributes}};
  0            
  0            
123             }
124 0   0       $target_container->{attribute} ||= {};
125 0           my $attributes = $target_container->{attribute};
126 0           while (my ($attribute,$value) = each %{$derive_container->{attribute}}) {
  0            
127 0           $attributes->{$attribute} = $target_container->copy_decl($value); # FIXME: no need if we remove derives in the end
128             }
129 0 0         if (ref $derive_container->{delete}) {
130 0           for my $attribute (@{$derive_container->{delete}}) {
  0            
131 0           delete $attributes->{$attribute};
132             }
133             }
134             } else {
135 0           croak "Cannot derive a container '$name' from a different type '$source'\n";
136             }
137             } elsif ($derive->{choice}) {
138 0           my $choice = $derive->{choice};
139 0 0         if ($type->{choice}) {
140 0           my (@add,%delete);
141 0 0         if (UNIVERSAL::isa($choice,'HASH')) {
142 0 0         @add = @{$choice->{values}} if ref $choice->{values};
  0            
143 0 0         @delete{ @{$choice->{delete}} }=() if ref $choice->{delete};
  0            
144             } else {
145 0           @add = @$choice;
146             }
147 0           my %seen;
148 0           @{$type->{choice}{values}} =
149 0   0       grep { !($seen{$_}++) and ! exists $delete{$_} } (@{$type->{choice}{values}},@add);
  0            
  0            
150             } else {
151 0           croak "Cannot derive a choice type '$name' from a non-choice type '$source'\n";
152             }
153             } else {
154 0 0         unless ($name ne $source) {
155 0           croak " has no effect in $schema->{URL}\n";
156             }
157             }
158             }
159              
160             1;
161             __END__