File Coverage

blib/lib/SOAP/WSDL/XSD/SimpleType.pm
Criterion Covered Total %
statement 53 63 84.1
branch 15 26 57.6
condition 8 15 53.3
subroutine 9 9 100.0
pod 0 4 0.0
total 85 117 72.6


line stmt bran cond sub pod time code
1             package SOAP::WSDL::XSD::SimpleType;
2 1     1   858 use strict;
  1         3  
  1         39  
3 1     1   5 use warnings;
  1         2  
  1         76  
4 1     1   957 use Class::Std::Fast::Storable;
  1         28324  
  1         9  
5 1     1   187 use base qw(SOAP::WSDL::Base);
  1         3  
  1         739  
6              
7             our $VERSION = $SOAP::WSDL::VERSION;
8              
9             my %length_of :ATTR(:name :default<[]>);
10             my %minLength_of :ATTR(:name :default<[]>);
11             my %maxLength_of :ATTR(:name :default<[]>);
12             my %pattern_of :ATTR(:name :default<[]>);
13             my %enumeration_of :ATTR(:name :default<[]>);
14             my %whiteSpace_of :ATTR(:name :default<[]>);
15             my %totalDigits_of :ATTR(:name :default<[]>);
16             my %fractionDigits_of :ATTR(:name :default<[]>);
17             my %minExclusive :ATTR(:name :default<[]>);
18             my %minInclusive :ATTR(:name :default<[]>);
19             my %maxExclusive :ATTR(:name :default<[]>);
20             my %maxInclusive :ATTR(:name :default<[]>);
21              
22             my %fixed :ATTR(:name :default<[]>);
23              
24             my %annotation_of :ATTR(:name :default<()>);
25             my %base_of :ATTR(:name :default<()>);
26             my %itemType_of :ATTR(:name :default<()>);
27              
28              
29             # TODO rename flavor to variety to be consistent with the XML Schema
30             # specs - though flavor is the cooler name..
31             # set to restriction|list|union|enumeration
32             my %flavor_of :ATTR(:name :default<()>);
33              
34             # for simpleType containing atomic simple types
35             my %type_of :ATTR(:name :default<()>);
36              
37             sub get_simpleType; *get_simpleType = \&get_type;
38             sub set_simpleType; *set_simpleType = \&set_type;
39              
40             sub get_variety; *get_variety = \&get_flavor;
41              
42             sub set_restriction {
43 1     1 0 3 my $self = shift;
44 1         2 my @attributes = @_;
45 1         6 $self->set_flavor( 'restriction' );
46              
47 1         7 for (@attributes) {
48 2 100       7 next if (not $_->{ LocalName } eq 'base');
49 1         5 $self->set_base( $_->{ Value } );
50             }
51             }
52              
53             sub set_list {
54 1     1 0 18 my $self = shift;
55 1         2 my @attributes = @_;
56 1         12 $self->set_flavor( 'list' );
57 1         7 for (@attributes) {
58 2 100       9 next if (not $_->{ LocalName } eq 'itemType');
59 1         3 $self->set_itemType( $_->{ Value } );
60             }
61             }
62              
63             sub set_union {
64 2     2 0 1142 my $self = shift;
65 2         5 my @attributes = @_;
66 2         8 $self->set_flavor( 'union' );
67 2         13 for (@attributes) {
68 4 100       12 next if (not $_->{ LocalName } eq 'memberTypes');
69 2         17 $self->set_base( [ split /\s/, $_->{ Value } ] );
70             }
71             }
72              
73             sub serialize {
74 4     4 0 2307 my $self = shift;
75 4         7 my $name = shift;
76 4         6 my $value = shift;
77 4         8 my $opt = shift;
78 4         15 my $ident = ident $self;
79              
80 4   50     53 $opt->{ attributes } ||= [];
81 4   50     23 $opt->{ indent } ||= q{};
82              
83 4 100 66     55 return $self->_serialize_single($name, $value , $opt)
      100        
84             if ( $flavor_of{ $ident } eq 'restriction'
85             or $flavor_of{ $ident } eq 'union'
86             or $flavor_of{ $ident } eq 'enumeration');
87              
88 2 100       15 if ($flavor_of{ $ident } eq 'list' )
89             {
90 1   50     4 $value ||= [];
91 1 50       4 $value = [ $value ] if ( ref( $value) ne 'ARRAY' );
92 1         2 return $self->_serialize_single($name, join( q{ }, @{ $value } ), $opt);
  1         5  
93             }
94             }
95              
96             sub _serialize_single {
97 3     3   8 my ($self, $name, $value, $opt) = @_;
98 3         5 my $xml = '';
99 3 50       10 $xml .= $opt->{ indent } if ($opt->{ readable }); # add indentation
100 3         4 $xml .= '<' . join ' ', $name, @{ $opt->{ attributes } };
  3         12  
101 3 50       11 if ( $opt->{ autotype }) {
102             # reverse namespace by prefix hash
103 0         0 my $ns = $self->get_targetNamespace();
104              
105             # build a list of hash keys (eg '#default', 'tns') whose values match our namespace (eg 'urn:myNamespace')
106 0         0 (my @possible_namespace_names) = grep { $opt->{ namespace }->{$_} eq $ns } keys %{ $opt->{ namespace } };
  0         0  
  0         0  
107              
108             # put any '#default' option last
109 0 0       0 @possible_namespace_names = sort { $a eq '#default' ? 1 : $b eq '#default' ? -1 : $a cmp $b } @possible_namespace_names;
  0 0       0  
110              
111 0 0 0     0 if( grep( $_ ne '#default', @possible_namespace_names ) > 1 or ! @possible_namespace_names ) {
112 0         0 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";
113             }
114 0         0 my $prefix = $possible_namespace_names[0];
115 0         0 $xml .= ' type="' . $prefix . ':' . $self->get_name() .'"';
116             }
117              
118             # nillabel ?
119 3 50       8 return $xml .'/>' if not defined $value;
120              
121 3         8 $xml .= join q{}, '>' , $value , '';
122 3 50       9 $xml .= "\n" if ($opt->{ readable });
123 3         22 return $xml;
124             }
125              
126             1;