File Coverage

blib/lib/App/soapcli.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -c
2              
3             package App::soapcli;
4              
5             =head1 NAME
6              
7             App::soapcli - SOAP client for CLI with YAML and JSON input and output
8              
9             =head1 SYNOPSIS
10              
11             my $app = App::soapcli->new(argv => [qw( calculator.yml calculator.url )]);
12             $app->run;
13              
14             =head1 DESCRIPTION
15              
16             This is core module for L utility.
17              
18             =cut
19              
20              
21 7     7   94488 use v5.10;
  7         19  
  7         251  
22              
23 7     7   27 use strict;
  7         7  
  7         259  
24 7     7   24 use warnings;
  7         14  
  7         234  
25              
26             our $VERSION = '0.0300';
27              
28 7     7   2734 use Log::Report 'soapcli', syntax => 'SHORT';
  7         484573  
  7         33  
29              
30 7     7   2736 use XML::LibXML;
  0            
  0            
31             use XML::Compile::WSDL11;
32             use XML::Compile::SOAP11;
33             use XML::Compile::SOAP12;
34             use XML::Compile::Transport::SOAPHTTP;
35              
36             use Perl6::Slurp qw(slurp);
37             use Getopt::Long::Descriptive ();
38             use HTTP::Tiny ();
39             use YAML::Syck ();
40             use YAML::XS ();
41             use JSON::PP ();
42              
43              
44             =head1 ATTRIBUTES
45              
46             =over
47              
48             =item argv : ArrayRef
49              
50             Arguments list with options for the application.
51              
52             =back
53              
54             =head1 METHODS
55              
56             =over
57              
58             =item new (I<%args>)
59              
60             The default constructor.
61              
62             =cut
63              
64             sub new {
65             my ($class, %args) = @_;
66             return bless {
67             argv => [],
68             extra_argv => [],
69             %args,
70             } => $class;
71             };
72              
73              
74             =item new_with_options (%args)
75              
76             The constructor which initializes the object based on C<@ARGV> variable or
77             based on array reference if I option is set.
78              
79             =cut
80              
81             sub new_with_options {
82             my ($class, %args) = @_;
83              
84             my $argv = delete $args{argv};
85             local @ARGV = $argv ? @$argv : @ARGV;
86              
87             my ($opts, $usage) = Getopt::Long::Descriptive::describe_options(
88             "$0 %o data.yml [http://schema | schema.url] [endpoint#port] [operation]",
89             [ 'verbose|v', 'verbose mode with messages trace', ],
90             [ 'dump-xml-request|x', 'dump request as XML document', ],
91             [ 'explain|e', 'explain webservice as Perl code', ],
92             [ 'help|h', 'print usage message and exit', ],
93             [ 'json|j', 'output result as JSON document', ],
94             [ 'yaml|y', 'output result as YAML document', ],
95             );
96              
97             die $usage->text if $opts->help or @ARGV < 1;
98              
99             return $class->new(extra_argv => [@ARGV], %$opts);
100             };
101              
102              
103             =item run ()
104              
105             Run the main job
106              
107             =back
108              
109             =cut
110              
111             sub run {
112             my ($self) = @_;
113              
114             my $arg_request = $self->{extra_argv}->[0];
115             my $servicename = do {
116             if ($arg_request =~ /^{/ or $arg_request eq '-') {
117             '';
118             }
119             else {
120             my $arg = $arg_request;
121             $arg =~ s/\.(url|yml|wsdl)$//;
122             $arg;
123             };
124             };
125              
126              
127             my $arg_wsdl = $self->{extra_argv}->[1];
128              
129             my $wsdlsrc = do {
130             if (defined $self->{extra_argv}->[1]) {
131             $self->{extra_argv}->[1];
132             }
133             else {
134             my $name = $servicename;
135             LOOP: {
136             do {
137             if (-f "$name.wsdl") {
138             $name .= '.wsdl';
139             last;
140             }
141             elsif (-f "$name.url") {
142             $name .= '.url';
143             last;
144             };
145             $name =~ s/[._-][^._-]*$//;
146             }
147             while ($name =~ /[._-]/);
148             $name .= '.wsdl';
149             };
150             $name;
151             };
152             };
153              
154             my $wsdldata = do {
155             if ($wsdlsrc =~ /\.url$/ or $wsdlsrc =~ m{://}) {
156             my $url = $wsdlsrc =~ m{://} ? $wsdlsrc : slurp($wsdlsrc, {chomp=>1});
157             chomp $url;
158             HTTP::Tiny->new->get($url)->{content};
159             }
160             elsif ($wsdlsrc =~ /\.wsdl$/ and -f $wsdlsrc) {
161             slurp($wsdlsrc);
162             };
163             } or die "Can not read WSDL data from `$wsdlsrc': $!\n";
164              
165              
166             my $arg_endpoint = $self->{extra_argv}->[2];
167              
168              
169             my $request = do {
170             if ($arg_request =~ /^{/) {
171             $arg_request =~ s/\n//g;
172             JSON::PP->new->utf8->relaxed->allow_barekey->decode($arg_request);
173             }
174             elsif ($arg_request eq '-') {
175             YAML::Syck::LoadFile(\*STDIN);
176             }
177             elsif ($arg_request =~ /\.json$/) {
178             my $content = slurp($arg_request);
179             $content =~ s/\n//g;
180             JSON::PP->new->utf8->relaxed->allow_barekey->decode($content);
181             }
182             else {
183             YAML::Syck::LoadFile($arg_request);
184             }
185             };
186              
187             die "Wrong request format from `$arg_request'\n" unless ref $request||'' eq 'HASH';
188              
189              
190             my $arg_operation = $self->{extra_argv}->[3];
191              
192             my $wsdldom = XML::LibXML->load_xml(string => $wsdldata);
193             my $imports = eval { $wsdldom->find('/wsdl:definitions/wsdl:types/xsd:schema/xsd:import') };
194              
195             my @schemas = eval { map { $_->getAttribute('schemaLocation') } $imports->get_nodelist };
196              
197             my $wsdl = XML::Compile::WSDL11->new;
198              
199             $wsdl->importDefinitions(\@schemas);
200             $wsdl->addWSDL($wsdldom);
201              
202             $wsdl->addHook(type => '{http://www.w3.org/2001/XMLSchema}hexBinary', before => sub {
203             my ($doc, $value, $path) = @_;
204             defined $value or return;
205             $value =~ m/^[0-9a-fA-F]+$/ or error __x"{path} contains illegal characters", path => $path;
206             return pack 'H*', $value;
207             });
208              
209             my $port = do {
210             if (defined $arg_endpoint and $arg_endpoint =~ /#(.*)$/) {
211             $1;
212             }
213             else {
214             undef;
215             }
216             };
217              
218             my $endpoint = do {
219             if (defined $arg_endpoint and $arg_endpoint !~ /^#/) {
220             my $url = $arg_endpoint =~ m{://} ? $arg_endpoint : slurp($arg_endpoint, {chomp=>1});
221             chomp $url;
222             $url =~ s/^(.*)#(.*)$/$1/;
223             $url;
224             }
225             else {
226             $wsdl->endPoint(
227             defined $port ? ( port => $port ) : (),
228             );
229             }
230             };
231              
232              
233             my $operation = do {
234             if (defined $arg_operation) {
235             $arg_operation
236             }
237             else {
238             my $o = (keys %$request)[0];
239             $request = $request->{$o};
240             $o;
241             }
242             };
243              
244              
245             my $http = XML::Compile::Transport::SOAPHTTP->new(
246             address => $endpoint,
247             );
248              
249             $http->userAgent->agent("soapcli/$VERSION");
250             $http->userAgent->env_proxy;
251              
252             my $action = eval {
253             $wsdl->operation(
254             $operation,
255             defined $port ? ( port => $port ) : (),
256             )->soapAction()
257             };
258              
259             my $transport = $http->compileClient(
260             action => $action,
261             );
262              
263              
264             $wsdl->compileCalls(
265             sloppy_floats => 1,
266             sloppy_integers => 1,
267             transport => $transport,
268             defined $port ? ( port => $port ) : (),
269             $self->{dump_xml_request} ? ( transport => sub { print $_[0]->toString(1); goto EXIT } ) : (),
270             );
271              
272             if ($self->{explain}) {
273             die $wsdl->explain($operation, PERL => 'INPUT');
274             }
275              
276             my ($response, $trace) = $wsdl->call($operation, $request);
277              
278             my $json = JSON::PP->new->utf8->allow_nonref;
279              
280             if ($self->{verbose}) {
281             say "---";
282             $trace->printRequest;
283             if ($self->{yaml}) {
284             say YAML::XS::Dump({ Data => { $operation => $request } });
285             } else {
286             say "---";
287             say $json->encode({ $operation => $request });
288             }
289             say "---";
290             $trace->printResponse;
291             if ($self->{yaml}) {
292             say YAML::XS::Dump({ Data => $response });
293             } else {
294             say "---";
295             say $json->encode($response);
296             }
297             }
298             else {
299             if ($self->{yaml}) {
300             print YAML::XS::Dump($response);
301             } else {
302             say $json->encode($response);
303             }
304             }
305              
306             EXIT:
307             return 1;
308             };
309              
310              
311             1;
312              
313              
314             =head1 SEE ALSO
315              
316             L, L.
317              
318             =head1 AUTHOR
319              
320             Piotr Roszatycki
321              
322             =head1 LICENSE
323              
324             Copyright (c) 2011-2015 Piotr Roszatycki .
325              
326             This is free software; you can redistribute it and/or modify it under
327             the same terms as perl itself.
328              
329             See L