view release on metacpan or  search on metacpan

ProxyRewrite.pm  view on Meta::CPAN

    } elsif ($k =~ /User-Agent/) {
      $client_agent = $v;
    }
    $v = uri_unescape($v);
    $request->header($k,$v);	
    $r->log->debug("fetch: IN-MOD $k: $v");
  }

  # If we have authorization information and it isn't already filled in
  if ($auth_info && !$request->authorization()) {
    $request->authorization($auth_info);
  }

  if ($r->method eq "POST") {
    my $content;
    if ($r->headers_in->{'Content-type'} eq 'application/x-www-form-urlencoded') {
      $content = $r->content;
    } else {
      $r->read($content, $r->headers_in->{'Content-length'});
    }
    $request->content($content);
    $r->log->debug("fetch: Request type: ", $r->method);
    $r->log->debug("fetch: Request content type: ",
		   $r->headers_in->{'Content-type'});
    $r->log->debug("fetch: Request content: $content");
  }

  $r->log->debug("fetch: Product: $Apache::ProxyRewrite::PRODUCT");
  my $ua = new LWP::UserAgent;
  if ($client_agent ne '') {
    $ua->agent("$client_agent; $Apache::ProxyRewrite::PRODUCT");
  } else {
    $ua->agent("$Apache::ProxyRewrite::PRODUCT");
  }
  my $res = $ua->simple_request($request);
  $r->log->info("ProxyRewrite::fetch: Time proxy got document: ", time);
  $r->log->info("ProxyRewrite::fetch: Original document size: ",
		length($res->content));

  return($res);
}

###############################################################################
###############################################################################
# parse: parse HTML and find all embedded URLs
###############################################################################
###############################################################################
sub parse {
  my ($r, $remote_site, $response, $mapref) = @_;
  my $buf = $response->content;
  my ($lessthanpos, $greaterthanpos, $prediff, $diff,
      $preblock, $tagblock, $lastblock);
  my $pos = 0;
  my $newbuf = '';
  my $iscomment = 0;
  my $buflen = length($buf);

  while (($lessthanpos = index($buf, "<", $pos)) > -1) {
    # Make a special case out of the comment in case there
    # are nested tags within the comment, such as javascript code
    # fragments. Not necessarily our problem, but it doesn't hurt much
    # to deal with it.
    if (substr($buf, $lessthanpos + 1, 3) eq '!--') {
      $greaterthanpos = index($buf, "-->", $lessthanpos);
      $iscomment = 1;
    } else {
      $greaterthanpos = index($buf, ">", $lessthanpos);
    }
    $prediff = $lessthanpos - $pos;
    $diff = $greaterthanpos - $lessthanpos - 1;
    $preblock = substr($buf, $pos, $prediff + 1);
    $tagblock = substr($buf, $lessthanpos + 1, $diff);
    if ($iscomment == 0) {
      $r->log->debug("parse: Dealing with tag block: $tagblock");
      &dealwithtag($r, $remote_site, \$tagblock, $mapref);
      $r->log->debug("parse: Edited tag block: $tagblock");
    } else {
      $r->log->debug("parse: Skipped comment tag block");
      $iscomment = 0;
    }
    $newbuf .= "$preblock$tagblock";
    $pos = $greaterthanpos;
    # If a tag isn't properly closed at the end of a document, we need to
    # force an end to the loop.
    last if ($pos == -1);
  }
  $lastblock = substr($buf, $pos, $buflen);
  $newbuf .= "$lastblock";

  $response->content($newbuf);
}

###############################################################################
###############################################################################
# dealwithtag: decides if there a URL in a tag and sends it to be rewritten
###############################################################################
###############################################################################
sub dealwithtag {
  my ($r, $remote_site, $tagblock, $mapref) = @_;
  my @blocks;
  my ($tag, $lctag, $key, $lckey, $value, $lcvalue, $delay, $tmp, $i);
  my $done = 0;
  my $refresh = 0;

  # Remove spaces around equal signs, eg 'src = bar' becomes 'src=bar'
  $$tagblock =~ s/\s*(=)\s*/$1/g;
  # Remove all other forms of whitespace in block
  $$tagblock =~ s/(\f|\n|\r|\t)+/ /g;
  # Remove leading spaces in block, eg < img ...> becomes <img ...>
  $$tagblock =~ s/^\s+//;
  # Remove leading and trailing whitespace within quotes
  $$tagblock =~ s/(=[\"\'])\s*/$1/g;
  $$tagblock =~ s/\s*([\"\'])/$1/g;
  @blocks = split(/\s+/, $$tagblock);
  $tag = shift(@blocks);
  $lctag = lc($tag);
  if (exists($LINK_ELEMENTS{$lctag})) {
    $$tagblock = $tag;
    for ($i = 0; $i < @blocks; $i++) {
      if ($blocks[$i] =~ /=/) {
        ($key, $value) = split(/=/, $blocks[$i], 2);