#! /usr/bin/perl
#
# linkrel.pl
#
# Converts full URL links to relative links, and sends to stdout.
#
# by Kenneth J. Lanfear, lanfear@usgs.gov
# Version 1.1, 18DEC96
# updated by David Boldt   31 Oct 2003 not to modify ftp links
#
# Input:
#       $url      = Full URL of the file.
#       $filein   = input file name. If none specified, input
#                      sill be from stdin
#
# Output:
#       The file, with URL's replaced by relative URL's where
#       possible, is sent to standard output.
#
#=====================================================================

#Check the arguments
$url = $ARGV[0]; $filein = $ARGV[1]; 
unless ($url) {&usage}
unless ($filein) {$filein = '-'} #Standard input

#Read the input file into memory as a long string.
open (INFILE,"$filein") || die "Could not open input file $filein\n";
while (<INFILE>) {$text .= $_}
#Split the big string at the start of each html tag
@line = split('<',$text);

#Find each link "<a href=" and check it.
for ($i=0; $i<=$#line; $i++) {
  if ($i > 0) {$line[$i] = "<" . $line[$i]}
  next unless ($line[$i] =~ /<[ \s]*a[ \s]+href[ \s=]|<[ \s]*img[ \s]|<[ \s]*form[ \s]/i);
  if ($line[$i] =~ /([ \s]src[ \s]*=[ \s"]*)([^\s][^"> \s]*)/i) {
    $link = $2; $before = $1;
  }
  elsif ($line[$i] =~ /([ \s]href[ \s]*=[ \s"]*)(http:\/\/[^\s][^"> \s]*)/i) {
    $link = $2; $before = $1;
  }
  elsif ($line[$i] =~ /([ \s]action[ \s]*=[ \s"]*)([^\s][^"> \s]*)/i) {
    $link = $2; $before = $1;
  }
  else {next}
  $relative_url = &relurl($url,$link);
  if ($relative_url ne $link) {
    $line[$i] =~ s/$before$link/$before$relative_url/;
  }
}

#All links changed.
$text = join("",@line);
print $text;
exit;

sub usage {
  print "Usage: linkrel.pl <filein> <url>\n";
  print "  where\n";
  print "    <filein>     Input file name.\n";
  print "    <url>        Full URL of the input file.\n";
  exit; #Kills the program
}

sub relurl {
  #Returns the url of $url2 relative to $url1
  local ($url1,$url2) = @_;
  local ($dir);
  local ($protocol1,$server1,$dir1,$file1);
  local ($protocol2,$server2,$dir2,$file2);
  &breakurl($url2,$protocol2,$server2,$dir2,$file2);
  unless ($server2) {return $url2} #Already a relative link.
  &breakurl($url1,$protocol1,$server1,$dir1,$file1);
  if ($server2 !~ /^$server1$/i || $path2 !~ /^$path1$/i) {return $url2}
  #Link is on the same server.
  unless ($dir2) {$dir2 = "//"} #At ServerRoot
  unless ($dir2 =~ /^\.{1,2}\//) {$dir2 = &relpath($dir1,$dir2)} #Relative path
  return "$dir2$file2";
}

sub breakurl {
  #Breaks a full or a relative URL into protocol, server, directory, file
  local ($url) = $_[0];
  local ($protocol,$server,$dir,$file);
  if ($url =~ s/^(.*):\/\///) {
    $protocol = $1;
    if ($url =~ s/^([^\/]+)//) {$server = $1}
  }
  if ($url =~ s/([^\/]+)$//) {$file = $1}
  $url =~ s/^\///;
  $_[1]=$protocol; $_[2]=$server; $_[3]=$url; $_[4]=$file;
}

sub relpath {
  #Returns the pathname of $path2 relative to $path1.
  local ($path1,$path2) = @_;
  local ($i);
  local (@dir1,@dir2);
  local ($relpath);
  @dir1 = split(/\//,$path1); @dir2 = split(/\//,$path2);
  unless ($path2) {return ""}
  local($mi) = 0;
  for ($i=0;$i<=$#dir2;$i++) {
    if ($dir1[$i] ne $dir2[$i]) {$mi = $i; last}
    if ($i > $#dir1 || $i == $#dir2) {$mi = $i + 1; last}
  }
  for ($i=$mi;$i<=$#dir1;$i++) {$relpath .= "../"}
  for ($i=$mi;$i<=$#dir2;$i++) {$relpath .= "$dir2[$i]/"}
  $relpath;
}