view release on metacpan or  search on metacpan

RewritingProxy.pm  view on Meta::CPAN

      elsif ($tolkens->[1] =~ /^base$/i && $tolkens->[0] eq 'S')
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{href})
	  {
	  my $newLink = &fixLink($r,$tolkens->[2]{href},$url);
	  $text =~ s#$tolkens->[2]{href}#$newLink#;

          $url = $tolkens->[2]{href};
	  }
	$outString .= $text;
	}
      elsif ($tolkens->[1] =~ /^meta$/i)
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{content} =~ /url/i)
	  {
	  my ($junk,$tmpLink) = split (/=/, $tolkens->[2]{content});
	  my $newLink = &fixLink($r,$tmpLink,$url);
	  $tmpLink = regexEscape($tmpLink);
	  $text =~ s#$tmpLink#$newLink#;
	  }
	$outString .= $text;
	}
      elsif ($tolkens->[1] =~ /^(area|link)$/i && $tolkens->[0] eq 'S')
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{href})
	  {
	  my $newLink = &fixLink($r,$tolkens->[2]{href},$url);
	  $text =~ s#$tolkens->[2]{href}#$newLink#;
	  }
	$outString .= $text;
	}
      elsif ($tolkens->[1] =~ /^(frame|img|input)$/i 
		&& $tolkens->[0] eq 'S')
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{src} && $tolkens->[0] eq 'S')
	  {
	  my $newLink = &fixLink($r,$tolkens->[2]{src},$url);
	  $tolkens->[2]{src} = regexEscape($tolkens->[2]{src});
	  $text =~ s#$tolkens->[2]{src}#$newLink#;
	  }
	$outString .= $text;
	}
      elsif ($tolkens->[1] =~ /^form$/i && $tolkens->[0] eq 'S')
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{action})
	  {
	  my $newLink = &fixLink($r,$tolkens->[2]{action},$url);
          my $action = regexEscape($tolkens->[2]{action});
	  $text =~ s#$action#$newLink#;
	  }
	$outString .= $text;
	}
      elsif ($tolkens->[1] =~ /^(td|body)$/i && $tolkens->[0] eq 'S')
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{background})
	  {
	  my $newLink = &fixLink($r,$tolkens->[2]{background},$url);
	  $text =~ s#$tolkens->[2]{background}#$newLink#;
	  }
	$outString .= $text;
	}
      elsif ($tolkens->[1] =~ /^script$/i 
		&& $tolkens->[0] eq 'S')
  	{
	$text = $tolkens->[4];
        if ($tolkens->[2]{src} && $tolkens->[0] eq 'S')
	  {
	  my $newLink = &fixLink($r,$tolkens->[2]{src},$url);
	  $tolkens->[2]{src} = regexEscape($tolkens->[2]{src});
	  $text =~ s#$tolkens->[2]{src}#$newLink#;
	  }
	$outString .= $text;
	}
      else
	{
	  $outString .= $tolkens->[4];
	}
      }

    $r->content_type($res->content_type);
    print "\n" . $outString;
    return(OK);
    }
  else
    {
    $r->content_type($res->content_type);
    $r->header_out('Content-length'=> length($res->content));
    print "\n" .$res->content;
    return(OK);
    }
  undef $ua;
  return (SERVER_ERROR);
  }

###############################
# sub fixLink
#
# Parameters:

# $r - an Apache request object.
# $url - a reference to another resource.
#     It can be a URL or a relative reference.
#     fixLink will do the right thing with it.
# $baseLink - the link pointing to the current resource.

# Returns:
# a fixed URL using this module again.
#################################
sub fixLink
  {
  my $r = shift;
  my $link = shift;
  my $baseLink = shift;
  my $server_name = $r->get_server_name;
  my $script_name = $r->uri;
  my $i;
  my $urlPath = "";
  my $hostName = "";