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