package urls;

=head1 NAME

urls - perl module to deal with URL's in accordance with RFC2396.

=head1 SYNOPSIS

    use urlpath qw(&makeurlabs &makeurlrel);

    $absolute = &makeurlabs ('../foo', 'http://www.place/a/b/c')
    $relative = &makeurlrel ('http://www.place/a/b/d', 'http://www.place/a/b/c')

=head1 DESCRIPTION

There are a lot of "Gotcha's" dealing with relative and absolute URL's.
Some browsers even get it wrong.
There is enough confusion, and missimplemention, that they finally issued an
RFC (RFC 2396) that clairifies the procedures.

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(&makeurlabs &makeurlrel);

$VERSION = 1.0;


# in order to deal with relative and absolute URI's, we have to deal with
# absolute and relative paths.
use paths qw(&makepathabs &makepathrel);
use urlparse qw(&parseuri &builduri);

# ==============  Deal with URL's.

sub makeurlabs {
# This is modeled directly on the discription in RFC 2396
my $given         = shift;
my $basescheme    = shift;
my $baseauthority = shift;
my $basepath      = shift;
my $basequery     = shift;
my $basefragment  = shift;

my $result = $given;

# Item 5.2.1 from RFC 2396
  my ($scheme, $authority, $path, $query, $fragment) = &parseuri ( $given );

# Item 5.2.2 from RFC 2396
  if ($path eq '' && !defined $scheme && !defined $authority && !defined $query) {
     $scheme    = $basescheme;
     $authority = $baseauthority;
     $path      = $basepath;
     $query     = $basequery;
     # $result = $given;
  }

  else {
    # RFC2396 5.2.3
      # ["Some implementations MAY..."]
    if (defined $scheme && defined $basescheme
     && $scheme eq $basescheme && $scheme =~ /^(https?|ftp|gopher)$/)
       { $scheme = undef }

    if (!defined $scheme) {
       $scheme = $basescheme;

       # RFC 2396 5.2.4
       if (!defined $authority) {
          $authority = $baseauthority if defined $baseauthority;

          # RFC 2396 5.2.5
          if ($path !~ m;^/;) {

             # RFC 2396 5.2.6
             $path = &makepathabs ($path, $basepath);
          }
       }
    }
  }

  # RFC 2396 5.2.7
  return  &builduri ($scheme, $authority, $path, $query, $fragment);
}

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

sub makeurlrel {
my $given         = shift;
my $basescheme    = shift;
my $baseauthority = shift;
my $basepath      = shift;
my $basequery     = shift;
my $basefragment  = shift;

  # print "DEBUG: Making URL rel, $given\n";
  my ($scheme, $authority, $path, $query, $fragment) = &parseuri ( $given );

  if (defined $scheme && defined $basescheme && $scheme eq $basescheme ) {
    $scheme = undef;
    if (defined $authority && defined $baseauthority && $authority eq $baseauthority) {
       $authority = undef;
       $path = &makepathrel ($path, $basepath);
    }
  }

  if (defined $basequery && defined $query && $basequery eq $query) { $query = undef }

  if (!defined $scheme && !defined $authority && defined $path && $path =~ m:^\.\/?$:
     && (defined $query || defined $fragment)) { $path = '' }

  return &builduri ($scheme, $authority, $path, $query, $fragment);
}

1; # End Package