urn-scheme.tcl

Go to the documentation of this file.

/*  urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net>*/
/* */
/*  extend the uri package to deal with URN (RFC 2141)*/
/*  see http://www.normos.org/ietf/rfc/rfc2141.txt*/
/* */
/*  Released under the tcllib license.*/
/* */
/*  $Id: urn-scheme.tcl,v 1.11 2005/09/28 04:51:24 andreas_kupries Exp $*/
/*  -------------------------------------------------------------------------*/

package require uri      1.1.2

namespace ::uri {}
namespace ::uri::urn {
    variable version 1.0.2
}

/*  -------------------------------------------------------------------------*/

/*  Description:*/
/*    Called by uri::split with a url to split into its parts.*/
/* */
ret  ::uri::SplitUrn (type uri) {
    #@c Split the given uri into then URN component parts
    #@a uri: the URI to split without it's scheme part.
    #@r List of the component parts suitable for 'array set'

    upvar \#0 [namespace current]::urn::URNpart pattern
    array set parts {nid {} nss {}}
    if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} {
        return [array get parts]
    } else {
        error "invalid urn syntax: \"$uri\" could not be parsed"
    }
}


/*  -------------------------------------------------------------------------*/

ret  ::uri::JoinUrn args (
    #@type c , type Join , type the , type parts , type of , type a , type URN , type scheme , type URI
    #@, type a , type list , type of , type nid , type value , type nss , type value
    #@, type r , type a , type valid , type string , type representation , type for , type your , type URI
    , type variable , type urn::, type NIDpart

    , type array , type set , type parts [, type list , type nid , optional  , type nss , optional ]
    , type array , type set , type parts $, type args
    , type if , optional ! =[regexp -- =^$NIDpart$ $parts(nid)] , optional 
        error ="invalid urn: =nid is =invalid"
    
    , type set , type url ", type urn:$, type parts(, type nid):[, type urn::, type quote $, type parts(, type nss)]"
    , type return $, type url
)

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

# Quote the disallowed characters according to the RFC for URN scheme.
# ref: RFC2141 sec2.2
proc ::uri::urn::quote {url} {
    variable trans
    
     ndx =  0
     result =  ""
    while {[regexp -indices -- "\[^$trans\]" $url r]} {
         ndx =  [lindex $r 0]
        scan [string index $url $ndx] %c chr
         rep =  %[format %.2X $chr]
        if {[string match $rep %00]} {
            error "invalid character: character $chr is not allowed"
        }
        
        incr ndx -1
        append result [string range $url 0 $ndx] $rep
        incr ndx 2
         url =  [string range $url $ndx end]
    }
    append result $url
    return $result
}

/*  -------------------------------------------------------------------------*/
/*  Perform the reverse of urn::quote.*/

if { [package vcompare [package provide Tcl] 8.3] < 0 } {
    /*  Before Tcl 8.3 we do not have 'regexp -start'. We simulate it by*/
    /*  using 'string range' and adjusting the match results.*/

    ret  ::uri::urn::unquote (type url) {
        set result ""
        set start 0
        while {[regexp -indices {%[0-9a-fA-F]{2}} [string range $url $start end] match]} {
            foreach {first last} $match break
            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]
        return $result
    }
} else {
    ret  ::uri::urn::unquote (type 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]
        return $result
    }
}

/*  -------------------------------------------------------------------------*/

::uri::register {urn URN} {
    variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}}
        variable esc {%[0-9a-fA-F]{2}}
        variable trans {a-zA-Z0-9$_.+!*'(,):=@;-}
        variable NSSpart "($esc|\[$trans\])+"
        variable URNpart "($NIDpart):($NSSpart)"
        variable schemepart $URNpart
    variable url "urn:$NIDpart:$NSSpart"
}

/*  -------------------------------------------------------------------------*/

package provide uri::urn $::uri::urn::version

/*  -------------------------------------------------------------------------*/
/*  Local Variables:*/
/*    indent-tabs-mode: nil*/
/*  End:*/