File Coverage

blib/lib/SOAP/WSDL/XSD/ComplexType.pm
Criterion Covered Total %
statement 36 89 40.4
branch 8 48 16.6
condition 4 10 40.0
subroutine 6 10 60.0
pod 0 5 0.0
total 54 162 33.3


line stmt bran cond sub pod time code
1             package SOAP::WSDL::XSD::ComplexType;
2 1     1   947 use strict;
  1         2  
  1         40  
3 1     1   6 use warnings;
  1         2  
  1         162  
4 1     1   1139 use Class::Std::Fast::Storable;
  1         29961  
  1         10  
5 1     1   149 use Scalar::Util qw(blessed);
  1         2  
  1         242  
6 1     1   6 use base qw(SOAP::WSDL::Base);
  1         2  
  1         1031  
7              
8             our $VERSION = $SOAP::WSDL::VERSION;
9              
10             # id provided by Base
11             # name provided by Base
12             # annotation provided by Base
13             my %length_of :ATTR(:name :default<[]>);
14             my %minLength_of :ATTR(:name :default<[]>);
15             my %maxLength_of :ATTR(:name :default<[]>);
16             my %pattern_of :ATTR(:name :default<[]>);
17             my %enumeration_of :ATTR(:name :default<[]>);
18             my %whiteSpace_of :ATTR(:name :default<[]>);
19             my %totalDigits_of :ATTR(:name :default<[]>);
20             my %fractionDigits_of :ATTR(:name :default<[]>);
21             my %minExclusive :ATTR(:name :default<[]>);
22             my %minInclusive :ATTR(:name :default<[]>);
23             my %maxExclusive :ATTR(:name :default<[]>);
24             my %maxInclusive :ATTR(:name :default<[]>);
25              
26              
27             my %attribute_of :ATTR(:name :default<()>);
28             my %element_of :ATTR(:name :default<[]>);
29             my %group_of :ATTR(:name :default<()>);
30             my %variety_of :ATTR(:name :default<()>);
31             my %base_of :ATTR(:name :default<()>);
32             my %itemType_of :ATTR(:name :default<()>);
33             my %abstract_of :ATTR(:name :default<()>);
34             my %final_of :ATTR(:name :default<()>);
35             my %mixed_of :ATTR(:name :default<()>); # default is false
36              
37             my %derivation_of :ATTR(:name :default<()>);
38              
39             # is set to simpleContent/complexContent
40             my %content_model_of :ATTR(:name :default);
41              
42             sub get_flavor; *get_flavor = \&get_variety;
43              
44             sub push_element {
45 0     0 0 0 my $self = shift;
46 0         0 my $element = shift;
47 0 0       0 if ($variety_of{ ident $self } eq 'all')
    0          
48             {
49 0 0       0 $element->set_minOccurs(0) if not defined ($element->get_minOccurs);
50 0 0       0 $element->set_maxOccurs(1) if not defined ($element->get_maxOccurs);
51             }
52             elsif ($variety_of{ ident $self } eq 'sequence')
53             {
54 0 0       0 $element->set_minOccurs(1) if not defined ($element->get_minOccurs);
55 0 0       0 $element->set_maxOccurs(1) if not defined ($element->get_maxOccurs);
56             }
57 0         0 push @{ $element_of{ ident $self } }, $element;
  0         0  
58             }
59              
60             sub set_restriction {
61 0     0 0 0 my $self = shift;
62 0         0 my $element = shift;
63 0         0 $variety_of{ ident $self } = 'restriction';
64 0         0 $derivation_of{ ident $self } = 'restriction';
65 0         0 $base_of{ ident $self } = $element->{ Value };
66             }
67              
68             sub set_extension {
69 0     0 0 0 my $self = shift;
70 0         0 my $element = shift;
71 0         0 $variety_of{ ident $self } = 'extension';
72 0         0 $derivation_of{ ident $self } = 'extension';
73 0         0 $base_of{ ident $self } = $element->{ Value };
74             }
75              
76             sub init {
77 0     0 0 0 my $self = shift;
78 0         0 my @args = @_;
79 0         0 $self->SUPER::init( @args );
80             }
81              
82             sub serialize {
83 2     2 0 1617 my ($self, $name, $value, $opt) = @_;
84              
85 2   50     15 $opt->{ indent } ||= q{};
86 2   50     14 $opt->{ attributes } ||= [];
87 2         6 my $variety = $self->get_variety();
88 2 50       14 my $xml = ($opt->{ readable }) ? $opt->{ indent } : q{}; # add indentation
89              
90 2 50       6 if ( $opt->{ qualify } ) {
91 0         0 $opt->{ attributes } = [ ' xmlns="' . $self->get_targetNamespace .'"' ];
92 0         0 delete $opt->{ qualify };
93             }
94              
95 2         4 $xml .= join q{ } , "<$name" , @{ $opt->{ attributes } };
  2         6  
96 2         4 delete $opt->{ attributes }; # don't propagate...
97              
98 2 100       7 if ( $opt->{ autotype }) {
99 1         14 my $ns = $self->get_targetNamespace();
100             # reverse namespace by prefix hash
101              
102             # build a list of hash keys (eg '#default', 'tns') whose values match our namespace (eg 'urn:myNamespace')
103 1         6 (my @possible_namespace_names) = grep { $opt->{ namespace }->{$_} eq $ns } keys %{ $opt->{ namespace } };
  0         0  
  1         5  
104              
105             # put any '#default' option last
106 1 0       2 @possible_namespace_names = sort { $a eq '#default' ? 1 : $b eq '#default' ? -1 : $a cmp $b } @possible_namespace_names;
  0 0       0  
107              
108 1 50 33     9 if( grep( $_ ne '#default', @possible_namespace_names ) > 1 or ! @possible_namespace_names ) {
109 1         11 die "No prefix found for namespace $ns, or too many possible names: ``@possible_namespace_names''; there should be just one and maybe a '#default' entry";
110             }
111 0         0 my $prefix = $possible_namespace_names[0];
112              
113 0 0       0 $xml .= join q{}, " type=\"$prefix:", $self->get_name(), '" '
114             if ($self->get_name() );
115             }
116 1         2 $xml .= '>';
117 1 50       3 $xml .= "\n" if ( $opt->{ readable } ); # add linebreak
118              
119 1 50       6 if ($self->schema) {
120 0 0       0 if ($self->schema()->get_elementFormDefault() ne "qualified") {
121 0 0       0 push @{$opt->{ attributes } }, q{xmlns=""}
  0         0  
122             if ($self->get_targetNamespace() ne "");
123             }
124             }
125 1 50 33     7 if ( ($variety eq "sequence") or ($variety eq "all") ) {
126 0         0 $opt->{ indent } .= "\t";
127 0         0 for my $element (@{ $self->get_element() }) {
  0         0  
128             # resolve element ref
129             #
130             # Basic algorithm is like this:
131             # If on serialization, we meet a element whose get_ref method
132             # returns a true value, lookup the element from the
133             # definitions instead, and serialize this element.
134             #
135 0 0       0 if (my $ref = $element->get_ref()) {
136             $element = $opt->{ typelib }->find_element(
137 0         0 $element->expand($ref)
138             );
139             }
140              
141             # might be list - listify
142 0 0       0 $value = [ $value ] if not ref $value eq 'ARRAY';
143              
144 0         0 for my $single_value (@{ $value }) {
  0         0  
145 0         0 my $element_value;
146 0 0       0 if (blessed $single_value) {
147 0         0 my $method = 'get_' . $element->get_name();
148 0         0 $element_value = $single_value->$method();
149             }
150             else {
151 0         0 $element_value = $single_value->{ $element->get_name() };
152             }
153 0 0       0 $element_value = [ $element_value ]
154             if not ref $element_value eq 'ARRAY';
155              
156 0         0 $xml .= join q{}
157 0         0 , map { $element->serialize( undef, $_, $opt ) }
158 0         0 @{ $element_value };
159             }
160             }
161 0         0 $opt->{ indent } =~s/\t$//;
162             }
163             else {
164 1         9 die "sorry, we just handle all and sequence types yet...";
165             }
166 0 0         $xml .= $opt->{ indent } if ( $opt->{ readable } ); # add indentation
167 0           $xml .= '';
168 0 0         $xml .= "\n" if ($opt->{ readable } ); # add linebreak
169 0           return $xml;
170             }
171              
172             1;
173