#!/usr/bin/perl
###############
# Usage:
#
#    uri_test [ -s ] base-URI
#
# where base-URI is a hierarchical URI in absolute form and the -s option
# indicates that we should behave strictly for same-scheme references.
#
# This is a simple test program that uses a non-validating URI reference
# parser to input a sequence of URI references and, for each one,
#
#    1. parse the reference into its component parts
#    2. resolve the reference relative to the base URI argument
#    3. recombine and print the resolved target URI
#
# continuing until end-of-file is received via stdin.
#
# This software is placed in the Public Domain by Roy T. Fielding
# and Day Software, Inc., for use as a test oracle by anyone that
# is testing or implementing a Uniform Resource Identifier parser.
#
# More info: http://www.apache.org/~fielding/uri/rev-2002/issues.html
#
###############

$strict = 0;     # set to 1 if you want to reject bad references

$base_uri = shift;
if ($base_uri eq '-s') {
    $strict   = 1;
    $base_uri = shift;
}

die "Usage: $0 [-s] base-URI\n" unless defined($base_uri);

($b_scheme, $b_auth, $b_path, $b_query, $b_frag) = &parse_uri($base_uri);

print<<"END";
  Base URI: $base_uri
    scheme: $b_scheme
 authority: $b_auth
      path: $b_path
     query: $b_query
  fragment: $b_frag

END

print "Enter a URI reference (^D exits): ";

while ($ref = <STDIN>) {

    chomp($ref);

    ($r_scheme, $r_auth, $r_path, $r_query, $r_frag) = &parse_uri($ref);

print<<"END";
 Reference: $ref
    scheme: $r_scheme
 authority: $r_auth
      path: $r_path
     query: $r_query
  fragment: $r_frag

END
    print "Target URI: ",
          &abs_uri($b_scheme, $b_auth, $b_path, $b_query, $b_frag,
                   $r_scheme, $r_auth, $r_path, $r_query, $r_frag), "\n";
}
continue {
    print "\nEnter a URI reference (^D exits): ";
}
print "done\n";
exit(0);

# A component parser based on the regular expression in rfc2396bis
#
sub parse_uri
{
    local($_) = @_;

    if ( m|^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?| ) {
        return ($2, $4, $5, $7, $9);
    }
    return ('this', 'should', 'never', 'happen', undef);
}

# Resolve a URI reference relative to a base URI to obtain target URI
#
sub abs_uri
{
    local($b_scheme, $b_auth, $b_path, $b_query, $b_frag,
          $r_scheme, $r_auth, $r_path, $r_query, $r_frag) = @_;

    local($t_scheme, $t_auth, $t_path, $t_query, $t_frag);

    if (!$strict && ($r_scheme eq $b_scheme)) {
        undef($r_scheme);
    }

    if (defined($r_scheme)) {
        $t_scheme = $r_scheme;
        $t_auth   = $r_auth;
        $t_path   = &remove_dot_segments($r_path);
        $t_query  = $r_query;
    }
    else {
        if (defined($r_auth)) {
            $t_auth  = $r_auth;
            $t_path  = &remove_dot_segments($r_path);
            $t_query = $r_query;
        }
        else {
            if ($r_path =~ /^$/) {
                $t_path = $b_path;
                if (defined($r_query)) {
                    $t_query = $r_query;
                }
                else {
                    $t_query = $b_query;
                }
            }
            elsif ($r_path =~ /^\//) {
                $t_path  = &remove_dot_segments($r_path);
                $t_query = $r_query;
            }
            else {
                $t_path  = &path_merge($b_path, $r_path);
                $t_path  = &remove_dot_segments($t_path);
                $t_query = $r_query;
            }
            $t_auth = $b_auth;
        }
        $t_scheme = $b_scheme;
    }
    $t_frag = $r_frag;

    return &recompose($t_scheme, $t_auth, $t_path, $t_query, $t_frag);
}

# Merge a relative-path reference's path with the base URI's path
#
sub path_merge
{
    local($bpath, $rpath) = @_;

    if ($bpath eq "") {          # base path is empty
        return "/$rpath";
    }
    if ($bpath !~ /^\//) {       # base path is non-hierarchical
        return $rpath;
    }

    $bpath =~ s/[^\/]*$//;       # remove last base path segment

    return ($bpath . $rpath);    # and return with ref path appended
}

# Remove "." and ".." segments from a reference's path
#
sub remove_dot_segments
{
    local($buf) = @_;
    local($buzz);

    $buzz = 0;

    # If the buffer begins with "./" or "../", the "." or ".." is removed.

    $buf =~ s/^\.\.?\//\//;

    # All occurrences of "/./" in the buffer are replaced with "/"

    while ($buf =~ s/\/\.\//\//) {}

    # If the buffer ends with "/.", the "." is removed.

    $buf =~ s/\/\.$/\//;

    # All occurrences of "/<segment>/../" in the buffer, where ".."
    # and <segment> are complete path segments, are iteratively replaced
    # with "/" in order from left to right until no matching pattern remains.
    # If the buffer ends with "/<segment>/..", that is also replaced
    # with "/".  Note that <segment> may be empty.

    while ($buf =~ s/\/[^\/]*\/\.\.(\/|$)/\//) {}

    # All prefixes of "<segment>/../" in the buffer, where ".."
    # and <segment> are complete path segments, are iteratively replaced
    # with "/" in order from left to right until no matching pattern remains.
    # If the buffer ends with "<segment>/..", that is also replaced
    # with "/".  Note that <segment> may be empty.

    while ($buf =~ s/[^\/]*\/\.\.(\/|$)/\//) {}

    return $buf;
}

# Given a parsed URI reference, recompose the components into a URI reference
#
sub recompose
{
    local($t_scheme, $t_auth, $t_path, $t_query, $t_frag) = @_;

    local($result) = "";

    if (defined($t_scheme)) {
        $result .= $t_scheme . ':';
    }

    if (defined($t_auth)) {
        $result .= '//' . $t_auth;
    }

    $result .= $t_path;

    if (defined($t_query)) {
        $result .= "?" . $t_query;
    }

    if (defined($t_frag)) {
        $result .= "#" . $t_frag;
    }

    return $result;
}
