Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[r418]: trunk / lib / SOAP / SOM.pm Maximize Restore History

Download this file

SOM.pm    249 lines (212 with data), 7.1 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
package SOAP::SOM;
use strict;
use Carp ();
use SOAP::Lite::Utils;
use SOAP::Fault;
use SOAP::Server::Object;
sub BEGIN {
no strict 'refs';
my %path = (
root => '/',
envelope => '/Envelope',
body => '/Envelope/Body',
header => '/Envelope/Header',
headers => '/Envelope/Header/[>0]',
fault => '/Envelope/Body/Fault',
faultcode => '/Envelope/Body/Fault/faultcode',
faultstring => '/Envelope/Body/Fault/faultstring',
faultactor => '/Envelope/Body/Fault/faultactor',
faultdetail => '/Envelope/Body/Fault/detail',
);
for my $method ( keys %path ) {
*$method = sub {
my $self = shift;
ref $self or return $path{$method};
Carp::croak
"Method '$method' is readonly and doesn't accept any parameters"
if @_;
return $self->valueof( $path{$method} );
};
}
my %results = (
method => '/Envelope/Body/[1]',
result => '/Envelope/Body/[1]/[1]',
freeform => '/Envelope/Body/[>0]',
paramsin => '/Envelope/Body/[1]/[>0]',
paramsall => '/Envelope/Body/[1]/[>0]',
paramsout => '/Envelope/Body/[1]/[>1]'
);
for my $method ( keys %results ) {
*$method = sub {
my $self = shift;
ref $self or return $results{$method};
Carp::croak
"Method '$method' is readonly and doesn't accept any parameters"
if @_;
defined $self->fault
? return
: return $self->valueof( $results{$method} );
};
}
for my $method (qw(o_child o_value o_lname o_lattr o_qname))
{ # import from SOAP::Utils
*$method = \&{'SOAP::Utils::' . $method};
}
__PACKAGE__->__mk_accessors('context');
}
# use object in boolean context return true/false on last match
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success';
use overload fallback => 1, 'bool' => sub { @{shift->{_current}} > 0 };
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $content = shift;
SOAP::Trace::objects('()');
return bless {_content => $content, _current => [$content]} => $class;
}
sub parts {
my $self = shift;
if (@_) {
$self->context->packager->parts(@_);
return $self;
}
else {
return $self->context->packager->parts;
}
}
sub is_multipart {
my $self = shift;
return defined( $self->parts );
}
sub current {
my $self = shift;
$self->{_current} = [@_], return $self if @_;
return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
}
sub valueof {
my $self = shift;
local $self->{_current} = $self->{_current};
$self->match(shift) if @_;
return
wantarray ? map { o_value($_) } @{$self->{_current}}
: @{$self->{_current}} ? o_value( $self->{_current}->[0] )
: undef;
}
sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
wantarray
? map { bless $_ => 'SOAP::Header' } shift->dataof(@_)
: do { # header returned by ->dataof can be undef in scalar context
my $header = shift->dataof(@_);
ref $header ? bless( $header => 'SOAP::Header' ) : undef;
};
}
sub dataof {
my $self = shift;
local $self->{_current} = $self->{_current};
$self->match(shift) if @_;
return
wantarray ? map { $self->_as_data($_) } @{$self->{_current}}
: @{$self->{_current}} ? $self->_as_data( $self->{_current}->[0] )
: undef;
}
sub namespaceuriof {
my $self = shift;
local $self->{_current} = $self->{_current};
$self->match(shift) if @_;
return
wantarray ? map { ( SOAP::Utils::splitlongname( o_lname($_) ) )[0] }
@{$self->{_current}}
: @{$self->{_current}}
? ( SOAP::Utils::splitlongname( o_lname( $self->{_current}->[0] ) ) )[0]
: undef;
}
#sub _as_data {
# my $self = shift;
# my $pointer = shift;
#
# SOAP::Data
# -> new(prefix => '',
# name => o_qname($pointer),
# name => o_lname($pointer), attr => o_lattr($pointer))
# -> set_value(o_value($pointer));
#}
sub _as_data {
my $self = shift;
my $node = shift;
my $data = SOAP::Data->new( prefix => '',
# name => o_qname has side effect: sets namespace !
name => SOAP::Lite::Utils::o_qname($node),
name => SOAP::Lite::Utils::o_lname($node),
attr => SOAP::Lite::Utils::o_lattr($node) );
if ( defined SOAP::Lite::Utils::o_child($node) ) {
my @children;
foreach my $child ( @{ SOAP::Lite::Utils::o_child($node) } ) {
push( @children, $self->_as_data($child) );
}
$data->set_value( \SOAP::Data->value(@children) );
}
else {
$data->set_value( SOAP::Lite::Utils::o_value($node) );
}
return $data;
}
sub match {
my $self = shift;
my $path = shift;
$self->{_current} = [
$path =~ s!^/!! || !@{$self->{_current}}
? $self->_traverse( $self->{_content}, 1 => split '/' => $path )
: map { $self->_traverse_tree( o_child($_), split '/' => $path ) }
@{$self->{_current}}];
return $self;
}
sub _traverse {
my $self = shift;
my ( $pointer, $itself, $path, @path ) = @_;
die "Incorrect parameter" unless $itself =~ /^\d*$/;
if ( $path && substr( $path, 0, 1 ) eq '{' ) {
$path = join '/', $path, shift @path while @path && $path !~ /}/;
}
my ( $op, $num ) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/
if defined $path;
return $pointer unless defined $path;
$op = '==' unless $op;
$op .= '=' if $op eq '=' || $op eq '!';
my $numok = defined $num && eval "$itself $op $num";
my $nameok = ( o_lname($pointer) || '' ) =~ /(?:^|\})$path$/
if defined $path; # name can be with namespace
my $anynode = $path eq '';
unless ($anynode) {
if (@path) {
return if defined $num && !$numok || !defined $num && !$nameok;
}
else {
return $pointer
if defined $num && $numok || !defined $num && $nameok;
return;
}
}
my @walk;
push @walk, $self->_traverse_tree( [$pointer], @path ) if $anynode;
push @walk,
$self->_traverse_tree( o_child($pointer),
$anynode ? ( $path, @path ) : @path );
return @walk;
}
sub _traverse_tree {
my $self = shift;
my ( $pointer, @path ) = @_;
# can be list of children or value itself. Traverse only children
return unless ref $pointer eq 'ARRAY';
my $itself = 1;
grep { defined }
map { $self->_traverse( $_, $itself++, @path ) }
grep {
!ref o_lattr($_)
|| !exists o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"}
|| o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ne '0'
} @$pointer;
}
1;
__END__