package paths;

=head1 NAME

paths - perl module to deal with absolute and relative paths in accordance with
       RFC2396.

=head1 SYNOPSIS

    use paths qw(&makepathrel &makepathabs)

    $relative = &makepathrel (&givenpath, &basepath);
       &makepathrel ('/a/b', '/a/b/c/') returns "../"

    $absolute = &makepathabs (&givenpath, &basepath);
       &makepathabs ('../', '/a/b/c/') returns "/a/b";

=head1 DESCRIPTION

There are a lot of "gotcha's" in dealing with relative and absolute paths.
There is enough confusion, and missimplemention, that they finally issued an
RFC that clairifies the procedure.

This code just implements that RFC.

=head1 AUTHOR

John Halleck <John.Halleck@utah.edu>

=head1 COPYRIGHT

(C) Copyright 2000 by John Halleck.

=cut

require 5.0; # Not a prayer with perl 4.

use strict;

use vars qw ($VERSION @ISA @EXPORT_OK);
@ISA = qw (Exporter);
@EXPORT_OK = qw(&makepathabs &makepathrel);

$VERSION = 1.1;

# ------------------

sub makepathabs { # this is a direct coding of RFC 2396 5.2.6
  my $given = shift;
  my $base  = shift;
  if (!defined $base)   { die "No base path given" }
  if (!defined $given)  { die "No relative path given" }
  if ($given =~ m;^/;)  { return $given }

  # RFC 2396 5.2.6a
  my $result = $base;
  if ($result =~ m;^(.*/)[^/]+$;) { $result = $1 }

  # RFC 2396 5.2.6b
  $result .= $given;

  # Just to make search patterns easier.
  my $startingslash = $result =~ m:^/: ;
  if (!$startingslash) { $result = '/' . $result }

  # RFC 2396 5.2.6c  Remove /.'s
  $result =~ s:/\./:/:g;

  # RFC 2396 5.2.6d  Remove trailing /.
  $result =~ s:/\.$:/: ;

  # RFC 2396 5.2.6e  Remove /<SEGMENT>/../'s
  while ($result =~ m;^(.*?)/[^/]*/\.\./(.*)$;) { $result = "$1/$2" }

  # RFC 2396 5.2.6f  Remove trailing /<SEGMENT>/..
  if ($result =~ m;^(.*/)([^/]*)/\.\.$; && $2 ne '..') { $result = $1}

  # RFC 2396 5.2.6g
  if ($result eq '/..') { $result = '' } # Some implementations MAY...
  else {
   while ($result =~ m;^(.*)/\.\.(/.*)$;) { $result = $1 . $2 } # Some implementations MAY...
  }

  # Undo the leading / we put on to simplify pattern matches.
  if (!$startingslash && $result =~ m;^/;) { $result =~ s;^/;; }

  return $result;
}

# -----------------

sub makepathrel {
  my $given = shift;
  my $base  = shift;
  if (!defined $given) { return '' }
  if ($given !~ m;^/(.*)$;) { return $given } # not given an abs.
  $given = $1;
  if (!defined $base)  { return $given } # This is an error, but what to do?
  if ($base  !~ m;^/(.*)$;) { return $given } # really an error.
  $base = $1;

  # Were we handed the same thing?
  if ($base eq $given) {
    if ($given =~ m:/$:) { return './' }
    else                 { return '.'  }
  }

  # We don't really care about non directory part of the base if they are unequal
  if ($base =~ m:^(.*/)[^/]+$:) { $base = $1 }

  # a/b/c/d/  a/b/g/h  => c/d/ g/h
  my ($testbase, $restbase, $testgiven, $restgiven);
  my $didone = 0;
  while (1) {
    # print "DEBUG: Making relative $given, $base\n";
    if ($base  !~ m:^([^/]*)/(.*)$:) { last }
    $testbase = $1; $restbase = $2;
    if ($given !~ m:^([^/]*)/(.*)$:) { last }
    $testgiven = $1; $restgiven = $2;
    if ($testbase eq $testgiven) {
       $base  = $restbase;
       $given = $restgiven;
       $didone = 1;
    } else {
      last
    }
  }

  # What if nothing in common? Then just give it as abs.
  if (!$didone) { return '/' . $given }

  # a/b/c d => ../../d
  while ($base =~ m:^[^/]*/(.*)$:) {
     $base  = $1;
     $given = '../' . $given;
  }

  if ($given eq '' || $given eq '/') { return './' }

  # print "DEBUG: Making relative returning $given\n";
  return $given;
}

1; # End package