File Coverage

blib/lib/eBay/API/XML/BaseCall.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             package eBay::API::XML::BaseCall;
4              
5 4     4   35457 use strict;
  4         8  
  4         134  
6 4     4   19 use warnings;
  4         9  
  4         124  
7              
8             ###############################################################################
9             #
10             # Module: ............... eBay/API/XML
11             # File: ................. BaseCall.pm
12             # Original Author: ...... Milenko Milanovic
13             # Last Modified By: ..... Robert Bradley / Jeff Nokes
14             # Last Modified: ........ 03/06/2007 @ 16:28
15             #
16             # Description: This is a super class for all eBay API calls.
17             #
18             # It contains properties common for all calls.
19             # It assembles request based on properties set.
20             # It submitis the HTTP request to the API server.
21             # It handles call retries (if retries are enabled by a programmer).
22             # It parses received HTTP response.
23             # It handles both HTTP connection errors and API errors.
24             #
25             ###############################################################################
26              
27             =head1 NAME
28              
29             eBay::API::XML::BaseCall
30              
31             =head1 INHERITANCE
32              
33             eBay::API::XML::BaseCall inherits from the L class
34              
35             =cut
36              
37             # Need to sub the Exporter class, to use the EXPORT* arrays below.
38 4     4   17 use Exporter;
  4         7  
  4         173  
39 4     4   1851 use eBay::API::XML::BaseCallGen; # parent class
  0            
  0            
40             our @ISA = ('Exporter'
41             ,'eBay::API::XML::BaseCallGen'); # Parent class
42              
43             use LWP::UserAgent;
44             use HTTP::Request;
45             use HTTP::Headers;
46             #use XML::Simple qw(:strict);
47             # Do not use XML::Simple 'strict' mode because if you use it,
48             # it gets global for the
49             # whole application within apache. Most often we do not use
50             # forcearray and keyattr attributes in XML::Simple
51             # $rhXmlSimple = XMLin ( $sRawXml
52             # , forcearray => []
53             # , keyattr => []
54             # );
55             use XML::Simple;
56             use Data::Dumper;
57             use Time::HiRes qw(sleep);
58             use Compress::Zlib;
59             use XML::Tidy;
60              
61             use eBay::API;
62             use eBay::API::XML::DataType::XMLRequesterCredentialsType;
63             use eBay::API::XML::DataType::ErrorType;
64             use eBay::API::XML::DataType::Enum::SeverityCodeType;
65             use eBay::API::XML::DataType::Enum::ErrorClassificationCodeType;
66              
67             # Variable Declarations
68             # # -----------------------------------------------------------------------
69             # # Constants
70             #
71              
72             use constant _TRUE_ => scalar 1;
73             use constant _FALSE_ => scalar 0;
74              
75             use constant HTTP_ERRORCODE_PREFIX => scalar 'HTTP'; #API001
76             use constant XML_PARSE_ERROR => scalar 'XML_PARSE_ERROR'; #API004
77             use constant NO_RESPONSE_CONTENT => scalar 'NO_RESPONSE_CONTENT'; # API002
78             use constant BAD_API_GATAWAY => scalar 'BAD_API_GATAWAY'; # API003
79             use constant XML_PARSE_RESULT_EMPTY => scalar 'XML_PARSE_RESULT_EMPTY';# API005
80              
81             use constant XML_OLD_TYPE_RESPONSE => scalar 'XML_OLD_TYPE_RESPONSE';
82              
83             =head1 Methods
84              
85             =head2 new()
86              
87             See the parent constructor for detailed docs about object instantiation
88              
89             =cut
90              
91             sub new($;$;) {
92              
93             my $classname = shift;
94             my $arg_hash = shift;
95             my $self = $classname->SUPER::new($arg_hash);
96              
97             # this allow me to introduce a "reset" method
98             # which will allow as to reuse a call instance
99             $self->_init();
100              
101             return $self;
102             }
103              
104             sub _init {
105              
106             my $self = shift;
107              
108             $self->{'pRequest'} = undef;
109             $self->{'pResponse'} = undef;
110              
111             $self->{'pHttpResponse'} = undef;
112             $self->{'isResponseValidXml'} = undef;
113             $self->{'rhXmlSimple'} = undef;
114             # if externalySetRequestXml is defined
115             # then use it to submit the call
116             $self->{'externalySetRequestXml'} = undef;
117             # if 'hasForcedError' is set then do not execute the call
118             # just return the error set with 'forcedError' method
119             $self->{'hasForcedError'} = undef;
120              
121            
122             $self->_initRequest();
123             $self->_initResponse();
124             }
125              
126             =head2 reset()
127              
128             Use 'reset' method in cases when you want to reuse a Call instance
129              
130             =cut
131              
132             sub reset {
133             my $self = shift;
134             $self->_init();
135             }
136              
137              
138             =head2 execute()
139              
140             Executes the current API call
141              
142             =cut
143              
144             sub execute {
145            
146             my $self = shift;
147            
148             #
149             # 1. create HTTP::Request
150             my $objRequest = $self->_getHttpRequestObject();
151              
152             #
153             # 2. create UserAgent
154             my $objUserAgent = LWP::UserAgent->new();
155              
156             # Purposely overwrite the UserAgent property, with one identifying
157             # eBay Perl SDK.
158             $objUserAgent->agent(
159             $objUserAgent->agent . ' / ' .
160             'eBay API Perl SDK (Version: ' . $eBay::API::VERSION . ')'
161             );
162              
163             # timeout in seconds
164             my $timeout = $self->getTimeout();
165             if ( defined $timeout ) {
166             $objUserAgent->timeout($timeout);
167             }
168              
169             $self->_submitHttpRequest( $objUserAgent, $objRequest );
170              
171             }
172              
173             sub _getHttpRequestObject {
174            
175             my $self = shift;
176            
177             # 1. what URL the call will be submitted to
178             my $sApiUrl = $self->getApiUrl();
179             #
180             # 2. create HTTP::Request object and fill it with all parameters
181             my $objHeader = $self->_getRequestHeader();
182              
183             # 3. get XML string that will be sent to the URL
184             my $requestRawXml = $self->getRequestRawXml();
185              
186             # 4. create request that will be submitted to the URL
187             my $objRequest =
188             HTTP::Request->new("POST"
189             , $sApiUrl
190             , $objHeader, $requestRawXml);
191              
192             return $objRequest;
193             }
194              
195             =head2 getHttpRequestAsString()
196              
197             Arguments: 1 [O] - isPrettyPrint - if set then XML is pretty printed
198              
199             Returns: string
200             Method returning a textual representation of the request
201             (request type, url, query string, header and content).
202              
203             =cut
204              
205             sub getHttpRequestAsString {
206             my $self = shift;
207             my $isPrettyPrint = shift || 0;
208              
209             my $pHttpRequest = $self->_getHttpRequestObject();
210              
211             my $str = undef;
212             if ( $isPrettyPrint ) {
213             $str = $self->_prettyPrintFormat( $pHttpRequest );
214             } else {
215             $str = $pHttpRequest->as_string();
216             }
217             return $str;
218             }
219              
220             sub _submitHttpRequest($$$;) {
221              
222             my $self = shift;
223             my $objUserAgent = shift;
224             my $objRequest = shift;
225              
226             ###
227             #
228             # We use this complex LOOP IN ORDER TO BE ABLE TO HANDLE RETRIES
229             #
230             ###
231              
232             my $maxNumberOfTries = 1;
233             my $pCallRetry = $self->getCallRetry();
234             if ( defined $pCallRetry ) {
235             $maxNumberOfTries = $pCallRetry->getMaximumRetries() + 1;
236             }
237              
238             my $currentTry = 0;
239             my $exitLoop = _FALSE_;
240              
241             #
242             # If forced error is set, do not execute the call. See 'forceError' method.
243             # This is used only for test purposes.
244             #
245             if ( $self->hasForcedError() ) {
246             $self->logMessage(eBay::API::BaseApi::LOG_DEBUG
247             ,"Error forced, request has not been sent to the API server\n");
248             return;
249             }
250              
251             while ( ! $exitLoop ) { ## START retry LOOP
252              
253             # 1. send request to the URL ( API server )
254             my $objHttpResponse = $objUserAgent->request($objRequest);
255              
256             # 2. process response
257             $self->processResponse ( $objHttpResponse );
258              
259             # 3. check whether we should retry the call
260             # Exit loop if
261             # a) maxNumberOfTries has been reached
262             # - meaning that all tries failed
263             # b) pCallRetry is not defined
264             # - meaning that call is supposed to be execute only once
265              
266             $currentTry++;
267              
268             if ( ($currentTry >= $maxNumberOfTries)
269             || (! $self->hasErrors() && ! $self->hasWarnings())
270             || (! defined $pCallRetry) ) {
271            
272             $exitLoop = _TRUE_;
273             } else {
274              
275             my $shouldRetry = $pCallRetry->shouldRetry(
276             # ref to an array of ErrorDataType objects
277             # check out both, errors and warnings
278             'raErrors' => $self->getErrorsAndWarnings()
279             );
280              
281             if ( $shouldRetry ) {
282              
283             my $pause = $pCallRetry->getDelayTime();
284             sleep $pause/1000; ## Time::HiRes sleep in miliseconds
285              
286             $exitLoop = _FALSE_;
287              
288             $pCallRetry->incNumberOfRetries();
289             } else {
290             $exitLoop = _TRUE_;
291             }
292             }
293             } ## END retry LOOP
294             }
295              
296             sub _getRequestHeader {
297            
298             my $self = shift;
299             my $sCallName = $self->getApiCallName();
300             if ( ! defined $sCallName ) {
301             print "\nAPI call not set!!!\n";
302             print "'GetApiCallName' method must be implemented in "
303             . ref($self) . ".pm!\n\n";
304             return;
305             }
306            
307             # common call properties
308             my $sSiteId = $self->getSiteID();
309              
310             my $sClLevel = $self->getCompatibilityLevel();
311             my $sDevName = $self->getDevID();
312             my $sAppName = $self->getAppID();
313             my $sCertName = $self->getCertID();
314              
315              
316             #
317             # set header values
318             my $objHeader = HTTP::Headers->new();
319              
320             $objHeader->push_header('X-EBAY-API-COMPATIBILITY-LEVEL' => $sClLevel);
321             $objHeader->push_header('X-EBAY-API-SESSION-CERTIFICATE' =>
322             "$sDevName;$sAppName;$sCertName");
323             $objHeader->push_header('X-EBAY-API-DEV-NAME' => $sDevName);
324             $objHeader->push_header('X-EBAY-API-APP-NAME' => $sAppName);
325             $objHeader->push_header('X-EBAY-API-CERT-NAME' => $sCertName);
326             $objHeader->push_header('X-EBAY-API-CALL-NAME' => $sCallName);
327             $objHeader->push_header('X-EBAY-API-SITEID' => $sSiteId);
328             $objHeader->push_header('Content-Type' => 'text/xml');
329             if ($self->isCompression()) {
330             $objHeader->push_header('Accept-Encoding' => 'gzip');
331             }
332            
333             return $objHeader;
334             }
335              
336             sub _setRequestDataType {
337             my $self = shift;
338             $self->{'pRequest'} = shift;
339             }
340              
341             =head2 getRequestDataType()
342              
343             Returns the RequestDataType object,
344              
345             =cut
346              
347             sub getRequestDataType {
348             my $self = shift;
349             return $self->{'pRequest'};
350             }
351              
352             sub _setResponseDataType {
353             my $self = shift;
354             $self->{'pResponse'} = shift;
355             }
356              
357             =head2 getResponseDataType()
358              
359             Returnst the ResponseDataType object
360             =cut
361              
362             sub getResponseDataType {
363             my $self = shift;
364             return $self->{'pResponse'};
365             }
366              
367             sub _setHttpResponseObject {
368             my $self = shift;
369             $self->{'pHttpResponse'} = shift;
370             }
371              
372             sub _getHttpResponseObject {
373             my $self = shift;
374             return $self->{'pHttpResponse'};
375             }
376              
377             =head2 isHttpRequestSubmitted()
378              
379             Tells to a programmer whether a request has been submitted or not.
380             This method is mainly used in Session in sequential mode.
381              
382             =cut
383              
384             sub isHttpRequestSubmitted {
385             my $self = shift;
386             my $objHttpResponse = $self->_getHttpResponseObject();
387             if ( defined $objHttpResponse ) {
388             return 1;
389             }
390             return 0;
391             }
392              
393             =head2 getHttpResponseAsString()
394              
395             Method returning a textual representation of the response
396              
397             Arguments: 1 [O] - isPrettyPrint - if set then XML is pretty printed
398             Returns: string
399              
400             =cut
401              
402             sub getHttpResponseAsString {
403              
404             my $self = shift;
405             my $isPrettyPrint = shift || 0;
406              
407             my $objHttpResponse = $self->_getHttpResponseObject();
408              
409             my $str = undef;
410             if ( defined $objHttpResponse ) {
411             if ( $isPrettyPrint ) {
412             $str = $self->_prettyPrintFormat( $objHttpResponse );
413             } else {
414             $str = $objHttpResponse->as_string();
415             }
416             } else {
417             $str = "HttpResponseAsString is not available since the API call " .
418             "has not been executed yet!";
419             if ($self->hasForcedError()) {
420             $str .= "\nError forced, request has not been sent to the API server.";
421             }
422             }
423             return $str;
424             }
425              
426             =head2 getResponseRawXml()
427              
428             Method returning the raw XML reponse
429              
430             =cut
431              
432             sub getResponseRawXml {
433             my $self = shift;
434             my $pHttpResponse = $self->_getHttpResponseObject();
435            
436             my $str = '';
437             if ( defined $pHttpResponse ) {
438             $str = $pHttpResponse->content();
439             my $contentEncoding = $pHttpResponse->content_encoding;
440             if ( defined $contentEncoding && $contentEncoding =~ /gzip/i) {
441             $str = Compress::Zlib::memGunzip($str);
442             }
443             }
444             return $str;
445             }
446              
447             sub _setXmlSimpleDataStructure {
448             my $self = shift;
449             $self->{'rhXmlSimple'} = shift;
450             }
451              
452             =head2 getXmlSimpleDataStructure()
453              
454             Returns XML::Simple data structure for a given path.
455             Path is defined as a reference to an array of node names, starting with
456             the top level node and ending with lowest level node.
457              
458             Path IS NOT an XPATH string!!!!
459              
460             Path examples for VerifyAddItem call:
461            
462             @path = ( 'Fees','Fee' ); # Returns fees as an XML::Simple data structure
463             @path = ( 'Errors' ); # Returns Response errors as an XML::Simple
464             # data structure
465             @path = ( 'Errors-xxxx' ); # Will not find anything
466              
467             Notice that root node is not being specified. The reason for that is that
468             we XML::Simple is configured not to put root node into its data structure
469             (that is a default behaviour for XML::Simple).
470              
471             If path is not submitted return the whole XML::Simple data structure
472              
473             =cut
474              
475             sub getXmlSimpleDataStructure {
476             my $self = shift;
477             my $raPath = shift;
478              
479             my $rhXmlSimple = $self->{'rhXmlSimple'};
480             if ( ! defined $raPath ) {
481             return $rhXmlSimple;
482             }
483              
484             my $rhNode = $rhXmlSimple;
485             foreach my $key (@$raPath) {
486             $rhNode = $rhNode->{$key};
487             if ( ! defined $rhNode ) {
488             last;
489             }
490             }
491              
492             return $rhNode;
493             }
494              
495             # _setResponseValidXml()
496             # Sets whether a response is a valid XML document or not.
497              
498             sub _setResponseValidXml {
499             my $self = shift;
500             $self->{'isResponseValidXml'} = shift;
501             }
502              
503             =head2 isResponseValidXml()
504              
505             Access: public
506             Returns: true (1) if a response is a valid XML document or not.
507             false (0) if a response is NOT a valid XML document or not.
508             Note:
509             It allows us to differentiate cases the following cases:
510             a) Response is a valid XML with API errors
511             b) Response is not a valid XML document at all
512             or HTTP connection failed.
513             Most likely it should not be used a lot.
514              
515             =cut
516              
517             sub isResponseValidXml {
518             my $self = shift;
519            
520             my $value = $self->{'isResponseValidXml'};
521             if ( defined $value && $value == 1 ) {
522             return _TRUE_;
523             }
524             return _FALSE_;
525             }
526              
527             sub _addError {
528             my $self = shift;
529             my $pError = shift;
530            
531             my $pResponse = $self->getResponseDataType();
532             my $raErrors = $pResponse->getErrors();
533              
534             if ( ! defined $raErrors ) {
535             $raErrors = [];
536             }
537             push @$raErrors, $pError;
538             $pResponse->setErrors( $raErrors );
539             }
540              
541             =head2 hasErrors()
542              
543             If an API call return errors (API, HTTP connection or XML parsing errors)
544             the application should stop normal processing and return a "system error"
545             message to an application user. The only things that it makes sense to read
546             from ResponseDataType objects are: errors and rawResponse (which in this case
547             might not even be a valid XML document).
548              
549             =cut
550              
551             sub hasErrors {
552             my $self = shift;
553             return $self->_hasErrorsForSeverityCode(
554             eBay::API::XML::DataType::Enum::SeverityCodeType::Error);
555             }
556              
557             =head2 hasWarnings()
558              
559             Return true if the API has errors.
560              
561             =cut
562              
563             sub hasWarnings {
564             my $self = shift;
565             return $self->_hasErrorsForSeverityCode(
566             eBay::API::XML::DataType::Enum::SeverityCodeType::Warning);
567             }
568              
569             =head2 getErrors()
570              
571             Returns: a reference to an array of errors (it can retu
572             This method overrides BaseCallGen::getErrors method, while _getResponseErrors is basically
573             the same method that exists in BaseCallGen
574              
575             =cut
576              
577             sub getErrors {
578             my $self = shift;
579             return $self->_getErrorsForSeverityCode(
580             eBay::API::XML::DataType::Enum::SeverityCodeType::Error);
581             }
582              
583             =head2 getWarnings()
584              
585             Return a reference to an array of warnings
586              
587             =cut
588              
589             sub getWarnings {
590             my $self = shift;
591             return $self->_getErrorsForSeverityCode(
592             eBay::API::XML::DataType::Enum::SeverityCodeType::Warning);
593             }
594              
595             # _hasErrorsForSeverityCode()
596             sub _hasErrorsForSeverityCode {
597              
598             my $self = shift;
599             my $severityCode = shift;
600            
601             my $raErrors = $self->_getResponseErrors();
602            
603             my $hasErrors = 0;
604             if ( defined $raErrors ) {
605             foreach my $pError (@$raErrors) {
606              
607             my @keys = keys ( %$pError );
608             if ( (scalar @keys) == 0 ) {
609             $hasErrors = 1;
610             last;
611             }
612              
613             if ( $pError->getSeverityCode() eq $severityCode ) {
614             $hasErrors = 1;
615             last;
616             }
617             }
618             }
619             return $hasErrors;
620             }
621              
622             # _getErrorsForSeverityCode()
623             sub _getErrorsForSeverityCode {
624              
625             my $self = shift;
626             my $severityCode = shift;
627            
628             my $raErrors = $self->_getResponseErrors();
629            
630             my @aErrors = ();
631             if ( defined $raErrors ) {
632             foreach my $pError (@$raErrors) {
633             if ( $pError->getSeverityCode() eq $severityCode ) {
634             push @aErrors, $pError;
635             }
636             }
637             }
638             return wantarray ? @aErrors : \@aErrors;
639             }
640              
641             =head2 getErrorsAndWarnings()
642              
643             Returns: reference to an array
644              
645             Array contains all errors returned by API call, regardless of SeverityCode
646             Includes both SeverityCodes: 'Error' and 'Warning'
647              
648             =cut
649              
650             sub getErrorsAndWarnings() {
651             my $self = shift;
652             return $self->_getResponseErrors();
653             }
654              
655             =head2 hasError()
656              
657             Arguments: [0] [R] - errorCode
658              
659             Returns: 1 - if an error with the given error code is found
660             0 - if no error with the given error code is returned
661              
662             my $boolean = $self->hasError( '304' );
663            
664             =cut
665              
666             sub hasError {
667            
668             my $self = shift;
669             my $sErrorCode = shift;
670              
671             my $yes = 0;
672             my $raErrors = $self->getErrorsAndWarnings();
673             foreach my $pError ( @$raErrors ) {
674             if ( $sErrorCode eq $pError->getErrorCode() ) {
675             $yes = 1;
676             last;
677             }
678             }
679              
680             return $yes;
681             }
682              
683             ###############################################################################
684             # Response getters(only): output values
685             ###############################################################################
686              
687             # _getResponsErrors()
688             #
689             # type: 'ns:ErrorType'
690             # setter expects: array or reference to an array
691             # getter returns: reference to an array
692             # of 'ns:ErrorType'
693             #
694             sub _getResponseErrors {
695             my $self = shift;
696             return $self->getResponseDataType()->getErrors();
697             }
698              
699              
700             =head2 getEBayOfficialTime()
701              
702             Returns the officaial eBay time.
703              
704             2008-07-03T23:46:36.234Z
705            
706             =cut
707              
708             #
709             # type: 'xs:dateTime'
710             #
711             #
712             sub getEBayOfficialTime {
713             my $self = shift;
714             return $self->getResponseDataType()->getTimestamp();
715             }
716              
717             ###############################################################################
718             # Methods
719             ###############################################################################
720              
721             # _prettyPrintFormat()
722             #
723             # Arguments: 1 [R] pHttpR - either an HTTP::Request or HTTP:Response object
724             # Description: Formats HTTP::Request/HTTP::Response as a string.
725             # Includes: header and content.
726             # XML content is pretty printed.
727              
728             sub _prettyPrintFormat {
729              
730             my $self = shift;
731             my $pHttpR = shift; # either HTTP::Request or HTTP::Response object
732              
733             my $sContent = $pHttpR->content();
734             my $sEverything = $pHttpR->as_string();
735              
736             my $str = '';
737             my $pTidy = XML::Tidy->new('xml' => $sContent);
738             my $tidyStrContent = '';
739             eval {
740             $pTidy->tidy();
741             $tidyStrContent = $pTidy->toString();
742             };
743             my $ndx = index($sEverything, '
744             my $sHeader = '';
745             if ( $ndx >= 0) {
746             $sHeader = substr($sEverything, 0, $ndx);
747             }
748             $str = $sHeader . $tidyStrContent;
749             return $str;
750             }
751              
752             =head2 setRequestRawXml()
753            
754             Method for setting some raw xml content to be used for the request.
755              
756             my $call = new eBay::API::XML::Call::FetchToken(
757             site_id => 0,
758             proxy => __API_URL__,
759             dev_id => __DEVELOPER_ID__,
760             app_id => __APPLICATION_ID__,
761             cert_id => __CERT_ID__,
762             user_auth_token => __AUTH_TOKEN__,
763             );
764            
765             $call->setRequestRawXml('
766            
767            
768             R2n6MQr@LDMAABeDFY8.1025449191.1198127665.563330
769            
770             __USERNAME__
771            
772             '
773             );
774              
775             $call->execute();
776             print $call->getResponseRawXml();
777            
778             =cut
779              
780             sub setRequestRawXml {
781             my $self = shift;
782             $self->{'externalySetRequestXml'} = shift;
783             }
784              
785             =head2 getRequestRawXml()
786              
787             Method returning the raw XML request content
788              
789             =cut
790              
791             sub getRequestRawXml {
792            
793             my $self = shift;
794              
795             #
796             # externaly set Request Xml should be used only for testing purposes
797             #
798             my $sExternalySetRequestXml = $self->{'externalySetRequestXml'};
799             if ( defined $sExternalySetRequestXml ) {
800             return $sExternalySetRequestXml;
801             }
802            
803             # Assemble Request Xml
804             my $pRequest = $self->getRequestDataType();
805              
806             # 1. START set credentials
807             my $pRequesterCredentials =
808             eBay::API::XML::DataType::XMLRequesterCredentialsType->new();
809              
810              
811             # We should always be submitting either token or (username, password) pair, NEVER BOTH
812             # The default (username, password) values should be used for anonymous calls only!
813             my $sAuthToken = $self->getAuthToken();
814             if ( defined $sAuthToken && $sAuthToken ne '' ) {
815             $pRequesterCredentials->setEBayAuthToken($sAuthToken);
816             } else {
817             $pRequesterCredentials->setUsername($self->getUserName());
818             $pRequesterCredentials->setPassword($self->getUserPassword());
819             }
820              
821             $pRequest->setRequesterCredentials($pRequesterCredentials);
822            
823             # 1. END set credentials
824              
825             my $sCallName = $self->getApiCallName() . 'Request';
826             my $strXml = $self->{'pRequest'}->serialize($sCallName);
827              
828             return $strXml;
829             }
830              
831             # _initRequest()
832             sub _initRequest {
833              
834             my $self = shift;
835              
836             my $sRequestDataFullPackage = $self->getRequestDataTypeFullPackage();
837             if ( ! defined $sRequestDataFullPackage ) {
838             # Errors like this one should be cought during the development.
839             print "requestDataTypeFullPackage not set!!!\n";
840             print "'getRequestDataTypeFullPackage' method must be implemented in "
841             . ref($self) . ".pm!\n\n";
842             return;
843             }
844             my $pRequest = $sRequestDataFullPackage->new();
845              
846             $self->_setRequestDataType($pRequest);
847             }
848              
849             # _initResponse()
850             sub _initResponse {
851              
852             my $self = shift;
853              
854             my $sResponseDataFullPackage = $self->getResponseDataTypeFullPackage();
855             if ( ! defined $sResponseDataFullPackage ) {
856             # Errors like this one should be cought during the development.
857             print "responseDataTypeFullPackage not set!!!\n";
858             print "'getResponseDataTypeFullPackage' method must be implemented in "
859             . ref($self) . ".pm!\n\n";
860             return;
861             }
862             my $pResponse = $sResponseDataFullPackage->new();
863              
864             $self->_setResponseDataType($pResponse);
865             }
866              
867             =head2 forceError()
868              
869             This method is used to force a given error when a call is being executed.
870             If the forced error is set, then that error is being returned by the call
871             without executing the call (sending request to the API Server and receiving
872             the response.
873              
874             This method is used for test purposes when a programmer wants to test
875             how the application handles an API error.
876              
877             Arguments: This method uses named argument calling style that looks like this:
878            
879             $self->forceError ( sErrorCode => '1025', sShortMsg => 'Test API error', ... );
880              
881             Required arguments
882             1 - sErrorCode - API error code
883             2 - sShortMsg - short error message
884             3 - sLongMsg - long error message
885             Optional arguments
886             4 - sSeverityCode - severity code
887             default severity code:
888             eBay::API::XML::DataType::Enum::SeverityCodeType::Error
889             5 - sErrorClassificationCode - error classification code
890             default error classification code
891             eBay::API::XML::DataType::Enum::ErrorClassificationCodeType::SystemError
892              
893             Example:
894            
895             $call->forceError (
896             'sErrorCode' => '1025'
897             ,'sShortMsg' => 'Test error short message'
898             ,'sLongMsg' => 'Test error long message'
899             );
900              
901             =cut
902              
903             sub forceError {
904             my $self = shift;
905             my %args = @_;
906              
907             my $sErrorCode = $args{'sErrorCode'};
908             my $sShortMsg = $args{'sShortMsg'};
909             my $sLongMsg = $args{'sLongMsg'};
910             my $sSeverityError =
911             $args{'sSeverityCode'}
912             || eBay::API::XML::DataType::Enum::SeverityCodeType::Error;
913             my $sErrorClassificationCode =
914             $args{'sErrorClassificationCode'}
915             || eBay::API::XML::DataType::Enum::ErrorClassificationCodeType::SystemError;
916              
917             my $pError = eBay::API::XML::DataType::ErrorType->new();
918             $pError->setShortMessage ( $sShortMsg );
919             $pError->setErrorParameters ( [] );
920             $pError->setErrorCode( $sErrorCode );
921             $pError->setSeverityCode( $sSeverityError );
922             $pError->setLongMessage ( $sLongMsg );
923             $pError->setErrorClassification ( $sErrorClassificationCode );
924              
925             $self->_addError( $pError );
926             # signal that we want to force an error.
927             $self->{'hasForcedError'} = 1;
928             }
929              
930             sub hasForcedError {
931             my $self = shift;
932             return $self->{'hasForcedError'};
933             }
934              
935             =head2 processResponse()
936              
937             Method resonsible for process the http response when it arrives.
938              
939             =cut
940              
941             sub processResponse {
942             my $self = shift;
943             my $objHttpResponse = shift;
944              
945             # 1. retrieve response content
946             # if gziped - unzip it
947             my $contentEncoding = $objHttpResponse->content_encoding;
948             my $sRawXml= $objHttpResponse->content();
949             if (defined $contentEncoding && $contentEncoding =~ /gzip/i) {
950             $sRawXml = Compress::Zlib::memGunzip ( $sRawXml );
951             }
952              
953             $self->_setHttpResponseObject( $objHttpResponse );
954              
955             #print $sRawXml;
956              
957             my $pResponse = $self->getResponseDataType();
958              
959             my $isHttpError = $objHttpResponse->is_error;
960              
961             # 3. process response
962            
963             if (! $isHttpError ) { # 3.1. process HTTP response when when we
964             # DO NOT HAVE HTTP connection errors
965              
966             my $ok = 1;
967             $ok = $self->_handleNoResponseContent ( \$sRawXml );
968             if ( ! $ok ) {
969             $self->_setResponseValidXml( _FALSE_);
970             return;
971             }
972              
973             $ok = $self->_handleApiBadGataway ( \$sRawXml );
974             if ( ! $ok ) {
975             $self->_setResponseValidXml( _FALSE_);
976             return;
977             }
978              
979             my $rhXmlSimple;
980              
981             # I.1. parse the raw response
982             eval {
983             $rhXmlSimple = XMLin ( $sRawXml
984             , forcearray => []
985             , keyattr => []
986             );
987             };
988              
989             if ( $@ ) { # I.2. OOPS, parsing failed - response is not
990             # a valid XML document
991             $self->_setResponseValidXml( _FALSE_);
992              
993             #print Dumper($sRawXml);
994             my $longMsg = "error [$@] while parsing response xml [$sRawXml]";
995             my $shortMsg = $!;
996             my $errorCode = XML_PARSE_ERROR;
997              
998             $self->_addHTTP_XMLParse_Error (
999             'shortMsg' => $shortMsg
1000             ,'longMsg' => $longMsg
1001             ,'errorCode' => $errorCode
1002             );
1003             } else { # I.3. raw response is a valid XML document,
1004             # deserialize it to the response
1005              
1006             $self->_setResponseValidXml( _TRUE_);
1007              
1008             $ok = $self->_handleResposeParsedButStructureEmpty (
1009             \$sRawXml, $rhXmlSimple );
1010             if ( ! $ok ) {
1011             return;
1012             }
1013              
1014             $self->_setResponseValidXml( _TRUE_);
1015              
1016             $self->_setXmlSimpleDataStructure( $rhXmlSimple );
1017              
1018             #print Dumper $rhXmlSimple;
1019             $pResponse->deserialize('rhXmlSimple' => $rhXmlSimple );
1020             #print Dumper $pResponse;
1021              
1022             # I.3.1 OLD TYPE XML RESPONSE
1023             # see method description
1024             #
1025              
1026             $self->_handleIfItIsOldStyle();
1027             }
1028             } else { # 3.2. process HTTP response when we HAVE
1029             # HTTP connection errors
1030             # since this was a connectin error, raw response cannot be
1031             # a valid XML document
1032             $self->_setResponseValidXml( _FALSE_);
1033              
1034             #print $objHttpResponse->error_as_HTML;
1035             #print Dumper( $objHttpResponse);
1036              
1037             my $shortMsg = $objHttpResponse->status_line();
1038             my $longMsg = $shortMsg;
1039             my $errorCode = HTTP_ERRORCODE_PREFIX . $objHttpResponse->code();
1040              
1041             $self->_addHTTP_XMLParse_Error (
1042             'shortMsg' => $shortMsg
1043             ,'longMsg' => $longMsg
1044             ,'errorCode' => $errorCode
1045             );
1046             }
1047             }
1048              
1049             # _handleNoResponseContent()
1050             sub _handleNoResponseContent {
1051              
1052             my $self = shift;
1053             my $rsRawXml = shift;
1054              
1055             my $sRawXml = $$rsRawXml;
1056              
1057             my $ok = 1;
1058             if ( ! $sRawXml ) {
1059              
1060             my $longMsg = 'No response content !';
1061             my $shortMsg = $longMsg;
1062             my $errorCode = NO_RESPONSE_CONTENT;
1063             $self->_addHTTP_XMLParse_Error (
1064             'shortMsg' => $shortMsg
1065             ,'longMsg' => $longMsg
1066             ,'errorCode' => $errorCode
1067             );
1068             $ok = 0;
1069             }
1070             return $ok;
1071             }
1072              
1073             # _handleApiBadGataway()
1074             sub _handleApiBadGataway {
1075              
1076             my $self = shift;
1077             my $rsRawXml = shift;
1078              
1079             my $sRawXml = $$rsRawXml;
1080              
1081             # 'Bad Gataway' ERROR
1082             # Check for error HTML response from the gateway.
1083             # If it begins with DOCTYPE or it begins with an html block
1084              
1085             my $isBadApiGateway = 0;
1086             if ( $sRawXml =~ m{^\s*
1087             $isBadApiGateway = 1
1088             }
1089              
1090             my $ok = 1;
1091             if ( $isBadApiGateway ) {
1092              
1093             my $longMsg = "Bad API gateway, [$sRawXml] !";
1094             my $shortMsg = 'Bad API gateway';
1095             my $errorCode = BAD_API_GATAWAY;
1096             $self->_addHTTP_XMLParse_Error (
1097             'shortMsg' => $shortMsg
1098             ,'longMsg' => $longMsg
1099             ,'errorCode' => $errorCode
1100             );
1101             $ok = 0;
1102             }
1103             return $ok;
1104             }
1105              
1106             # _handleResposeParsedButStructureEmpty()
1107             sub _handleResposeParsedButStructureEmpty {
1108              
1109             my $self = shift;
1110             my $rsRawXml = shift;
1111             my $rhXmlSimple = shift;
1112              
1113             my $sRawXml = $$rsRawXml;
1114              
1115             # xml contains no useful data ( everything is comment??
1116             # try that as a test case )
1117              
1118             my $ok = 1;
1119             my $isEmpty = (! $rhXmlSimple)
1120             || (! ref($rhXmlSimple));
1121             if ( ! $isEmpty ) {
1122            
1123             if ( ref($rhXmlSimple) eq 'HASH' ) {
1124             my @keys = keys %$rhXmlSimple;
1125             if ( (scalar @keys) == 0 ) {
1126             $isEmpty = 1;
1127             }
1128             }
1129             }
1130              
1131             if ( $isEmpty ) {
1132              
1133             my $longMsg = "no data from response xml [$sRawXml]";
1134             my $shortMsg = 'no data from response xml';
1135             my $errorCode = XML_PARSE_RESULT_EMPTY;
1136             $self->_addHTTP_XMLParse_Error (
1137             'shortMsg' => $shortMsg
1138             ,'longMsg' => $longMsg
1139             ,'errorCode' => $errorCode
1140             );
1141             $ok = 0;
1142             }
1143            
1144             return $ok;
1145             }
1146              
1147             # _addHTTP_XMLParse_Error()
1148             sub _addHTTP_XMLParse_Error {
1149             my $self = shift;
1150             my %args = @_;
1151              
1152             my $shortMsg = $args{'shortMsg'};
1153             my $longMsg = $args{'longMsg'};
1154             my $errorCode = $args{'errorCode'};
1155              
1156             my $pError = eBay::API::XML::DataType::ErrorType->new();
1157             _populateHTTP_XMLParse_Error(
1158             'pError' => $pError
1159             ,'shortMsg' => $shortMsg
1160             ,'longMsg' => $longMsg
1161             ,'errorCode' => $errorCode
1162             );
1163             $self->_addError( $pError );
1164             }
1165              
1166             # _populateHTTP_XMLParse_Error()
1167             sub _populateHTTP_XMLParse_Error {
1168              
1169             my %args = @_;
1170              
1171             my $pError = $args{'pError'};
1172             my $shortMsg = $args{'shortMsg'};
1173             my $longMsg = $args{'longMsg'};
1174             my $errorCode = $args{'errorCode'};
1175              
1176             $pError->setShortMessage ( $shortMsg );
1177             $pError->setErrorParameters ( [] );
1178             $pError->setErrorCode( $errorCode );
1179             $pError->setSeverityCode(
1180             eBay::API::XML::DataType::Enum::SeverityCodeType::Error
1181             );
1182             $pError->setLongMessage ( $longMsg );
1183             $pError->setErrorClassification (
1184             eBay::API::XML::DataType::Enum::ErrorClassificationCodeType::SystemError
1185             );
1186             }
1187              
1188             # _handleIfItIsOldStyle()
1189             sub _handleIfItIsOldStyle {
1190              
1191             my $self = shift;
1192              
1193             # I.3.1 OLD TYPE XML RESPONSE
1194             # If an empty XML string is submitted, then an old type
1195             # XML response is returned. Such response returns errors
1196             # which are in the old format. Those errors do not make any
1197             # sense anyways so just replace them with a new one which really
1198             # says what has happend.
1199             #
1200             my $ok = 1;
1201             my $raErrors = $self->_getResponseErrors();
1202             if ( defined $raErrors ) {
1203              
1204             foreach my $pError (@$raErrors) {
1205              
1206             my @keys = keys ( %$pError );
1207             # If we have errors but such errors do not have keys
1208             # that means that an old style response is returned.
1209             # Add a new error message
1210             if ( (scalar @keys) == 0 ) {
1211              
1212             my $shortMsg = 'old type XML response';
1213             my $longMsg = <<"OLD_TYPE";
1214              
1215             Old type response, most likely:
1216             a) an empty string sent as a request
1217             b) a very incomplete XML string sent as a request
1218             Please check both, raw request string and raw response!!
1219             OLD_TYPE
1220             my $errorCode = XML_OLD_TYPE_RESPONSE;
1221              
1222             _populateHTTP_XMLParse_Error(
1223             'pError' => $pError
1224             ,'shortMsg' => $shortMsg
1225             ,'longMsg' => $longMsg
1226             ,'errorCode' => $errorCode
1227             );
1228             }
1229              
1230             $ok = 0;
1231             # Just check out the first error message
1232             # If first error message is not an old style error message
1233             # then none is.
1234             last;
1235             }
1236             }
1237              
1238             return $ok;
1239             }
1240              
1241             =head1 ABSTRACT METHODS
1242              
1243             Methods that HAVE TO BE IMPLEMENTED IN each specific API CALL
1244              
1245             =head2 getApiCallName()
1246              
1247             An abstract method - it has to be implemented in a class extending BaseCall class
1248              
1249             =cut
1250              
1251             sub getApiCallName {
1252             return undef;
1253             }
1254              
1255             =head2 getRequestDataTypeFullPackage()
1256              
1257             An abstract method - it has to be implemented in a class extending BaseCall class
1258              
1259             =cut
1260              
1261             sub getRequestDataTypeFullPackage {
1262             return undef;
1263             }
1264              
1265             =head2 getResponseDataTypeFullPackage()
1266              
1267             An abstract method - it has to be implemented in a class extending BaseCall class
1268              
1269             =cut
1270              
1271             sub getResponseDataTypeFullPackage {
1272             return undef;
1273             }
1274              
1275             1;