DTA-CAB
view release on metacpan or search on metacpan
CAB/Client/HTTP.pm view on Meta::CPAN
## -*- Mode: CPerl -*-
##
## File: DTA::CAB::Client::HTTP.pm
## Author: Bryan Jurish <moocow@cpan.org>
## Description: DTA::CAB generic HTTP server clients
package DTA::CAB::Client::HTTP;
use DTA::CAB;
use DTA::CAB::Datum ':all';
use DTA::CAB::Utils ':all';
use DTA::CAB::Client;
#use DTA::CAB::Client::XmlRpc;
use LWP::UserAgent;
use HTTP::Status;
use HTTP::Request::Common;
use URI::Escape qw(uri_escape_utf8);
#use Encode qw(encode decode encode_utf8 decode_utf8);
use Carp qw(confess);
use strict;
##==============================================================================
## Globals
##==============================================================================
our @ISA = qw(DTA::CAB::Client);
BEGIN {
*isa = \&UNIVERSAL::isa;
*can = \&UNIVERSAL::can;
}
##==============================================================================
## Constructors etc.
##==============================================================================
## $obj = CLASS_OR_OBJ->new(%args)
## + object structure: HASH ref
## {
## ##-- server
## serverURL => $url, ##-- default: localhost:8000
## timeout => $timeout, ##-- timeout in seconds, default: 300 (5 minutes)
## mode => $queryMode, ##-- query mode: qw(get post xpost xmlrpc); default='xpost' (post with get-like parameters)
## post => $postmode, ##-- post mode; one of 'urlencoded' (default), 'multipart'
## rpcns => $prefix, ##-- prefix for XML-RPC analyzer names (default='dta.cab.')
## rpcpath => $path, ##-- path part of URL for XML-RPC (default='/xmlrpc')
##
## format => $formatName, ##-- default query I/O format (default='json')
## #encoding => $encoding, ##-- query encoding (always utf8)
## cacheGet => $bool, ##-- allow cached response from server? (default=1)
## cacheSet => $bool, ##-- allow caching of server response? (default=1)
##
## ##-- debugging
## tracefh => $fh, ##-- dump requests to $fh if defined (default=undef)
## testConnect => $bool, ##-- if true connected() will send a test query (default=true)
##
## ##-- underlying LWP::UserAgent
## ua => $ua, ##-- underlying LWP::UserAgent object
## uargs => \%args, ##-- options to LWP::UserAgent->new()
##
## ##-- optional underlying DTA::CAB::Client::XmlRpc
## rclient => $xmlrpc_client, ##-- underlying DTA::CAB::Client::XmlRpc object
## }
sub new {
my $that = shift;
return $that->SUPER::new(
##-- server
serverURL => 'http://localhost:8000',
#encoding => 'UTF-8',
timeout => 300,
testConnect => 1,
mode => 'xpost',
#post => 'multipart',
post => 'urlencoded',
rpcns => 'dta.cab.',
rpcpath => '/xmlrpc',
CAB/Client/HTTP.pm view on Meta::CPAN
## cacheSet => $bool, ##-- locally override $cli->{cacheSet}
## + server-side %opts: see DTA::CAB::Server::HTTP::Handler::Query
sub analyzeDataRef {
my ($cli,$aname,$dataref,$opts) = @_;
return $cli->rclient->analyzeData($cli->{rpcns}.$aname,$$dataref,$opts) if ($cli->{mode} eq 'xmlrpc');
##-- get headers as ARRAY
my $headers = $opts->{headers};
if (UNIVERSAL::isa($headers,'HTTP::Headers')) {
$headers = [];
$opts->{headers}->scan(sub {push(@$headers,@_)});
} elsif (UNIVERSAL::isa($headers,'HASH')) {
$headers = [ %$headers ];
} elsif (UNIVERSAL::isa($headers,'ARRAY')) {
$headers = [ @$headers ];
} else {
##-- unknown headers
$headers = [];
}
##-- headers: cache control
my $cacheControl = join(', ',
((exists($opts->{cacheGet}) ? $opts->{cacheGet} : $cli->{cacheGet}) ? qw() : 'no-cache'),
((exists($opts->{cacheSet}) ? $opts->{cacheSet} : $cli->{cacheSet}) ? qw() : 'no-store'),
);
push(@$headers, 'Cache-Control'=>$cacheControl) if ($cacheControl);
##-- build form
my %form = (
fmt=>$cli->{format},
#enc=>$cli->{encoding},
($opts ? %$opts : qw()),
a=>$aname,
);
##-- sanity checks (long parameter names clobber short names)
#$form{enc} = $form{encoding} if ($form{encoding});
$form{fmt} = $form{format} if ($form{format});
delete(@form{qw(format encoding qraw headers cacheGet cacheSet)});
delete(@form{grep {!defined($form{$_})} keys %form});
##-- content-type hacks
my $ctype = $opts->{contentType};
$ctype = 'application/octet-stream' if (!$ctype);
delete(@form{qw(q qd contentType)});
##-- compatibility check / raw vs. formatted
my $qname = $opts->{qraw} ? 'q' : 'qd';
my $qmode = $cli->{mode};
if ($qname eq 'q' && $cli->{mode} eq 'xpost') {
$cli->logcarp("analyzeDataRef(): 'xpost' method not supported for raw queries; using 'post' instead");
$qmode = 'post';
}
##-- get response
my ($rsp);
if ($qmode eq 'get') {
$form{$qname} = $$dataref;
$rsp = $cli->uget_form($cli->lwpUrl, \%form, @$headers);
}
else {
##-- encode (for HTTP::Request v5.810 e.g. on services)
foreach (values %form) {
utf8::encode($_) if (utf8::is_utf8($_));
}
##-- encode dataref
utf8::encode($$dataref) if (utf8::is_utf8($$dataref));
if ($qmode eq 'post') {
##-- post most
$form{$qname} = $$dataref;
$rsp = $cli->upost($cli->lwpUrl, \%form,
@$headers,
($cli->{post} && $cli->{post} eq 'multipart' ? ('Content-Type'=>'form-data') : qw()),
);
}
elsif ($qmode eq 'xpost') {
##-- xpost mode
$ctype .= "; charset=\"UTF-8\"" if ($ctype !~ /octet-stream/ && $ctype !~ /\bcharset=/);
$rsp = $cli->uxpost($cli->lwpUrl,
\%form,
$$dataref,
@$headers,
'Content-Type'=>$ctype);
}
}
if (!$rsp) {
##-- should never happen
$rsp = HTTP::Response->new(RC_NOT_IMPLEMENTED, "not implemented: unknown client mode '$qmode'");
}
##-- trace server response
$cli->{tracefh}->print("\n__BEGIN_RESPONSE__\n", ($rsp ? $rsp->as_string : '(undef)'), "__END_RESPONSE__\n") if (defined($cli->{tracefh}));
return $rsp;
}
## undef = $cli->serverError($rsp)
## + handle server error responses
## + default implementation just calls $cli->logconfess()
sub serverError {
my ($cli,$rsp) = @_;
$cli->logconfess("server error: " . $rsp->status_line . "\n" . $rsp->content);
#$cli->logcroak("server error: " . $rsp->status_line . "\n" . $rsp->content . ' ');
#$cli->logdie("server error: " . $rsp->status_line . "\n" . $rsp->content);
#confess (ref($cli) . ": server error: " . $rsp->status_line . "\n" . $rsp->content);
}
## $data_str = $cli->analyzeData($analyzer, \$data_str, \%opts)
## + wrapper for analyzeDataRef()
## + die()s on error
## + you should pass $opts->{'Content-Type'} as some sensible value
sub analyzeData {
my ($cli,$aname,$data,$opts) = @_;
return $cli->rclient->analyzeData($cli->{rpcns}.$aname,$data,$opts) if ($cli->{mode} eq 'xmlrpc');
##
my $rsp = $cli->analyzeDataRef($aname,\$data,$opts);
return $cli->serverError($rsp) if ($rsp->is_error);
return $rsp->content;
}
CAB/Client/HTTP.pm view on Meta::CPAN
=cut
##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Client::HTTP: Methods: Utils
=pod
=head2 Methods: Low-Level Utilities
=over 4
=item lwpUrl
$lwp_url = $cli->lwpUrl();
$lwp_url = $cli->lwpUrl($url);
Returns LWP-style URL C<$lwp_url> for C<$url>, which defaults to C<$cli-E<gt>{serverURL}>.
Supports HTTP over UNIX sockets using various URL conventions:
=over 4
=item *
apache mod_proxy style: C<unix:/path/to/unix/socket|http:///uri/path>
=item *
L<LWP::Protocol::http::SocketUnixAlt|LWP::Protocol::http::SocketUnixAlt> style:
C<http:/path/to/unix/socket//uri/path>
=item *
native "http+unix" scheme: C<http+unix:/path/to/unix/socket//uri/path>.
=back
=item ua
$agent = $cli->ua();
Gets underlying L<LWP::UserAgent|LWP::UserAgent> object, caching if required.
=item rclient
$rclient = $cli->rclient();
For xmlrpc mode, gets underlying DTA::CAB::Client::XmlRpc object, caching if required.
=item urlEncode
$uriStr = $cli->urlEncode(\%form);
$uriStr = $cli->urlEncode(\@form);
$uriStr = $cli->urlEncode( $str);
Encodes query form parameters or a raw string for inclusing in a URL.
=item urequest
$response = $cli->urequest($httpRequest);
Gets response for $httpRequest (a HTTP::Request object) using $cli-E<gt>ua-E<gt>request().
Also traces request to $cli-E<gt>{tracefh} if defined.
=utem urequest_unix
$response = $cli->urequest_unix($httpRequest);
Guts for L<urequest()|/urequest> over UNIX sockets
using L<LWP::Protocol::http::SocketUnixAlt|LWP::Protocol::http::SocketUnixAlt>.
=item uhead
$response = $cli->uhead($url, Header=>Value, ...);
HEAD request.
=item uget
$response = $cli->uget($url, $headers);
GET request.
=item upost
$response = $cli->upost( $url );
$response = $cli->upost( $url, $content, Header =E<gt> Value,... )
$response = $cli->upost( $url, \$content, Header =E<gt> Value,... )
$response = $cli->upost( $url, \%form, Header =E<gt> Value,... )
POST request.
Specify 'Content-Type'=E<gt>'form-data' to get "multipart/form-data" forms.
=item uget_form
$response = $cli->uget_form($url, \%form);
$response = $cli->uget_form($url, \@form, @headers);
GET request for form data.
=item uxpost
$response = $cli->uxpost($url, \%form, $content, @headers);
$response = $cli->uxpost($url, \%form, \$content, @headers);
POST request which encodes \%form in the URL (as for GET) and sends $content
as the request content.
=back
=cut
##========================================================================
## END POD DOCUMENTATION, auto-generated by podextract.perl
##======================================================================
## Footer
##======================================================================
=pod
=head1 AUTHOR
( run in 0.868 second using v1.01-cache-2.11-cpan-98e64b0badf )