view release on metacpan or  search on metacpan

lib/Apache/ReverseProxy.pm  view on Meta::CPAN

  }
  elsif ( defined $exact{$uri_with_qs} ) {	# try exact uri with qs 
    $uri = $exact{$uri_with_qs};
    $changed=1;
  }
  else {

    # otherwise, try regular expression matching
    foreach my $key (keys(%regex)) {
      if ($uri =~ /^$key/) {

	$changed=1;

        # replace URI's first, then append query string
        my $replace_uri = $regex{$key};
        my $replace_query='';
        if ($replace_uri =~ s/\?(.*)$//) { $replace_query = $1 }

        $uri =~ s/$key/${replace_uri}/;
	if (length $replace_query) { $uri .= '?' . $replace_query }
        last;
      }
    } # for each regex match...

  } # regex matching


  if ($changed) {

    # strip out possible query string from re-written uri, store it
    my $munged_uri = $uri;
    my $munged_uri_query = '';
    if ($munged_uri =~ s/\?(.*)$//) { $munged_uri_query = $1 }

    # query string processing
    my $query = $r->args() || '';   # from the user's request
 
    # user has query, but munged url doesn't
    if ( defined $query && length($query) && length($munged_uri_query)==0) {
      $munged_uri_query = $query;
    }
    elsif (defined $query && length($query)) {
          # if the user had a query string, add it in to the munged uri's qs
      my $internal = new CGI($munged_uri_query);
      my $user_query = new CGI($query);
      foreach my $user_key ( $user_query->param() ) {
        # if we can't replace and the variable exists in both places, skip it

#        unless ($internal->param($user_key) && $user_query->param($user_key) 
#                  && defined $no_query_replace{$orig_uri} ) {

          $internal->param($user_key, $user_query->param($user_key) );
#        }
      } # for each variable in the user's query string
      $munged_uri_query = $internal->query_string();  # stringify 
    }

    if (length $munged_uri_query) { $uri = $munged_uri .'?'. $munged_uri_query }


    my $request = new HTTP::Request($r->method, $uri);

    # copy in client headers
    my(%headers) = $r->headers_in();
    for (keys(%headers)) {
      $request->header($_, $headers{$_});
    }
 
    my $host = $uri;
    $host =~ s/([a-zA-z]*:\/\/)([a-zA-Z0-9.-]*)([:0-9]*)\/.*/$2/;
    $request->header('Host', $host);
    my $ua = new LWP::UserAgent('max_redirect' => 0);

    if (defined $chain) {
      $ua->proxy(['http', 'https', 'ftp', 'gopher'], $chain);
      if (defined $noproxy) { $ua->noproxy($noproxy) }
    }
    
    # copy over the client's user-agent, since some servers look at
    # this and customize their response based on it.

    my $origin_ua = $r->header_in('user-agent');
    if (defined $origin_ua && length $origin_ua) {
      $ua->agent($origin_ua)
    }

    # copy over the content type
    my $content_type = $r->header_in('content-type');
    if (defined $content_type && length $content_type) {
      $request->header('content-type', $content_type);
    }

    # copy over the entity body as well
    my $entity_body = $r->content();
    if (defined $entity_body && length $entity_body) {
      $request->content($entity_body);
    } else {
        my $buff = '';
        $r->read($buff, $r->header_in('Content-length'));
        if ($buff ne '') {
            $request->content($buff);
        }
    }

    # Okay now for the fireworks. We use a custom subroutine to send an
    # http header and then display the content in chunks of 4096 bytes.
    # In this way we avoid reading the entire request into core and forcing
    # the web browser to wait for the entire file to be downloaded before
    # receiving any data.
    my $first_time=1;
    my $response = $ua->request($request, sub {
      my($data, $response, $protocol) = @_;
      if ($first_time == 1) {
        $r->content_type($response->header('Content-type'));
        $r->status($response->code());

        $r->status_line($response->code() . ' ' .  $response->message());

        $response->scan(sub { $r->headers_out->add(@_); });
        $r->send_http_header();
        $first_time=0;