File Coverage

blib/lib/Elive/Connection.pm
Criterion Covered Total %
statement 39 136 28.6
branch 0 62 0.0
condition 0 35 0.0
subroutine 13 21 61.9
pod n/a
total 52 254 20.4


line stmt bran cond sub pod time code
1             package Elive::Connection;
2 15     15   142183 use warnings; use strict;
  15     15   34  
  15         552  
  15         75  
  15         20  
  15         738  
3              
4             our $VERSION = '0.02';
5              
6 15     15   72 use Carp;
  15         22  
  15         927  
7 15     15   90 use File::Spec::Unix;
  15         34  
  15         386  
8 15     15   6566 use HTML::Entities;
  15         66987  
  15         1430  
9 15     15   122 use Scalar::Util;
  15         23  
  15         777  
10             require SOAP::Lite;
11 15     15   4073 use URI;
  15         42792  
  15         382  
12 15     15   88 use URI::Escape qw{};
  15         22  
  15         235  
13 15     15   4141 use Try::Tiny;
  15         8610  
  15         800  
14 15     15   3360 use YAML::Syck;
  15         12087  
  15         961  
15              
16 15     15   3151 use parent qw{Class::Accessor Class::Data::Inheritable};
  15         1816  
  15         100  
17              
18 15     15   34015 use Elive;
  15         31  
  15         404  
19 15     15   75 use Elive::Util;
  15         20  
  15         18592  
20              
21             =head1 NAME
22              
23             Elive::Connection - Manage Elluminate Live SOAP connections.
24              
25             =head1 DESCRIPTION
26              
27             This is an abstract class for managing connections and related resources.
28              
29             Most of the time, you'll be dealing with specific class instances; See L L.
30              
31             =cut
32              
33             __PACKAGE__->mk_accessors( qw{url user pass _soap debug type timeout} );
34              
35             =head1 METHODS
36              
37             =cut
38              
39             =head2 connect
40              
41             my $sdk_c1 = Elive::Connection->connect('http://someserver.com/test',
42             'user1', 'pass1', debug => 1,
43             );
44              
45             my $url1 = $sdk_c1->url; # 'http://someserver.com/test'
46              
47             my $sdk_c2 = Elive::Connection->connect('http://user2:pass2@someserver.com/test');
48             my $url2 = $sdk_c2->url; # 'http://someserver.com/test'
49              
50             Establishes a logical SOAP connection.
51              
52             =cut
53              
54             sub connect {
55 0     0     my ($class, $url, $user, $pass, %opt) = @_;
56             #
57             # default connection - for backwards compatibility
58             #
59 0           require Elive::Connection::SDK;
60 0           return Elive::Connection::SDK->connect($url, $user => $pass, %opt);
61             }
62              
63             sub _connect {
64 0     0     my ($class, $url, $user, $pass, %opt) = @_;
65              
66 0   0       my $debug = $opt{debug}||0;
67              
68 0           $url =~ s{/$}{}x;
69              
70 0           my $uri_obj = URI->new($url);
71              
72 0           my $userinfo = $uri_obj->userinfo;
73              
74 0 0         if ($userinfo) {
75              
76             #
77             # extract and remove any credentials from the url
78             #
79              
80 0           my ($uri_user, $uri_pass) = split(':',$userinfo, 2);
81              
82 0 0         if ($uri_user) {
83 0 0 0       if ($user && $user ne $uri_user) {
84 0           carp 'ignoring user in URI scheme - overridden';
85             }
86             else {
87 0           $user = URI::Escape::uri_unescape($uri_user);
88             }
89             }
90              
91 0 0         if ($uri_pass) {
92 0 0 0       if ($pass && $pass ne $uri_pass) {
93 0           carp 'ignoring pass in URI scheme - overridden';
94             }
95             else {
96 0           $pass = URI::Escape::uri_unescape($uri_pass);
97             }
98             }
99             }
100             else {
101 0 0         warn "no credentials in url: $url" if $debug;
102             }
103              
104 0           my $uri_path = $uri_obj->path;
105              
106 0 0         $pass = '' unless defined $pass;
107              
108 0           my @path = File::Spec::Unix->splitdir($uri_path);
109              
110 0 0 0       shift (@path)
111             if (@path && !$path[0]);
112              
113 0 0 0       pop (@path)
114             if (@path && $path[-1] eq 'webservice.event');
115              
116             #
117             # normalise the connection url by removing suffixes. The following
118             # all reduce to http://mysite/myinst:
119             # -- http://mysite/myinst/webservice.event
120             # -- http://mysite/myinst/v2
121             # -- http://mysite/myinst/v2/webservice.event
122             # -- http://mysite/myinst/default
123             # -- http://mysite/myinst/default/webservice.event
124             #
125             # there's some ambiguity, an instance named v1 ... v9 will cause trouble!
126             #
127              
128 0 0 0       if (@path && $path[-1] =~ m{^v(\d+)$}) {
129 0 0         croak "unsupported standard bridge version v${1}, endpoint path: ". File::Spec::Unix->catdir(@path, 'webservice.event')
130             unless $1 == 2;
131 0           pop(@path);
132             }
133              
134 0           $uri_obj->path(File::Spec::Unix->catdir(@path));
135              
136 0           my $soap_url = $uri_obj->as_string;
137              
138             #
139             # remove any embedded credentials
140             #
141 0 0         $soap_url =~ s{\Q${userinfo}\E\@}{} if $userinfo;
142              
143 0           my $self = {};
144 0           bless $self, $class;
145              
146 0           $self->url($soap_url);
147 0           $self->user($user);
148 0           $self->pass($pass);
149 0           $self->debug($debug);
150 0           $self->timeout($opt{timeout});
151              
152 0           return $self
153             }
154              
155             sub _check_for_errors {
156 0     0     my $class = shift;
157 0           my $som = shift;
158              
159 0 0         die "No response from server\n"
160             unless $som;
161              
162 0 0         die $som->fault->{ faultstring }."\n" if ($som->fault);
163              
164 0           my $result = $som->result;
165 0           my @paramsout = $som->paramsout;
166              
167 0 0         warn YAML::Syck::Dump({result => $result, paramsout => \@paramsout})
168             if ($class->debug);
169              
170 0           my @results = ($result, @paramsout);
171              
172 0           foreach my $result (@results) {
173 0 0         next unless Scalar::Util::reftype($result);
174            
175             #
176             # Look for Elluminate-specific errors
177             #
178 0 0 0       if ($result->{Code}
179             && (my $code = $result->{Code}{Value})) {
180              
181             #
182             # Elluminate error!
183             #
184            
185 0           my $reason = $result->{Reason}{Text};
186 0           my @stack_trace;
187              
188 0           my $stack = $result->{Detail}{Stack};
189              
190 0 0 0       if ($stack && (my $trace = $stack->{Trace})) {
191 0 0         @stack_trace = (Elive::Util::_reftype($trace) eq 'ARRAY'
192             ? @$trace
193             : $trace);
194              
195             }
196              
197 0           my %seen;
198              
199 0 0         my @error = grep {$_ && !$seen{$_}++} ($code, $reason, @stack_trace);
  0            
200 0 0         my $msg = @error ? join(' ', @error) : YAML::Syck::Dump($result);
201 0           die "$msg\n";
202             }
203             }
204             }
205              
206             =head2 check_command
207              
208             my $command1 = Elive->check_command([qw{getUser listUser}])
209             my $command2 = Elive->check_command(deleteUser => 'd')
210              
211             Find the first known command in the list. Raise an error if it's unknown;
212              
213             See also: elive_lint_config.
214              
215             =cut
216              
217             sub check_command {
218 0     0     my $class = shift;
219 0           my $commands = shift;
220 0           my $crud = shift; #create, read, update or delete
221 0           my $params = shift;
222              
223 0 0         if (Elive::Util::_reftype($commands) eq 'CODE') {
224 0           $commands = $commands->($crud, $params);
225             }
226              
227 0 0         $commands = [$commands]
228             unless Elive::Util::_reftype($commands) eq 'ARRAY';
229              
230 0           my $usage = "usage: \$class->check_command(\$name[,'c'|'r'|'u'|'d'])";
231 0 0 0       die $usage unless @$commands && $commands->[0];
232              
233 0           my $known_commands = $class->known_commands;
234              
235 0           die "no known commands for class: $class"
236 0 0 0       unless $known_commands && (keys %{$known_commands});
237              
238 0           my ($command) = grep {exists $known_commands->{$_}} @$commands;
  0            
239              
240 0 0         croak "Unknown command(s): @{$commands}"
  0            
241             unless $command;
242              
243 0 0         if ($crud) {
244 0           $crud = lc(substr($crud,0,1));
245 0 0         die $usage
246             unless $crud =~ m{^[c|r|u|d]$}xi;
247              
248 0           my $command_type = $known_commands->{$command};
249 0 0 0       die "misconfigured command: $command"
250             unless $command_type && $command_type =~ m{^[c|r|u|d]+$}xi;
251              
252 0 0         die "command $command. Type mismatch. Expected $crud, found $command_type"
253             unless ($crud =~ m{[$command_type]}i);
254             }
255              
256 0           return $command;
257             }
258              
259             =head2 known_commands
260              
261             Returns an array of hash-value pairs for all Elluminate I commands
262             required by Elive. This list is cross-checked by the script elive_lint_config.
263              
264             =cut
265              
266             =head2 call
267              
268             my $som = $self->call( $cmd, %params );
269              
270             Performs an Elluminate SOAP method call. Returns the response as a
271             SOAP::SOM object.
272              
273             =cut
274              
275             sub call {
276 0     0     my ($self, $cmd, %params) = @_;
277              
278 0           $cmd = $self->check_command($cmd, undef, \%params);
279              
280 0           my @soap_params = $self->_preamble($cmd);
281              
282 0           foreach my $name (keys %params) {
283              
284 0           my $value = $params{$name};
285              
286 0     0     $value = SOAP::Data->type(string => Elive::Util::string($value))
287             unless (Scalar::Util::blessed($value)
288 0 0 0       && try {$value->isa('SOAP::Data')});
289              
290 0           my $soap_param = $value->name($name);
291              
292 0           push (@soap_params, $soap_param);
293             }
294              
295 0           my $som = $self->soap->call( @soap_params );
296              
297 0           return $som;
298             }
299              
300             =head2 disconnect
301              
302             Closes a connection.
303              
304             =cut
305              
306             sub disconnect {
307 0     0     my $self = shift;
308 0           return;
309             }
310              
311             =head2 url
312              
313             my $url1 = $connection1->url;
314             my $url2 = $connection2->url;
315              
316             Returns a restful url for the connection.
317              
318             =cut
319              
320             sub DESTROY {
321 0     0     shift->disconnect;
322 0           return;
323             }
324              
325             =head1 SEE ALSO
326              
327             L L L
328              
329             =cut
330              
331             1;