view release on metacpan or  search on metacpan

Gateway.pm  view on Meta::CPAN

sub server_name_from_URL($$) {
    my ($r, $url) = @_;
    $url = Apache::URI->parse($r, $url) unless ref $url;
    return canonicalized_server_URL($url->scheme, $url->hostname, $url->port);
}

=item server_name($r)

Return the (somewhat canonicalized) "server name" portion of the
URL of this server.  The "server name" is defined as the leading
scheme://authority portion of the URL.  Currently assumes server
access is via HTTP.

=cut

sub server_name($) {
    my $r = shift;
    return canonicalized_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 daylight
savings time.  Specifically, as used in this module, this function
will return the wrong results when applied to files retrieved by the
mirror during the two hours of the year when one server is in Daylight
Savings Time and the other is not.

=cut

sub diff_TZ($$) {
    my($mirror_TZ, $origin_TZ) = @_;

    return 0 if $origin_TZ eq $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;

    return Time::Zone::tz_offset(Time::Zone::tz2zone($mirror_TZ),
				 $reference_time)
      - Time::Zone::tz_offset(Time::Zone::tz2zone($origin_TZ),
			      $reference_time);
}

=item $gw->update_via_header_field($response)

Update Via header in HTTP::Response with information about this hop.
Hop information combines protocol information from the message with
server information from the B<Apache> server.  The server name
returned is hardcoded as 'C<apache>'.

Eventually, options should be provided to control hostname suppression
and comment customization.

=cut

sub 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');
    }

    # HTTP protocol-name can be dropped.  Remember if the server is
    # being accessed via HTTP.
    my $server_accessed_via_HTTP = ($hop =~ s{^HTTP/}{});

    # Set server name.
    $hop .= ' apache';		# For now, use a pseudonym.
    $hop .= ':' . $r->server->port
      unless $server_accessed_via_HTTP && $r->server->port == 80;

    # Set comment.  Comment text may not contain embedded parentheses.
    my $comment = SERVER_VERSION;
    $comment =~ tr/()/[]/;	# Replace parentheses with brackets.
    $hop .= ' (' . $comment . ')'; # Append comment.

    # Update header.
    my $via = $response->header('Via');
    $response->header(Via => defined $via ? $via . ', ' . $hop : $hop);
}

=item copy_header_to_Apache_request($r, $headers)

Copy the headers from an C<HTTP::Headers> object to an
C<Apache::Request>.  Hope that the B<Apache> request object will later
print out the headers in "Good Practice" order (there appears to be no
way of controlling this).

The only tricky item is the Content-Type header, which needs special
handling.

=cut

sub 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(@_);});