ad_library {
    <p>This is a Tcl implementation of various URI-related operations.</p>
    
    <p>Uniform Resource Identifiers (URIs) are defined by 
    <a href="http://www.ietf.org/rfc/rfc2396.txt">RFC 2396</a> as 
    "a simple and extensible means for identifying a resource" and 
    include both Uniform Resource Locators (URLs) and 
    Uniform Resource Names (URNs). URIs are developed by the 
    World Wide Consortium (W3C), see 
    <a href="http://www.w3.org/Addressing/">their addressing page</a>
    for more information.</p>
    
    <p>It is made available under the terms of the GNU License.
    See <a href="http://www.gnu.org/">the GNU website</a> for more information.</p>

    @author Aaron Swartz <aaron@blogspace.com>
    @creation-date 2001-2-13
}

ad_proc as_parse_uri {uri_in} {
    <p>Takes an URI (including URLs) and returns a listified array of its parts: 
    scheme, authority, path, query and fragment. An entry will be
    missing if it was not included in the URI.</p>
    
    <p>For example, a URI of <code>http://example.org/q#z</code> 
    would return 
    <code>scheme http authority example.org path /q fragment z</code>.
    Notice that query was not included in the the returned list, since there was 
    no query part to the URI.</p>

} {
    regexp -indices {\A(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?} $uri_in {} {} scheme {} authority path {} query {} fragment
    foreach name {scheme authority path query fragment} {
        if {[set $name] != "-1 -1"} {
            set uri($name) [string range $uri_in [lindex [set $name] 0] [lindex [set $name] 1]]
        }
    }

    return [array get uri]
}

ad_proc as_parse_uri_test {} {
    Returns 1 if as_parse_uri works, otherwise throws an error.
} {
    set uri_l [as_parse_uri http://www.ics.uci.edu/pub/ietf/uri/#Related]
    array set uri $uri_l
    
    foreach {name value} {
        scheme "http" 
        authority "www.ics.uci.edu" 
        path "/pub/ietf/uri/" 
        query NULL
        fragment "Related"
    } {
        if {$value != "NULL" && ![string equal $uri($name) $value]} {
            error "$name broken: is \"$uri($name)\"; should be $value"
        } elseif {$value == "NULL" && [info exists uri($name)]} {
            error "$name broken: is \"$uri($name)\"; should be NULL"
        }
    }
    return 1
}

ad_proc as_resolve_relative_uri {base target} {
    <p>Takes a <var>base</var> URI (including URLs) and a <var>target</var> URI 
    and returns the absolute URI.</p>
    
    <p>For example, a base of <code>http://example.org/q/y</code> and a target of 
    <code>../foo</code> would return <code>http://example.org/foo</code>.</p>
} {
    # 1: Parse URI
    set target_l [as_parse_uri $target]
    array set target_uri $target_l
    set base_l [as_parse_uri $base]
    array set base_uri $base_l
    
    # 2: Detect null reference
    if {[string equal $target_uri(path) ""] && ![info exists target_uri(scheme)] && ![info exists target_uri(authority)] && ![info exists target_uri(query)]} {
        if {[info exists target_uri(fragment)]} {
            return $base#$target_uri(fragment)
        }
        return $base
    }
        
    set path $target_uri(path)
    if {[info exists target_uri(query)]} {set query $target_uri(query)}
    if {[info exists target_uri(fragment)]} {set fragment $target_uri(fragment)}
    if {[info exists target_uri(authority)]} {set authority $target_uri(authority)}
        
    # 3: Detect absolute URI
    if {[info exists target_uri(scheme)]} {
        return $target
    } {
        set scheme $base_uri(scheme)
    }
    
    # 4: Detect authority
    if {![info exists target_uri(authority)]} {
        set authority $base_uri(authority)
        
        # 5: check for starting with a slash
        
        if {[string index $target_uri(path) 0] != "/"} {
            # 6: Resolve relative-path reference
            
            # a: Copy all but last segment
            set buffer ""
            if {[info exists base_uri(path)]} {
                set buffer [string range $base_uri(path) 0 [string last / $base_uri(path)]]
            }
            
            # b: Append target's path
            append buffer $target_uri(path)
            
            # c and d: remove . path segments
            set buffer [split $buffer /]
            set i 0
            foreach segment $buffer {
                incr i
                if {$segment != "."} {lappend newbuffer $segment} {
                    if {$i == 1 || $i == [llength $buffer]} {
                        lappend newbuffer ""
                    }
                }
            }
            
            # e and f: deal with .. path segments
            set i 0
            foreach segment $newbuffer {
                if {$segment == ".."} {
                    if {$i <= 0 || $i == [expr [llength $newbuffer] - 1]} {
                        set newbuffer [lreplace $newbuffer [expr $i - 1] $i ""]
                    } {
                        set newbuffer [lreplace $newbuffer [expr $i - 1] $i]
                    }
                    incr i -2 ;# adjust i for the items we just deleted
                }
                incr i
            }
            # g: dealing with extra .. path segements
            # we don't really worry about this -- we just delete them all
            # but we do have to make sure we don't delete the root:
            if {[lindex $newbuffer 0] != ""} {
                set newbuffer [lreplace $newbuffer 0 0 "" [lindex $newbuffer 0]]
            }
            
            # h: set the path 
            set path [join $newbuffer /]
        }
    }

    # 7: recreate URI
    
    set result ""
    if {[info exists scheme]} {
        append result "$scheme:"
    }
    if {[info exists authority]} {
        append result "//$authority"
    }
    append result $path
    if {[info exists query]} {
        append result "?$query"
    }
    if {[info exists fragment]} {
        append result #$fragment
    }

    return $result
}

ad_proc as_resolve_relative_uri_test {} {
    Tests as_resolve_relative_uri. Returns a 1 if it works, throws an error if it doesn't.
} {
    foreach {target result} {
        g:h     g:h
        g       http://a/b/c/g
        ./g     http://a/b/c/g
        g/      http://a/b/c/g/
        /g      http://a/g
        //g     http://g
        ?y      http://a/b/c/?y
        g?y     http://a/b/c/g?y
        #s      http://a/b/c/d;p?q#s
        g#s     http://a/b/c/g#s
        g?y#s   http://a/b/c/g?y#s
        ;x      http://a/b/c/;x
        g;x     http://a/b/c/g;x
        g;x?y#s http://a/b/c/g;x?y#s
        .       http://a/b/c/
        ./      http://a/b/c/
        ..      http://a/b/
        ../     http://a/b/
        ../g    http://a/b/g
        ../..   http://a/
        ../../  http://a/
        ../../g http://a/g
        
        ""              http://a/b/c/d;p?q

        ../../../g      http://a/g
        ../../../../g   http://a/g

        /./g            http://a/./g
        /../g           http://a/../g
        g.              http://a/b/c/g.
        .g              http://a/b/c/.g
        g..             http://a/b/c/g..
        ..g             http://a/b/c/..g
        
        ./../g          http://a/b/g
        ./g/.           http://a/b/c/g/
        g/./h           http://a/b/c/g/h
        g/../h          http://a/b/c/h
        g;x=1/./y       http://a/b/c/g;x=1/y
        g;x=1/../y      http://a/b/c/y
        
        g?y/./x         http://a/b/c/g?y/./x
        g?y/../x        http://a/b/c/g?y/../x
        g#s/./x         http://a/b/c/g#s/./x
        g#s/../x        http://a/b/c/g#s/../x
    } {
        set my_result [as_resolve_relative_uri {http://a/b/c/d;p?q} $target]
        if {$my_result != $result} {
            error "with target \"$target\" expected \"$result\" but got \"$my_result\""
        }
    }
    return 1
}