1# urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net>
2#
3# extend the uri package to deal with URN (RFC 2141)
4# see http://www.normos.org/ietf/rfc/rfc2141.txt
5#
6# Released under the tcllib license.
7#
8# $Id: urn-scheme.tcl,v 1.11 2005/09/28 04:51:24 andreas_kupries Exp $
9# -------------------------------------------------------------------------
10
11package require uri      1.1.2
12
13namespace eval ::uri {}
14namespace eval ::uri::urn {
15    variable version 1.0.2
16}
17
18# -------------------------------------------------------------------------
19
20# Description:
21#   Called by uri::split with a url to split into its parts.
22#
23proc ::uri::SplitUrn {uri} {
24    #@c Split the given uri into then URN component parts
25    #@a uri: the URI to split without it's scheme part.
26    #@r List of the component parts suitable for 'array set'
27
28    upvar \#0 [namespace current]::urn::URNpart pattern
29    array set parts {nid {} nss {}}
30    if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} {
31        return [array get parts]
32    } else {
33        error "invalid urn syntax: \"$uri\" could not be parsed"
34    }
35}
36
37
38# -------------------------------------------------------------------------
39
40proc ::uri::JoinUrn args {
41    #@c Join the parts of a URN scheme URI
42    #@a list of nid value nss value
43    #@r a valid string representation for your URI
44    variable urn::NIDpart
45
46    array set parts [list nid {} nss {}]
47    array set parts $args
48    if {! [regexp -- ^$NIDpart$ $parts(nid)]} {
49        error "invalid urn: nid is invalid"
50    }
51    set url "urn:$parts(nid):[urn::quote $parts(nss)]"
52    return $url
53}
54
55# -------------------------------------------------------------------------
56
57# Quote the disallowed characters according to the RFC for URN scheme.
58# ref: RFC2141 sec2.2
59proc ::uri::urn::quote {url} {
60    variable trans
61
62    set ndx 0
63    set result ""
64    while {[regexp -indices -- "\[^$trans\]" $url r]} {
65        set ndx [lindex $r 0]
66        scan [string index $url $ndx] %c chr
67        set rep %[format %.2X $chr]
68        if {[string match $rep %00]} {
69            error "invalid character: character $chr is not allowed"
70        }
71
72        incr ndx -1
73        append result [string range $url 0 $ndx] $rep
74        incr ndx 2
75        set url [string range $url $ndx end]
76    }
77    append result $url
78    return $result
79}
80
81# -------------------------------------------------------------------------
82# Perform the reverse of urn::quote.
83
84if { [package vcompare [package provide Tcl] 8.3] < 0 } {
85    # Before Tcl 8.3 we do not have 'regexp -start'. We simulate it by
86    # using 'string range' and adjusting the match results.
87
88    proc ::uri::urn::unquote {url} {
89        set result ""
90        set start 0
91        while {[regexp -indices {%[0-9a-fA-F]{2}} [string range $url $start end] match]} {
92            foreach {first last} $match break
93            incr first $start ; # Make the indices relative to the true string.
94            incr last  $start ; # I.e. undo the effect of the 'string range' on match results.
95            append result [string range $url $start [expr {$first - 1}]]
96            append result [format %c 0x[string range $url [incr first] $last]]
97            set start [incr last]
98        }
99        append result [string range $url $start end]
100        return $result
101    }
102} else {
103    proc ::uri::urn::unquote {url} {
104        set result ""
105        set start 0
106        while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
107            foreach {first last} $match break
108            append result [string range $url $start [expr {$first - 1}]]
109            append result [format %c 0x[string range $url [incr first] $last]]
110            set start [incr last]
111        }
112        append result [string range $url $start end]
113        return $result
114    }
115}
116
117# -------------------------------------------------------------------------
118
119::uri::register {urn URN} {
120	variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}}
121        variable esc {%[0-9a-fA-F]{2}}
122        variable trans {a-zA-Z0-9$_.+!*'(,):=@;-}
123        variable NSSpart "($esc|\[$trans\])+"
124        variable URNpart "($NIDpart):($NSSpart)"
125        variable schemepart $URNpart
126	variable url "urn:$NIDpart:$NSSpart"
127}
128
129# -------------------------------------------------------------------------
130
131package provide uri::urn $::uri::urn::version
132
133# -------------------------------------------------------------------------
134# Local Variables:
135#   indent-tabs-mode: nil
136# End:
137