Apache-Gateway
view release on metacpan or search on metacpan
=item $gw = Apache::Gateway->new( [$ua] )Construct a new Apache::Gateway object describing a gateway. If aLWP::UserAgent is not provided, a new one will be created. Note: theuser agent is modified for seach request; it is not constant and isprobably not shareable.=cutsubnew($;$) {my$proto=shift;my$class=ref($proto) ||$proto;my$self= {};$self->{UA} =@_?shift: new LWP::UserAgent,$self->{CONFIG} = {};bless($self,$class);return$self;}=item $gw->user_agent( [$ua] )Get/set the user agent.=cutsubuser_agent($;$) {my$self=shift;if(@_) {$self->{UA} =shift}return$self->{UA};}=item $gw->request( [$r] )Get/set the Apache request currently being gatewayed. To send therequest, see the send_request method.=cutsubrequest($;$) {my$self=shift;if(@_) {$self->{REQUEST} =shift}return$self->{REQUEST};}# $gw->_config( [$config] )# Get/set the cached configuration information and current run state.# This very low-level method is for hackers only. This API might# change.sub_config($;$) {my$self=shift;if(@_) {$self->{CONFIG} =shift}return$self->{CONFIG};}=item $gw->location_config( [$config] )Get/set the configuration information for this gateway location. Canbe overridden to provide dynamic per location information=cutsublocation_config($;$) {my$self=shift;my$config_file=$self->{REQUEST}->dir_config('GatewayConfig');if(@_) {$self->{CONFIG}{$config_file} =shift}return$self->{CONFIG}{$config_file};}# $gw->_init_config_file## If necessary, parse and cache a configuration file specified by the# GatewayConfig variable. On error, sets
# ... }# ROOT => location of root of gateway,# TIMEOUT => timeout in seconds for contacting upstream server# }# site = a site URL, e.g., http://www.perl.com/CPAN/# mux sites list = { START_INDEX => start index of round robin,# SITE => [ site, site, ... ] }# This structure is subject to change. Because it contains state# information, it is per object and cannot be shared.sub_init_config_file($) {my$self=shift;my$r=$self->{REQUEST};my$config=$self->{CONFIG};my$config_file=$r->dir_config('GatewayConfig');unless($config_file) {$r->log_error('no GatewayConfig');$r->status(HTTP::Status::RC_INTERNAL_SERVER_ERROR);return;}
return1;}=item clear_headers_for_redirect($r)Clear request headers in $r in preparation for a redirect.=cutsubclear_headers_for_redirect($) {my$r=shift;# Some of this should be done with Apache::Tie when it is working.$r->header_out('Content-Length'=>undef);# should use tie$r->status(HTTP::Status::RC_OK);my%err=$r->err_headers_out;# should use tieforeach(keys%err) {$r->err_header_out($_=>undef);}}=item canonicalized_server_URL($scheme, $hostname, $port)Return semicanonicalized server URL (without trailing slash).=cutsubcanonicalized_server_URL($$$) {my($scheme,$host,$port) =@_;my$server=lc($scheme.'://'.$host);if(defined$portandexists$default_port{$scheme}and$port!=$default_port{$scheme}) {$server.=':'.$port;}return$server;}=item server_name_from_URL($r, $url)Return the (somewhat canonicalized) "server name" portion of the URL.The "server name" is defined as the leading scheme://authority portionof the URL.=cutsubserver_name_from_URL($$) {my($r,$url) =@_;$url= Apache::URI->parse($r,$url)unlessref$url;returncanonicalized_server_URL($url->scheme,$url->hostname,$url->port);}=item server_name($r)Return the (somewhat canonicalized) "server name" portion of theURL of this server. The "server name" is defined as the leadingscheme://authority portion of the URL. Currently assumes serveraccess is via HTTP.=cutsubserver_name($) {my$r=shift;returncanonicalized_server_URL('http',$r->server->server_hostname,$r->server->port);}=item diff_TZ($origin_TZ, $mirror_TZ)Get the usual time difference (in seconds) between the two time zones.Will yield the wrong results in the midst of a change to/from daylightsavings time. Specifically, as used in this module, this functionwill return the wrong results when applied to files retrieved by themirror during the two hours of the year when one server is in DaylightSavings Time and the other is not.=cutsubdiff_TZ($$) {my($mirror_TZ,$origin_TZ) =@_;return0if$origin_TZeq$mirror_TZ;# no need to do anything# Use Thu Jan 01 00:00:00 GMT 1998 as a reference time. No# changes to/from Daylight Savings Time occurred near this time.my$reference_time= 883612800;returnTime::Zone::tz_offset(Time::Zone::tz2zone($mirror_TZ),$reference_time)
Update Via header in HTTP::Responsewithinformation about this hop.Hop information combines protocol information from the messagewithserver information from the B<Apache> server. The server namereturned is hardcoded as'C<apache>'.Eventually, options should be provided to control hostname suppressionand comment customization.=cutsub update_via_header_field($$) {my($self, $response) = @_;my $r = $self->{REQUEST};# Set protocol.my $hop = $response->protocol;# Oops. No protocol. Try to guess from request.unless(defined $hop) {$hop = (uc(Apache::URI->parse($r, $response->request->url)->scheme). '/unknown');
Copy the headers from an C<HTTP::Headers> object to anC<Apache::Request>. Hope that the B<Apache> request object will laterout the headers in"Good Practice"order (there appears to benoway of controlling this).The only tricky item is the Content-Type header, which needs specialhandling.=cutsub copy_header_to_Apache_request($$) {my($r, $header) = @_;# Apache might already know the proper content type, e.g., by use# of a ForceType directive. If so, try not to override it. Else,# the type needs to be set explicitly with the Apache request's# content_type method: simply setting the header value isn't# enough.if(defined $r->content_type) {$header->content_type(undef);}else {$r->content_type($header->content_type);}# Copy headers to Apache request (in "Good Practice" order).$header->scan(sub {$r->header_out(@_);});}sub print_headers($$$) {my ($self, $response, $allow_abort) = @_;my $r = $self->{REQUEST};my $site = $self->{SITE};my $path = $self->{GW_PATH};# Copy status code and reason phrase from response to Apache# request.$r->status($1) if $response->status_line =~ /^(\d+)/;$r->status_line($response->status_line);
}=item redirect($allow_abort);Try a redirect. We do this via C<LWP::UserAgent> becauseC<internal_redirect_handler> does not provide hooks for detecting andrecovering from errors.=cutsubredirect($$) {my($self,$allow_abort) =@_;my$r=$self->{REQUEST};my$ua=$self->{UA};my$site=$self->{SITE};my$path=$self->{GW_PATH};my$url= Apache::URI->parse($r,$site.$path);# If this is an anon-FTP request, fill in the password with the
unless$headers_printed||$r->connection->aborted;}=item $gw->site( [$site] )Get/set the site tried. Can be used to determine which upstreamserver actually fields a request.=cutsubsite($;$) {my$self=shift;if(@_) {$self->{SITE} =shift}return$self->{SITE};}=item $gw->try_URI($allow_abort)Try the site $gw->site. Ideally, we could useC<Apache::internal_redirect_handler> to try the redirects. However,it provides no hook for detecting an error and aborting output.That's not B<mod_perl>'s fault--B<Apache> source would need to bemodified to support such a hook.=cutsubtry_URI($$) {my($self,$allow_abort) =@_;clear_headers_for_redirect($self->{REQUEST});$self->redirect($allow_abort);}=item try_sites($allow_last_site_abort, @site)Try sites in order until one succeeds. $allow_last_site_abortindicates if the last site can/should be aborted after examing thehead for its error code. All other sites always allow prematureabortion.Abortion is needed because only one request can be allowed to run tocompletion and produce a message body.=cutsubtry_sites($$@) {my($self,$allow_last_site_abort,@site) =@_;my$r=$self->{REQUEST};# Try all but last site, aborting each attempt on error.for(my$i= 0;$i<=$#site; ++$i) {if(ref$site[$i]) {# Try this group of sites, starting at index $idx.my$mux_site=$site[$i];my$idx=$mux_site->{START_INDEX};
}# We can exit if the last attempt succeeded or if the client# is no longer talking to us.returnif(!HTTP::Status::is_error($r->status)||$r->connection->aborted);}}# Set up the user agent for this particular request.sub_init_ua($) {my$self=shift;my$r=$self->{REQUEST};my$ua=$self->{UA};$ua->from($r->server->server_admin);$ua->agent($r->header_in('User-Agent'));$ua->timeout($self->location_config->{TIMEOUT});return1;# succeeded}# Set $self->{GW_PATH} to the portion of the path relative to# GatewayRoot. This is also the path which is appended to the URIs of# the upstream servers.sub_init_path($) {my$self=shift;my$r=$self->{REQUEST};# epath = $gw_root . $gw_pathmy$gw_root=$self->location_config->{ROOT};my($gw_path) =$r->parsed_uri->path =~ /^\Q$gw_root\E(.*)/;unless(defined$gw_path) {# error$r->log_error($r->uri .' does not begin with '.$gw_root);$r->status(HTTP::Status::RC_INTERNAL_SERVER_ERROR);return;}$self->{GW_PATH} =$gw_path;# succeededreturn1;}sub_init_request($) {my$self=shift;$self->_init_config_file orreturn;$self->_init_ua orreturn;$self->_init_path orreturn;return1;# succeeded}=item $gw->site_listGet the list of sites to try for this request. Can be overridden tocustomize the list of sites to try.By default, this method looks through the LocationMatch sections inthe GatewayConfig file in order and returns the sites in the firstsection matched.=cutsubsite_list($) {my$self=shift;my$location_conf=$self->location_config;my$gw_path=$self->{GW_PATH};foreachmy$entry(@{$location_conf->{LOCATION}}) {if($gw_path=~ /$entry->{PATTERN}/) {return@{$entry->{SITE}};}}return;}=item $gw->send_request( [$r] )Send the Apache request to the upstream server. Optionally sets itfirst.=cutsubsend_request($;$) {my$self=shift;if(@_) {$self->{REQUEST} =shift}$self->_init_request orreturn;$self->try_sites(0,$self->site_list);return1;# succeeded}subhandler {if(!defined$gw) {$gw= new Apache::Gateway;
( run in 0.332 second using v1.01-cache-2.11-cpan-55f5a4728d2 )