line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Pod::WSDL; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# TODO: make array based objects work as own complex types |
4
|
|
|
|
|
|
|
# TODO: non RPC style bindings |
5
|
|
|
|
|
|
|
# TODO: read type information alternatively from own file |
6
|
|
|
|
|
|
|
# TODO: write soapAction attribute in operations? |
7
|
|
|
|
|
|
|
|
8
|
6
|
|
|
6
|
|
100510
|
use strict; |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
219
|
|
9
|
6
|
|
|
6
|
|
25
|
use warnings; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
158
|
|
10
|
6
|
|
|
6
|
|
22
|
use Carp; |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
454
|
|
11
|
6
|
|
|
6
|
|
3101
|
use IO::Scalar; |
|
6
|
|
|
|
|
69314
|
|
|
6
|
|
|
|
|
269
|
|
12
|
6
|
|
|
6
|
|
3668
|
use Pod::Text; |
|
6
|
|
|
|
|
232752
|
|
|
6
|
|
|
|
|
447
|
|
13
|
6
|
|
|
6
|
|
2971
|
use Pod::WSDL::Method; |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
176
|
|
14
|
6
|
|
|
6
|
|
33
|
use Pod::WSDL::Return; |
|
6
|
|
|
|
|
6
|
|
|
6
|
|
|
|
|
108
|
|
15
|
6
|
|
|
6
|
|
19
|
use Pod::WSDL::Param; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
84
|
|
16
|
6
|
|
|
6
|
|
20
|
use Pod::WSDL::Fault; |
|
6
|
|
|
|
|
6
|
|
|
6
|
|
|
|
|
100
|
|
17
|
6
|
|
|
6
|
|
21
|
use Pod::WSDL::Doc; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
136
|
|
18
|
6
|
|
|
6
|
|
2292
|
use Pod::WSDL::Type; |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
150
|
|
19
|
6
|
|
|
6
|
|
28
|
use Pod::WSDL::Writer; |
|
6
|
|
|
|
|
6
|
|
|
6
|
|
|
|
|
105
|
|
20
|
6
|
|
|
6
|
|
18
|
use Pod::WSDL::Utils qw(:writexml :namespaces :messages :types); |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
1077
|
|
21
|
6
|
|
|
6
|
|
27
|
use Pod::WSDL::AUTOLOAD; |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
16274
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
24
|
|
|
|
|
|
|
# ------------------ > "CONSTANTS" ----------------------------------------- # |
25
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
our $VERSION = "0.063"; |
28
|
|
|
|
|
|
|
our @ISA = qw/Pod::WSDL::AUTOLOAD/; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
our $WSDL_METHOD_REGEXP_BEG = qr/^=(?:begin)\s+wsdl\s*\n(.*?)^=(?:cut|end\s+wsdl).*?^\s*sub\s+(\w+)/ims; |
31
|
|
|
|
|
|
|
our $WSDL_METHOD_REGEXP_FOR = qr/^=(?:for)\s+wsdl\s*\n(.*?)\n\n^\s*sub\s+(\w+)/ims; |
32
|
|
|
|
|
|
|
our $WSDL_TYPE_REGEXP_BEG = qr/^=(?:begin)\s+wsdl\s*\n(.*?_ATTR.*?)^=(?:cut|end\s+wsdl)/ims; |
33
|
|
|
|
|
|
|
our $WSDL_TYPE_REGEXP_FOR = qr/^=(?:for)\s+wsdl\s*\n(.*?_ATTR.*?)\n\n/ims; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
our $DEFAULT_BASE_NAME = 'myService'; |
36
|
|
|
|
|
|
|
our $PORT_TYPE_SUFFIX_NAME = 'Handler'; |
37
|
|
|
|
|
|
|
our $BINDING_SUFFIX_NAME = 'SoapBinding'; |
38
|
|
|
|
|
|
|
our $SERVICE_SUFFIX_NAME = 'Service'; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Pod::WSDL::AUTOLOAD uses this |
41
|
|
|
|
|
|
|
our %FORBIDDEN_METHODS = ( |
42
|
|
|
|
|
|
|
source => {get => 0, set => 0}, |
43
|
|
|
|
|
|
|
source => {get => 0, set => 0}, |
44
|
|
|
|
|
|
|
baseName => {get => 0, set => 0}, |
45
|
|
|
|
|
|
|
methods => {get => 0, set => 0}, |
46
|
|
|
|
|
|
|
location => {get => 1, set => 1}, |
47
|
|
|
|
|
|
|
namespaces => {get => 0, set => 0}, |
48
|
|
|
|
|
|
|
generateNS => {get => 0, set => 0}, |
49
|
|
|
|
|
|
|
types => {get => 0, set => 0}, |
50
|
|
|
|
|
|
|
writer => {get => 0, set => 0}, |
51
|
|
|
|
|
|
|
standardTypeArrays => {get => 0, set => 0}, |
52
|
|
|
|
|
|
|
emptymessagewritten => {get => 0, set => 0}, |
53
|
|
|
|
|
|
|
targetNS => {get => 1, set => 1}, |
54
|
|
|
|
|
|
|
); |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
57
|
|
|
|
|
|
|
# --------------- > PUBLIC METHODS ---------------------------------------- # |
58
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# avoid using reserved words with our autoload methods |
61
|
|
|
|
|
|
|
# use => pw_use; no not break backward compatibility |
62
|
|
|
|
|
|
|
sub new { |
63
|
0
|
|
|
0
|
1
|
|
my ($pkg, %data) = @_; |
64
|
0
|
|
|
|
|
|
my $nsnum = 0; |
65
|
|
|
|
|
|
|
|
66
|
0
|
0
|
|
|
|
|
croak "I need a location, died" unless defined $data{location}; |
67
|
0
|
0
|
|
|
|
|
croak "I need a file or module name or a filehandle, died" unless defined $data{source}; |
68
|
|
|
|
|
|
|
|
69
|
0
|
0
|
|
|
|
|
if ( $data{use} ) { |
70
|
0
|
|
|
|
|
|
$data{pw_use} = delete $data{use} ; |
71
|
|
|
|
|
|
|
} |
72
|
0
|
0
|
0
|
|
|
|
$data{pw_use} = $LITERAL_USE if $data{style} and $data{style} eq $DOCUMENT_STYLE and !defined $data{pw_use}; |
|
|
|
0
|
|
|
|
|
73
|
0
|
0
|
0
|
|
|
|
$data{pw_use} = $LITERAL_USE and $data{style} = $DOCUMENT_STYLE if $data{wrapped} and !defined $data{pw_use} and !defined $data{style}; |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
74
|
|
|
|
|
|
|
|
75
|
0
|
|
|
0
|
|
|
my $me = bless { |
76
|
|
|
|
|
|
|
_source => $data{source}, |
77
|
|
|
|
|
|
|
_baseName => undef, |
78
|
|
|
|
|
|
|
_methods => [], |
79
|
|
|
|
|
|
|
_location => $data{location}, |
80
|
|
|
|
|
|
|
_namespaces => {}, |
81
|
|
|
|
|
|
|
_targetNS => undef, |
82
|
|
|
|
|
|
|
_generateNS => sub {return $DEFAULT_NS_DECL . $nsnum++}, |
83
|
0
|
|
0
|
|
|
|
_types => {}, |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
84
|
|
|
|
|
|
|
_writer => new Pod::WSDL::Writer(withDocumentation => $data{withDocumentation}, pretty => $data{pretty}), |
85
|
|
|
|
|
|
|
_standardTypeArrays => {}, |
86
|
|
|
|
|
|
|
_emptymessagewritten => 0, |
87
|
|
|
|
|
|
|
_pw_use => $data{pw_use} || $ENCODED_USE, |
88
|
|
|
|
|
|
|
_style => $data{style} || $RPC_STYLE, |
89
|
|
|
|
|
|
|
_wrapped => $data{wrapped} || 0, |
90
|
|
|
|
|
|
|
}, $pkg; |
91
|
|
|
|
|
|
|
|
92
|
0
|
0
|
0
|
|
|
|
croak "'use' argument may only be one of $ENCODED_USE or $LITERAL_USE, died" if $me->pw_use ne $ENCODED_USE and $me->pw_use ne $LITERAL_USE; |
93
|
0
|
0
|
0
|
|
|
|
croak "'style' argument may only be one of $RPC_STYLE or $DOCUMENT_STYLE, died" if $me->style ne $RPC_STYLE and $me->style ne $DOCUMENT_STYLE; |
94
|
0
|
0
|
0
|
|
|
|
croak "The combination of use=$ENCODED_USE and style=$DOCUMENT_STYLE is not valid, died" if ($me->style eq $DOCUMENT_STYLE and $me->pw_use eq $ENCODED_USE); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
## AHICOX 10/12/2006 |
97
|
|
|
|
|
|
|
## this is a quick and dirty hack to set the baseName |
98
|
|
|
|
|
|
|
## the baseName should probably be set from the POD |
99
|
|
|
|
|
|
|
## source (which is why it's set in _getModuleCode) |
100
|
|
|
|
|
|
|
## this quick hack takes the 'name' parameter when |
101
|
|
|
|
|
|
|
## we create the object, and |
102
|
|
|
|
|
|
|
|
103
|
0
|
|
|
|
|
|
$me->_initSource($data{'source'}); |
104
|
0
|
|
|
|
|
|
$me->_initNS; |
105
|
0
|
|
|
|
|
|
$me->_initTypes; |
106
|
|
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
return $me; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub WSDL { |
111
|
0
|
|
|
0
|
1
|
|
my $me = shift; |
112
|
0
|
|
|
|
|
|
my %args = @_; |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
|
my $wr = $me->writer; |
115
|
0
|
|
|
|
|
|
$wr->prepare; |
116
|
|
|
|
|
|
|
|
117
|
0
|
0
|
|
|
|
|
if (%args) { |
118
|
0
|
0
|
|
|
|
|
$wr->pretty($args{pretty}) if defined $args{pretty}; |
119
|
0
|
0
|
|
|
|
|
$wr->withDocumentation($args{withDocumentation}) if defined $args{withDocumentation}; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
0
|
|
|
|
|
|
$me->writer->comment("WSDL for " . $me->{_location} . " created by " . ref ($me) . " version: $VERSION on " . scalar localtime); |
123
|
0
|
|
|
|
|
|
$me->writer->startTag('wsdl:definitions', targetNamespace => $me->targetNS, %{$me->{_namespaces}}); |
|
0
|
|
|
|
|
|
|
124
|
0
|
|
|
|
|
|
$me->writer->wrNewLine(2); |
125
|
|
|
|
|
|
|
|
126
|
0
|
|
|
|
|
|
$me->_writeTypes; |
127
|
|
|
|
|
|
|
|
128
|
0
|
|
|
|
|
|
$_->writeMessages($me->types, $me->style, $me->wrapped) for @{$me->methods}; |
|
0
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
|
130
|
0
|
|
|
|
|
|
$me->_writePortType; |
131
|
0
|
|
|
|
|
|
$me->_writeBinding; |
132
|
0
|
|
|
|
|
|
$me->_writeService; |
133
|
|
|
|
|
|
|
|
134
|
0
|
|
|
|
|
|
$me->writer->endTag('wsdl:definitions'); |
135
|
0
|
|
|
|
|
|
$me->writer->end; |
136
|
0
|
|
|
|
|
|
return $me->writer->output; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub addNamespace { |
140
|
0
|
|
|
0
|
1
|
|
my $me = shift; |
141
|
0
|
|
|
|
|
|
my $uri = shift; |
142
|
0
|
|
|
|
|
|
my $decl = shift; |
143
|
|
|
|
|
|
|
|
144
|
0
|
0
|
|
|
|
|
croak "I need a namespace, died" unless defined $uri; |
145
|
|
|
|
|
|
|
|
146
|
0
|
0
|
|
|
|
|
defined $decl or $decl = $me->{_generateNS}; |
147
|
|
|
|
|
|
|
|
148
|
0
|
0
|
|
|
|
|
$decl = 'xmlns:' . $decl unless $decl =~ /xmlns:/; |
149
|
|
|
|
|
|
|
|
150
|
0
|
|
|
|
|
|
$me->{_namespaces}->{$decl} = $uri; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
154
|
|
|
|
|
|
|
# ---------------- > INIT METHODS < ---------------------------------------- # |
155
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub _initNS { |
158
|
0
|
|
|
0
|
|
|
my $me = shift; |
159
|
0
|
|
|
|
|
|
my $namespaces = shift; |
160
|
|
|
|
|
|
|
|
161
|
0
|
|
0
|
|
|
|
$namespaces ||= {}; |
162
|
|
|
|
|
|
|
|
163
|
0
|
|
|
|
|
|
$me->addNamespace($namespaces->{$_}, $_) for keys %$namespaces; |
164
|
0
|
|
|
|
|
|
$me->addNamespace($BASIC_NAMESPACES{$_}, $_) for keys %BASIC_NAMESPACES; |
165
|
0
|
|
|
|
|
|
$me->addNamespace($me->targetNS, $IMPL_NS_DECL); |
166
|
0
|
|
|
|
|
|
$me->addNamespace($me->targetNS, $TARGET_NS_DECL); |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub _initSource { |
170
|
0
|
|
|
0
|
|
|
my $me = shift; |
171
|
0
|
|
|
|
|
|
my $src = shift; |
172
|
|
|
|
|
|
|
|
173
|
0
|
|
|
|
|
|
my ($baseName, $contents) = $me->_getModuleCode($src, 1); |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
#set the baseName in the object |
176
|
0
|
|
|
|
|
|
$me->baseName($baseName); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# find =begin wsdl ... =end |
179
|
0
|
|
|
|
|
|
while ($contents =~ /$WSDL_METHOD_REGEXP_BEG/g) { |
180
|
0
|
|
|
|
|
|
$me->_parseMethodPod($2, $1); |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# find =for wsdl |
184
|
0
|
|
|
|
|
|
while ($contents =~ /$WSDL_METHOD_REGEXP_FOR/g) { |
185
|
0
|
|
|
|
|
|
$me->_parseMethodPod($2, $1); |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _initTypes { |
190
|
0
|
|
|
0
|
|
|
my $me = shift; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
|
193
|
0
|
|
|
|
|
|
for my $method (@{$me->{_methods}}) { |
|
0
|
|
|
|
|
|
|
194
|
0
|
|
|
|
|
|
for my $param (@{$method->params},$method->return) { |
|
0
|
|
|
|
|
|
|
195
|
0
|
0
|
|
|
|
|
next unless $param; |
196
|
0
|
0
|
|
|
|
|
unless (exists $XSD_STANDARD_TYPE_MAP{$param->type}) { |
|
|
0
|
|
|
|
|
|
197
|
0
|
|
|
|
|
|
$me->_addType($param->type, $param->array); |
198
|
|
|
|
|
|
|
} elsif ($param->array) { |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
#AHICOX: 10/10/2006 |
201
|
|
|
|
|
|
|
#changed to _standardTypeArrays (was singular) |
202
|
0
|
|
|
|
|
|
$me->{_standardTypeArrays}->{$param->type} = 1; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
0
|
|
|
|
|
|
for my $fault (@{$method->faults}) { |
|
0
|
|
|
|
|
|
|
207
|
0
|
0
|
|
|
|
|
unless (exists $XSD_STANDARD_TYPE_MAP{$fault->type}) { |
208
|
0
|
|
|
|
|
|
$me->_addType($fault->type, 0); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub _addType { |
216
|
0
|
|
|
0
|
|
|
my $me = shift; |
217
|
0
|
|
|
|
|
|
my $name = shift; |
218
|
0
|
|
|
|
|
|
my $array = shift; |
219
|
|
|
|
|
|
|
|
220
|
0
|
0
|
|
|
|
|
if (exists $me->types->{$name}) { |
221
|
0
|
0
|
|
|
|
|
$me->types->{$name}->array($array) if $array; |
222
|
0
|
|
|
|
|
|
return; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
0
|
|
|
|
|
|
my $code = $me->_getModuleCode($name); |
226
|
0
|
|
|
|
|
|
my $pod = ''; |
227
|
0
|
|
|
|
|
|
my $in = $code; |
228
|
0
|
|
|
|
|
|
my $out = ''; |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# collect =begin wsdl ... =end |
231
|
0
|
|
|
|
|
|
while ($code =~ /$WSDL_TYPE_REGEXP_BEG/g) { |
232
|
0
|
|
|
|
|
|
$pod .= "$1\n"; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# collect =for wsdl |
236
|
0
|
|
|
|
|
|
while ($code =~ /$WSDL_TYPE_REGEXP_FOR/g) { |
237
|
0
|
|
|
|
|
|
$pod .= "$1\n"; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
0
|
0
|
|
|
|
|
warn "No pod wsdl found for type '$name'.\n" unless $pod; |
241
|
|
|
|
|
|
|
|
242
|
0
|
|
|
|
|
|
my $IN = new IO::Scalar \$in; |
243
|
0
|
|
|
|
|
|
my $OUT = new IO::Scalar \$out; |
244
|
|
|
|
|
|
|
|
245
|
0
|
|
|
|
|
|
new Pod::Text()->parse_from_filehandle($IN, $OUT); |
246
|
|
|
|
|
|
|
|
247
|
0
|
|
|
|
|
|
$me->types->{$name} = new Pod::WSDL::Type(name => $name, array => $array, pod => $pod, descr => $out, writer => $me->writer); |
248
|
|
|
|
|
|
|
|
249
|
0
|
|
|
|
|
|
for my $attr (@{$me->types->{$name}->attrs}) { |
|
0
|
|
|
|
|
|
|
250
|
0
|
0
|
|
|
|
|
unless (exists $XSD_STANDARD_TYPE_MAP{$attr->type}) { |
|
|
0
|
|
|
|
|
|
251
|
0
|
|
|
|
|
|
$me->_addType($attr->type, $attr->array); |
252
|
|
|
|
|
|
|
} elsif ($attr->array) { |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
#AHICOX: 10/10/2006 |
255
|
|
|
|
|
|
|
#changed to _standardTypeArrays (was singular) |
256
|
0
|
|
|
|
|
|
$me->{_standardTypeArrays}->{$attr->type} = 1; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub _parseMethodPod { |
262
|
0
|
|
|
0
|
|
|
my $me = shift; |
263
|
0
|
|
|
|
|
|
my $methodName = shift; |
264
|
0
|
|
|
|
|
|
my $podData = shift; |
265
|
|
|
|
|
|
|
|
266
|
0
|
|
|
|
|
|
my $method = new Pod::WSDL::Method(name => $methodName, writer => $me->writer); |
267
|
|
|
|
|
|
|
|
268
|
0
|
|
|
|
|
|
my @data = split "\n", $podData; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# Preprocess wsdl pod: trim all lines and concatenate lines not |
271
|
|
|
|
|
|
|
# beginning with wsdl type tokens to previous line. |
272
|
|
|
|
|
|
|
# Ignore first element, if it does not begin with wsdl type token. |
273
|
0
|
|
|
|
|
|
for (my $i = $#data; $i >= 0; $i--) { |
274
|
|
|
|
|
|
|
|
275
|
0
|
0
|
|
|
|
|
if ($data[$i] !~ /^\s*(_INOUT|_IN|_OUT|_RETURN|_DOC|_FAULT|_ONEWAY)/i) { |
276
|
0
|
0
|
|
|
|
|
if ($i > 0) { |
277
|
0
|
|
|
|
|
|
$data[$i - 1] .= " $data[$i]"; |
278
|
0
|
|
|
|
|
|
$data[$i] = ''; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
0
|
|
|
|
|
|
for (@data) { |
284
|
0
|
|
|
|
|
|
s/\s+/ /g; |
285
|
0
|
|
|
|
|
|
s/^ //; |
286
|
0
|
|
|
|
|
|
s/ $//; |
287
|
|
|
|
|
|
|
|
288
|
0
|
0
|
|
|
|
|
if (/^_(INOUT|IN|OUT)\s+/i) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
289
|
0
|
|
|
|
|
|
my $param = new Pod::WSDL::Param($_); |
290
|
0
|
|
|
|
|
|
$method->addParam($param); |
291
|
0
|
0
|
0
|
|
|
|
$me->standardTypeArrays->{$param->type} = 1 if $param->array and $XSD_STANDARD_TYPE_MAP{$param->type}; |
292
|
|
|
|
|
|
|
} elsif (/^_RETURN\s+/i) { |
293
|
0
|
|
|
|
|
|
my $return = new Pod::WSDL::Return($_); |
294
|
0
|
|
|
|
|
|
$method->return($return); |
295
|
0
|
0
|
0
|
|
|
|
$me->standardTypeArrays->{$return->type} = 1 if $return->array and $XSD_STANDARD_TYPE_MAP{$return->type}; |
296
|
|
|
|
|
|
|
} elsif (/^_DOC\s+/i) { |
297
|
0
|
|
|
|
|
|
$method->doc(new Pod::WSDL::Doc($_)); |
298
|
|
|
|
|
|
|
} elsif (/^_FAULT\s+/i) { |
299
|
0
|
|
|
|
|
|
$method->addFault(new Pod::WSDL::Fault($_)); |
300
|
|
|
|
|
|
|
} elsif (/^_ONEWAY\s*$/i) { |
301
|
0
|
|
|
|
|
|
$method->oneway(1); |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
0
|
|
|
|
|
|
push @{$me->{_methods}}, $method; |
|
0
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub _getModuleCode { |
309
|
0
|
|
|
0
|
|
|
my $me = shift; |
310
|
0
|
|
|
|
|
|
my $src = shift; |
311
|
0
|
|
|
|
|
|
my $findNS = shift; |
312
|
|
|
|
|
|
|
|
313
|
0
|
0
|
0
|
|
|
|
if (ref $src and ($src->isa('IO::Handle') or $src->isa('GLOB'))) { |
|
|
|
0
|
|
|
|
|
314
|
0
|
|
|
|
|
|
local $/ = undef; |
315
|
0
|
|
|
|
|
|
my $contents = <$src>; |
316
|
0
|
0
|
|
|
|
|
$me->_setTargetNS($contents) if $findNS; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
##AHICOX: 10/12/2006 |
319
|
|
|
|
|
|
|
##attempt to construct a base name based on the package |
320
|
0
|
|
|
|
|
|
my $baseName = $DEFAULT_BASE_NAME; |
321
|
0
|
|
|
|
|
|
$src =~ /package\s+(.*?)\s*;/s; |
322
|
0
|
0
|
|
|
|
|
if ($1){ |
323
|
0
|
|
|
|
|
|
$baseName = $1; |
324
|
0
|
|
|
|
|
|
$baseName =~ s/::(.)/uc $1/eg; |
|
0
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
0
|
|
|
|
|
|
return ($baseName, $contents); |
328
|
|
|
|
|
|
|
} else { |
329
|
|
|
|
|
|
|
|
330
|
0
|
|
|
|
|
|
my $moduleFile; |
331
|
|
|
|
|
|
|
|
332
|
0
|
0
|
|
|
|
|
if (-e $src) { |
333
|
0
|
|
|
|
|
|
$moduleFile = $src; |
334
|
|
|
|
|
|
|
} else { |
335
|
0
|
|
|
|
|
|
my $subDir = $src; |
336
|
0
|
|
|
|
|
|
$subDir =~ s!::!/!g; |
337
|
|
|
|
|
|
|
|
338
|
0
|
|
|
|
|
|
my @files = map {"$_/$subDir.pm"} @INC; |
|
0
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
|
340
|
0
|
|
|
|
|
|
my $foundPkg = 0; |
341
|
|
|
|
|
|
|
|
342
|
0
|
|
|
|
|
|
for my $file (@files) { |
343
|
0
|
0
|
|
|
|
|
if (-e $file) { |
344
|
0
|
|
|
|
|
|
$moduleFile = $file; |
345
|
0
|
|
|
|
|
|
last; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
0
|
0
|
|
|
|
|
if ($moduleFile) { |
351
|
0
|
0
|
|
|
|
|
open IN, $moduleFile or die "Could not open $moduleFile, died"; |
352
|
0
|
|
|
|
|
|
local $/ = undef; |
353
|
0
|
|
|
|
|
|
my $contents = ; |
354
|
0
|
|
|
|
|
|
close IN; |
355
|
0
|
0
|
|
|
|
|
$me->_setTargetNS($contents) if $findNS; |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
##AHICOX: 10/12/2006 |
358
|
|
|
|
|
|
|
##attempt to construct a base name based on the package |
359
|
0
|
|
|
|
|
|
my $baseName = $DEFAULT_BASE_NAME; |
360
|
0
|
|
|
|
|
|
$contents =~ /package\s+(.*?)\s*;/s; |
361
|
0
|
0
|
|
|
|
|
if ($1){ |
362
|
0
|
|
|
|
|
|
$baseName = $1; |
363
|
0
|
|
|
|
|
|
$baseName =~ s/::(.)/uc $1/eg; |
|
0
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
0
|
|
|
|
|
|
return ($baseName, $contents); |
367
|
|
|
|
|
|
|
} else { |
368
|
0
|
|
|
|
|
|
die "Can't find any file '$src' and can't locate it as a module in \@INC either (\@INC contains " . join (" ", @INC) . "), died"; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
sub _setTargetNS { |
374
|
0
|
|
|
0
|
|
|
my $me = shift; |
375
|
0
|
|
|
|
|
|
my $contents = shift; |
376
|
|
|
|
|
|
|
|
377
|
0
|
|
|
|
|
|
$contents =~ /package\s+(.*?)\s*;/s; |
378
|
|
|
|
|
|
|
|
379
|
0
|
0
|
|
|
|
|
if ($1) { |
380
|
0
|
|
|
|
|
|
my $tmp = $1; |
381
|
0
|
|
|
|
|
|
$tmp =~ s!::!/!g; |
382
|
0
|
|
|
|
|
|
my $serverURL = $me->location; |
383
|
0
|
|
|
|
|
|
$serverURL =~ s!(http(s)??://[^/]*).*!$1!; |
384
|
0
|
|
|
|
|
|
$me->targetNS("$serverURL/$tmp"); |
385
|
|
|
|
|
|
|
} else { |
386
|
0
|
|
|
|
|
|
$me->targetNS($me->location); |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
391
|
|
|
|
|
|
|
# -------------- > OUTPUT UTILITIES < -------------------------------------- # |
392
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- # |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
sub _writeTypes { |
395
|
0
|
|
|
0
|
|
|
my $me = shift; |
396
|
|
|
|
|
|
|
|
397
|
0
|
0
|
0
|
|
|
|
return if keys %{$me->standardTypeArrays} == 0 and keys %{$me->types} == 0; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
|
399
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, 'wsdl:types'); |
400
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, 'schema', targetNamespace => $me->namespaces->{'xmlns:' . $TARGET_NS_DECL}, xmlns => "http://www.w3.org/2001/XMLSchema"); |
401
|
0
|
|
|
|
|
|
$me->writer->wrElem($EMPTY_PREFIX_NAME, "import", namespace => "http://schemas.xmlsoap.org/soap/encoding/"); |
402
|
|
|
|
|
|
|
|
403
|
0
|
|
|
|
|
|
for my $type (sort keys %{$me->standardTypeArrays}) { |
|
0
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, "complexType", name => $ARRAY_PREFIX_NAME . ucfirst $type); |
405
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, "complexContent"); |
406
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, "restriction", base => "soapenc:Array"); |
407
|
0
|
|
|
|
|
|
$me->writer->wrElem($EMPTY_PREFIX_NAME, "attribute", ref => "soapenc:arrayType", "wsdl:arrayType" => 'soapenc:' . $type . '[]'); |
408
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, "restriction"); |
409
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, "complexContent"); |
410
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, "complexType"); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
0
|
|
|
|
|
|
for my $type (values %{$me->types}) { |
|
0
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
|
$type->writeComplexType($me->types); |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
0
|
0
|
|
|
|
|
if ($me->style eq $DOCUMENT_STYLE) { |
418
|
0
|
|
|
|
|
|
for my $method (@{$me->methods}) { |
|
0
|
|
|
|
|
|
|
419
|
0
|
|
|
|
|
|
$method->writeDocumentStyleSchemaElements($me->types); |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, 'schema'); |
424
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, 'wsdl:types'); |
425
|
0
|
|
|
|
|
|
$me->writer->wrNewLine; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
sub _writePortType { |
429
|
0
|
|
|
0
|
|
|
my $me = shift; |
430
|
|
|
|
|
|
|
|
431
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, 'wsdl:portType', name => $me->baseName . $PORT_TYPE_SUFFIX_NAME); |
432
|
|
|
|
|
|
|
|
433
|
0
|
|
|
|
|
|
for my $method (@{$me->{_methods}}) { |
|
0
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
|
$method->writePortTypeOperation; |
435
|
0
|
|
|
|
|
|
$me->writer->wrNewLine; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, 'wsdl:portType'); |
439
|
0
|
|
|
|
|
|
$me->writer->wrNewLine(1); |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
sub _writeBinding { |
443
|
0
|
|
|
0
|
|
|
my $me = shift; |
444
|
|
|
|
|
|
|
|
445
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, 'wsdl:binding', name => $me->baseName . $BINDING_SUFFIX_NAME, type => $IMPL_NS_DECL . ':' . $me->baseName . $PORT_TYPE_SUFFIX_NAME); |
446
|
0
|
|
|
|
|
|
$me->writer->wrElem($EMPTY_PREFIX_NAME, "wsdlsoap:binding", style => $me->style, transport => "http://schemas.xmlsoap.org/soap/http"); |
447
|
0
|
|
|
|
|
|
$me->writer->wrNewLine; |
448
|
|
|
|
|
|
|
|
449
|
0
|
|
|
|
|
|
for my $method (@{$me->methods}) { |
|
0
|
|
|
|
|
|
|
450
|
0
|
|
|
|
|
|
$method->writeBindingOperation($me->targetNS, $me->pw_use); |
451
|
0
|
|
|
|
|
|
$me->writer->wrNewLine; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, 'wsdl:binding'); |
455
|
0
|
|
|
|
|
|
$me->writer->wrNewLine; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
sub _writeService { |
459
|
0
|
|
|
0
|
|
|
my $me = shift; |
460
|
|
|
|
|
|
|
|
461
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, 'wsdl:service', name => $me->baseName . $PORT_TYPE_SUFFIX_NAME . $SERVICE_SUFFIX_NAME); |
462
|
0
|
|
|
|
|
|
$me->writer->wrElem($START_PREFIX_NAME, 'wsdl:port', binding => $IMPL_NS_DECL . ':' . $me->baseName . $BINDING_SUFFIX_NAME, name => $me->baseName); |
463
|
0
|
|
|
|
|
|
$me->writer->wrElem($EMPTY_PREFIX_NAME, "wsdlsoap:address", location => $me->location); |
464
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, 'wsdl:port'); |
465
|
0
|
|
|
|
|
|
$me->writer->wrElem($END_PREFIX_NAME, 'wsdl:service'); |
466
|
|
|
|
|
|
|
|
467
|
0
|
|
|
|
|
|
$me->writer->wrNewLine; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
1; |
471
|
|
|
|
|
|
|
__END__ |