Tcl Library Source Code

if {![package vsatisfies [package provide Tcl] 8.2]} {
    # FRINK: nocheck
    return
}
package ifneeded uri      1.2.4 [list source [file join $dir uri.tcl]]
package ifneeded uri::urn 1.0.3 [list source [file join $dir urn-scheme.tcl]]

[vset VERSION 1.0.3]
[manpage_begin uri_urn n [vset VERSION]]
[keywords {rfc 2141}]
[keywords uri]
[keywords url]
[keywords urn]
[moddesc   {Tcl Uniform Resource Identifier Management}]
[titledesc {URI utilities, URN scheme}]
[category  Networking]
[require Tcl 8.2]
[require uri::urn [opt [vset VERSION]]]
[description]

This package provides two commands to quote and unquote the disallowed
characters for url using the [term urn] scheme, registers the scheme
with the package [package uri], and provides internal helpers which
will be automatically used by the commands [cmd uri::split] and
[cmd uri::join] of package [package uri] to handle urls using the

# $Id: urn-scheme.tcl,v 1.11 2005/09/28 04:51:24 andreas_kupries Exp $
# -------------------------------------------------------------------------

package require uri      1.1.2

namespace eval ::uri {}
namespace eval ::uri::urn {
    variable version 1.0.3
}

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

# Description:
#   Called by uri::split with a url to split into its parts.
#

proc ::uri::urn::quote {url} {
    variable trans
    
    set ndx 0
    set result ""
    while {[regexp -indices -- "\[^$trans\]" $url r]} {
        set ndx [lindex $r 0]

        set ch [string index $url $ndx]

        if {$ch eq "\0"} {
            error "invalid character: character $chr is not allowed"
        }

        # Decode into UTF-8 bytes.
        set rep {}
        foreach ch [split [encoding convertto utf-8 $ch] {}] {
            scan $ch %c chr
            append rep %[format %.2X $chr]
        }
        
        incr ndx -1
        append result [string range $url 0 $ndx] $rep
        incr ndx 2
        set url [string range $url $ndx end]
    }
    append result $url

            incr first $start ; # Make the indices relative to the true string.
            incr last  $start ; # I.e. undo the effect of the 'string range' on match results.
            append result [string range $url $start [expr {$first - 1}]]
            append result [format %c 0x[string range $url [incr first] $last]]
            set start [incr last]
        }
        append result [string range $url $start end]
        # Recode the array of utf-8 bytes to the proper internal rep.
        return [encoding convertfrom utf-8 $result]
    }
} else {
    proc ::uri::urn::unquote {url} {
        set result ""
        set start 0
        while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
            foreach {first last} $match break
            append result [string range $url $start [expr {$first - 1}]]
            append result [format %c 0x[string range $url [incr first] $last]]
            set start [incr last]
        }
        append result [string range $url $start end]
        # Recode the array of utf-8 bytes to the proper internal rep.
        return [encoding convertfrom utf-8 $result]
    }
}

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

::uri::register {urn URN} {
	variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}}

    if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
        set result ok
    }
    set result
} {ok}

# -------------------------------------------------------------------------
# Quoting checks - various UTF-8 representations for 'coffee' (RFC 2324, section 3)

catch { unset data }

lappend data  "coffee"                   "coffee"
lappend data  "\x4B\x61\x66\x66\x65\x65" "Kaffee"
lappend data  "q\u00e6hv\u00e6"          "q%C3%A6hv%C3%A6"                      ;# aserbaidjani
lappend data  "\u0642\u0647\u0648\u0629" "%D9%82%D9%87%D9%88%D8%A9"             ;# arabic
lappend data  "\u03ba\u03b1\u03c6\u03ad" "%CE%BA%CE%B1%CF%86%CE%AD"             ;# greek

lappend data  "\u0915\u094c\u092b\u0940" "%E0%A4%95%E0%A5%8C%E0%A4%AB%E0%A5%80" ;# hindi

# Ticket [daa83d2edf].
lappend data  "\u4f60\u597d"             "%E4%BD%A0%E5%A5%BD" ;# chinese 'How are you?'

set n 0
foreach {utf8 quoted} $data {
    test urn-4.[incr n] [list quote utf8 string] {
        list [catch {uri::urn::quote $utf8} msg] $msg
    } [list 0 $quoted]
}

set n 0
foreach {utf8 quoted} $data {
    test urn-5.[incr n] [list unquote utf8 string] {
        list [catch {uri::urn::unquote $quoted} msg] $msg
    } [list 0 $utf8]
}

# -------------------------------------------------------------------------
# Clean up the tests

unset data
testsuiteCleanup
return

# Local variables:
#    mode: tcl
#    indent-tabs-mode: nil
# End: