File Coverage

lib/XML/Compile/SOAP/Trace.pm
Criterion Covered Total %
statement 15 80 18.7
branch 0 34 0.0
condition 0 18 0.0
subroutine 5 18 27.7
pod 13 13 100.0
total 33 163 20.2


line stmt bran cond sub pod time code
1             # Copyrights 2007-2019 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution XML-Compile-SOAP. Meta-POD processed
6             # with OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package XML::Compile::SOAP::Trace;
10 7     7   1148 use vars '$VERSION';
  7         16  
  7         390  
11             $VERSION = '3.26';
12              
13              
14 7     7   106 use warnings;
  7         13  
  7         180  
15 7     7   33 use strict;
  7         12  
  7         170  
16              
17 7     7   61 use Log::Report 'xml-compile-soap', syntax => 'REPORT';
  7         10  
  7         43  
18             # no syntax SHORT, because we have own error()
19              
20 7     7   1589 use IO::Handle;
  7         18  
  7         8981  
21              
22             my @xml_parse_opts = (load_ext_dtd => 0, recover => 1, no_network => 1);
23              
24              
25             sub new($)
26 0     0 1   { my ($class, $data) = @_;
27 0           bless $data, $class;
28             }
29              
30              
31 0     0 1   sub start() {shift->{start}}
32              
33              
34 0     0 1   sub date() {scalar localtime shift->start}
35              
36              
37             sub error(;$)
38 0     0 1   { my $self = shift;
39 0   0       my $errors = $self->{errors} ||= [];
40              
41 0           foreach my $err (@_)
42 0 0         { $err = __$err unless ref $err;
43 0 0         $err = Log::Report::Exception->new(reason => 'ERROR', message => $err)
44             unless $err->isa('Log::Report::Exception');
45 0           push @$errors, $err;
46             }
47              
48 0 0         wantarray ? @$errors : $errors->[0];
49             }
50              
51              
52 0 0   0 1   sub errors() { @{shift->{errors} || []} }
  0            
53              
54              
55             sub elapse($)
56 0     0 1   { my ($self, $kind) = @_;
57 0 0         defined $kind ? $self->{$kind.'_elapse'} : $self->{elapse};
58             }
59              
60              
61 0     0 1   sub request() {shift->{http_request}}
62              
63              
64 0     0 1   sub response() {shift->{http_response}}
65              
66              
67 0     0 1   sub responseDOM() {shift->{response_dom}}
68              
69              
70             sub printTimings(;$)
71 0     0 1   { my ($self, $fh) = @_;
72 0 0         my $oldfh = $fh ? (select $fh) : undef;
73 0           print "Call initiated at: ",$self->date, "\n";
74 0           print "SOAP call timing:\n";
75 0           printf " encoding: %7.2f ms\n", $self->elapse('encode') *1000;
76 0           printf " stringify: %7.2f ms\n", $self->elapse('stringify') *1000;
77 0           printf " connection: %7.2f ms\n", $self->elapse('connect') *1000;
78              
79 0           my $dp = $self->elapse('parse');
80 0 0         if(defined $dp) {printf " parsing: %7.2f ms\n", $dp *1000 }
  0            
81 0           else {printf " parsing: - (no xml to parse)\n" }
82              
83 0           my $dt = $self->elapse('decode');
84 0 0         if(defined $dt) {printf " decoding: %7.2f ms\n", $dt *1000 }
  0            
85 0           else {print " decoding: - (no xml to convert)\n"}
86              
87 0           my $el = $self->elapse;
88 0 0         printf " total time: %7.2f ms = %.3f seconds\n\n", $el*1000, $el
89             if defined $el;
90              
91 0 0         select $oldfh if $oldfh;
92             }
93              
94              
95             sub printRequest(;$%)
96 0     0 1   { my $self = shift;
97 0 0         my $request = $self->request or return;
98              
99 0 0         my $fh = @_%2 ? shift : *STDOUT;
100 0           my %args = @_;
101              
102 0   0       my $format = $args{pretty_print} || 0;
103 0 0 0       if($format && $request->content_type =~ m/xml/i)
104 0           { $fh->print("\n", $request->headers->as_string, "\n");
105 0           XML::LibXML
106             ->load_xml(string => $request->content, @xml_parse_opts)
107             ->toFH($fh, $format);
108             }
109             else
110 0           { my $req = $request->as_string;
111 0           $req =~ s/^/ /gm;
112 0           $fh->print("Request:\n$req\n");
113             }
114             }
115              
116              
117             sub printResponse(;$%)
118 0     0 1   { my $self = shift;
119 0 0         my $resp = $self->response or return;
120              
121 0 0         my $fh = @_%2 ? shift : *STDOUT;
122 0           my %args = @_;
123              
124 0   0       my $format = $args{pretty_print} || 0;
125 0 0 0       if($format && $resp->content_type =~ m/xml/i)
126 0           { $fh->print("\n", $resp->headers->as_string, "\n");
127 0   0       XML::LibXML->load_xml
128             ( string => ($resp->decoded_content || $resp->content)
129             , @xml_parse_opts
130             )->toFH($fh, $format);
131             }
132             else
133 0           { my $resp = $resp->as_string;
134 0           $resp =~ s/^/ /gm;
135 0           $fh->print("Response:\n$resp\n");
136             }
137             }
138              
139              
140             sub printErrors(;$)
141 0     0 1   { my ($self, $fh) = @_;
142 0   0       $fh ||= *STDERR;
143              
144 0           print $fh $_->toString for $self->errors;
145              
146 0 0         if(my $d = $self->{decode_errors}) # Log::Report::Dispatcher::Try object
147 0           { print $fh "Errors while decoding:\n";
148 0           foreach my $e ($d->exceptions)
149 0           { print $fh " ", $e->toString;
150             }
151             }
152             }
153              
154             1;