home *** CD-ROM | disk | FTP | other *** search
/ PCNET 2006 September - Disc 1 / PCNET_CD_2006_09.iso / linux / puppy-barebones-2.01r2.iso / pup_201.sfs / usr / lib / uri / uri.tcl < prev    next >
Encoding:
Text File  |  2004-02-15  |  24.6 KB  |  933 lines
  1. # uri.tcl --
  2. #
  3. #    URI parsing and fetch
  4. #
  5. # Copyright (c) 2000 Zveno Pty Ltd
  6. # Steve Ball, http://www.zveno.com/
  7. # Derived from urls.tcl by Andreas Kupries
  8. #
  9. # TODO:
  10. #    Handle www-url-encoding details
  11. #
  12. # CVS: $Id: s.uri.tcl 1.25 04/01/24 22:03:45-08:00 tcl@bluepeak.home $
  13.  
  14. package require Tcl 8.2
  15.  
  16. namespace eval ::uri {
  17.  
  18.     namespace export split join
  19.     namespace export resolve isrelative
  20.     namespace export geturl
  21.     namespace export canonicalize
  22.     namespace export register
  23.  
  24.     variable file:counter 0
  25.  
  26.     # extend these variable in the coming namespaces
  27.     variable schemes       {}
  28.     variable schemePattern ""
  29.     variable url           ""
  30.     variable url2part
  31.     array set url2part     {}
  32.  
  33.     # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  34.     # basic regular expressions used in URL syntax.
  35.  
  36.     namespace eval basic {
  37.     variable    loAlpha        {[a-z]}
  38.     variable    hiAlpha        {[A-Z]}
  39.     variable    digit        {[0-9]}
  40.     variable    alpha        {[a-zA-Z]}
  41.     variable    safe        {[$_.+-]}
  42.     variable    extra        {[!*'(,)]}
  43.     # danger in next pattern, order important for []
  44.     variable    national    {[][|\}\{\^~`]}
  45.     variable    punctuation    {[<>#%"]}    ;#" fake emacs hilit
  46.     variable    reserved    {[;/?:@&=]}
  47.     variable    hex        {[0-9A-Fa-f]}
  48.     variable    alphaDigit    {[A-Za-z0-9]}
  49.     variable    alphaDigitMinus    {[A-Za-z0-9-]}
  50.  
  51.     # next is <national | punctuation>
  52.     variable    unsafe        {[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
  53.     variable    escape        "%${hex}${hex}"
  54.  
  55.     #    unreserved    = alpha | digit | safe | extra
  56.     #    xchar        = unreserved | reserved | escape
  57.  
  58.     variable    unreserved    {[a-zA-Z0-9$_.+!*'(,)-]}
  59.     variable    uChar        "(${unreserved}|${escape})"
  60.     variable    xCharN        {[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
  61.     variable    xChar        "(${xCharN}|${escape})"
  62.     variable    digits        "${digit}+"
  63.  
  64.     variable    toplabel    \
  65.         "(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
  66.     variable    domainlabel    \
  67.         "(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"
  68.  
  69.     variable    hostname    \
  70.         "((${domainlabel}\\.)*${toplabel})"
  71.     variable    hostnumber    \
  72.         "(${digits}\\.${digits}\\.${digits}\\.${digits})"
  73.  
  74.     variable    host        "(${hostname}|${hostnumber})"
  75.  
  76.     variable    port        $digits
  77.     variable    hostOrPort    "${host}(:${port})?"
  78.  
  79.     variable    usrCharN    {[a-zA-Z0-9$_.+!*'(,);?&=-]}
  80.     variable    usrChar        "(${usrCharN}|${escape})"
  81.     variable    user        "${usrChar}*"
  82.     variable    password    $user
  83.     variable    login        "(${user}(:${password})?@)?${hostOrPort}"
  84.     } ;# basic {}
  85. }
  86.  
  87.  
  88. # ::uri::register --
  89. #
  90. #    Register a scheme (and aliases) in the package. The command
  91. #    creates a namespace below "::uri" with the same name as the
  92. #    scheme and executes the script declaring the pattern variables
  93. #    for this scheme in the new namespace. At last it updates the
  94. #    uri variables keeping track of overall scheme information.
  95. #
  96. #    The script has to declare at least the variable "schemepart",
  97. #    the pattern for an url of the registered scheme after the
  98. #    scheme declaration. Not declaring this variable is an error.
  99. #
  100. # Arguments:
  101. #    schemeList    Name of the scheme to register, plus aliases
  102. #       script        Script declaring the scheme patterns
  103. #
  104. # Results:
  105. #    None.
  106.  
  107. proc ::uri::register {schemeList script} {
  108.     variable schemes
  109.     variable schemePattern
  110.     variable url
  111.     variable url2part
  112.  
  113.     # Check scheme and its aliases for existence.
  114.     foreach scheme $schemeList {
  115.     if {[lsearch -exact $schemes $scheme] >= 0} {
  116.         return -code error \
  117.             "trying to register scheme (\"$scheme\") which is already known"
  118.     }
  119.     }
  120.  
  121.     # Get the main scheme
  122.     set scheme  [lindex $schemeList 0]
  123.  
  124.     if {[catch {namespace eval $scheme $script} msg]} {
  125.     catch {namespace delete $scheme}
  126.     return -code error \
  127.         "error while evaluating scheme script: $msg"
  128.     }
  129.  
  130.     if {![info exists ${scheme}::schemepart]} {
  131.     namespace delete $scheme
  132.     return -code error \
  133.         "Variable \"schemepart\" is missing."
  134.     }
  135.  
  136.     # Now we can extend the variables which keep track of the registered schemes.
  137.  
  138.     eval lappend schemes $schemeList
  139.     set schemePattern    "([::join $schemes |]):"
  140.  
  141.     foreach s schemeList {
  142.     # FRINK: nocheck
  143.     set url2part($s) "${s}:[set ${scheme}::schemepart]"
  144.     # FRINK: nocheck
  145.     append url "(${s}:[set ${scheme}::schemepart])|"
  146.     }
  147.     set url [string trimright $url |]
  148.     return
  149. }
  150.  
  151. # ::uri::split --
  152. #
  153. #    Splits the given <a url> into its constituents.
  154. #
  155. # Arguments:
  156. #    url    the URL to split
  157. #
  158. # Results:
  159. #    Tcl list containing constituents, suitable for 'array set'.
  160.  
  161. proc ::uri::split {url {defaultscheme http}} {
  162.  
  163.     set url [string trim $url]
  164.     set scheme {}
  165.  
  166.     # RFC 1738:    scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
  167.     regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme
  168.  
  169.     if {$scheme == {}} {
  170.     set scheme $defaultscheme
  171.     }
  172.  
  173.     # ease maintenance: dynamic dispatch, able to handle all schemes
  174.     # added in future!
  175.  
  176.     if {[::info procs Split[string totitle $scheme]] == {}} {
  177.     error "unknown scheme '$scheme' in '$url'"
  178.     }
  179.  
  180.     regsub -- "^${scheme}:" $url {} url
  181.  
  182.     set       parts(scheme) $scheme
  183.     array set parts [Split[string totitle $scheme] $url]
  184.  
  185.     # should decode all encoded characters!
  186.  
  187.     return [array get parts]
  188. }
  189.  
  190. proc ::uri::SplitFtp {url} {
  191.     # @c Splits the given ftp-<a url> into its constituents.
  192.     # @a url: The url to split, without! scheme specification.
  193.     # @r List containing the constituents, suitable for 'array set'.
  194.  
  195.     # general syntax:
  196.     # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
  197.     #
  198.     # additional rules:
  199.     #
  200.     # <user>:<password> are optional, detectable by presence of @.
  201.     # <password> is optional too.
  202.     #
  203.     # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
  204.     #    <cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]
  205.  
  206.     upvar \#0 [namespace current]::ftp::typepart ftptype
  207.  
  208.     array set parts {user {} pwd {} host {} port {} path {} type {}}
  209.  
  210.     # slash off possible type specification
  211.  
  212.     if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {
  213.  
  214.     set from    [lindex $ftype 0]
  215.     set to        [lindex $ftype 1]
  216.  
  217.     set parts(type)    [string range   $url $from $to]
  218.  
  219.     set from    [lindex $dummy 0]
  220.     set url        [string replace $url $from end]
  221.     }
  222.  
  223.     # Handle user, password, host and port
  224.  
  225.     if {[string match "//*" $url]} {
  226.     set url [string range $url 2 end]
  227.  
  228.     array set parts [GetUPHP url]
  229.     }
  230.  
  231.     set parts(path) [string trimleft $url /]
  232.  
  233.     return [array get parts]
  234. }
  235.  
  236. proc ::uri::JoinFtp args {
  237.     array set components {
  238.     user {} pwd {} host {} port {}
  239.     path {} type {}
  240.     }
  241.     array set components $args
  242.  
  243.     set userPwd {}
  244.     if {[string length $components(user)] || [string length $components(pwd)]} {
  245.     set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
  246.     }
  247.  
  248.     set port {}
  249.     if {[string length $components(port)]} {
  250.     set port :$components(port)
  251.     }
  252.  
  253.     set type {}
  254.     if {[string length $components(type)]} {
  255.     set type \;type=$components(type)
  256.     }
  257.  
  258.     return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
  259. }
  260.  
  261. proc ::uri::SplitHttps {url} {
  262.     uri::SplitHttp $url
  263. }
  264.  
  265. proc ::uri::SplitHttp {url} {
  266.     # @c Splits the given http-<a url> into its constituents.
  267.     # @a url: The url to split, without! scheme specification.
  268.     # @r List containing the constituents, suitable for 'array set'.
  269.  
  270.     # general syntax:
  271.     # //<host>:<port>/<path>?<searchpart>
  272.     #
  273.     #   where <host> and <port> are as described in Section 3.1. If :<port>
  274.     #   is omitted, the port defaults to 80.  No user name or password is
  275.     #   allowed.  <path> is an HTTP selector, and <searchpart> is a query
  276.     #   string. The <path> is optional, as is the <searchpart> and its
  277.     #   preceding "?". If neither <path> nor <searchpart> is present, the "/"
  278.     #   may also be omitted.
  279.     #
  280.     #   Within the <path> and <searchpart> components, "/", ";", "?" are
  281.     #   reserved.  The "/" character may be used within HTTP to designate a
  282.     #   hierarchical structure.
  283.     #
  284.     # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]
  285.  
  286.     upvar #0 [namespace current]::http::search  search
  287.     upvar #0 [namespace current]::http::segment segment
  288.  
  289.     array set parts {host {} port {} path {} query {}}
  290.  
  291.     set searchPattern   "\\?(${search})\$"
  292.     set fragmentPattern "#(${segment})\$"
  293.  
  294.     # slash off possible query
  295.  
  296.     if {[regexp -indices -- $searchPattern $url match query]} {
  297.     set from [lindex $query 0]
  298.     set to   [lindex $query 1]
  299.  
  300.     set parts(query) [string range $url $from $to]
  301.  
  302.     set url [string replace $url [lindex $match 0] end]
  303.     }
  304.  
  305.     # slash off possible fragment
  306.  
  307.     if {[regexp -indices -- $fragmentPattern $url match fragment]} {
  308.     set from [lindex $fragment 0]
  309.     set to   [lindex $fragment 1]
  310.  
  311.     set parts(fragment) [string range $url $from $to]
  312.  
  313.     set url [string replace $url [lindex $match 0] end]
  314.     }
  315.  
  316.     if {[string match "//*" $url]} {
  317.     set url [string range $url 2 end]
  318.  
  319.     array set parts [GetHostPort url]
  320.     }
  321.  
  322.     set parts(path) [string trimleft $url /]
  323.  
  324.     return [array get parts]
  325. }
  326.  
  327. proc ::uri::JoinHttp {args} {
  328.     eval uri::JoinHttpInner http 80 $args
  329. }
  330.  
  331. proc ::uri::JoinHttps {args} {
  332.     eval uri::JoinHttpInner https 443 $args
  333. }
  334.  
  335. proc ::uri::JoinHttpInner {scheme defport args} {
  336.     array set components [list \
  337.     host {} port $defport path {} query {} \
  338.     ]
  339.     array set components $args
  340.  
  341.     set port {}
  342.     if {[string length $components(port)] && $components(port) != $defport} {
  343.     set port :$components(port)
  344.     }
  345.  
  346.     set query {}
  347.     if {[string length $components(query)]} {
  348.     set query ?$components(query)
  349.     }
  350.  
  351.     regsub -- {^/} $components(path) {} components(path)
  352.  
  353.     if { [info exists components(fragment)] && $components(fragment) != "" } {
  354.     set components(fragment) "#$components(fragment)"
  355.     } else {
  356.     set components(fragment) ""
  357.     }
  358.  
  359.     return $scheme://$components(host)$port/$components(path)$components(fragment)$query
  360. }
  361.  
  362. proc ::uri::SplitFile {url} {
  363.     # @c Splits the given file-<a url> into its constituents.
  364.     # @a url: The url to split, without! scheme specification.
  365.     # @r List containing the constituents, suitable for 'array set'.
  366.  
  367.     upvar #0 [namespace current]::basic::hostname    hostname
  368.     upvar #0 [namespace current]::basic::hostnumber    hostnumber
  369.  
  370.     if {[string match "//*" $url]} {
  371.     set url [string range $url 2 end]
  372.  
  373.     set hostPattern "^($hostname|$hostnumber)"
  374.     switch -exact -- $::tcl_platform(platform) {
  375.         windows {
  376.         # Catch drive letter
  377.         append hostPattern :?
  378.         }
  379.         default {
  380.         # Proceed as usual
  381.         }
  382.     }
  383.  
  384.     if {[regexp -indices -- $hostPattern $url match host]} {
  385.         set fh    [lindex $host 0]
  386.         set th    [lindex $host 1]
  387.  
  388.         set parts(host)    [string range $url $fh $th]
  389.  
  390.         set  matchEnd   [lindex $match 1]
  391.         incr matchEnd
  392.  
  393.         set url    [string range $url $matchEnd end]
  394.     }
  395.     }
  396.  
  397.     set parts(path) $url
  398.  
  399.     return [array get parts]
  400. }
  401.  
  402. proc ::uri::JoinFile args {
  403.     array set components {
  404.     host {} port {} path {}
  405.     }
  406.     array set components $args
  407.  
  408.     switch -exact -- $::tcl_platform(platform) {
  409.     windows {
  410.         if {[string length $components(host)]} {
  411.         return file://$components(host):$components(path)
  412.         } else {
  413.         return file://$components(path)
  414.         }
  415.     }
  416.     default {
  417.         return file://$components(host)$components(path)
  418.     }
  419.     }
  420. }
  421.  
  422. proc ::uri::SplitMailto {url} {
  423.     # @c Splits the given mailto-<a url> into its constituents.
  424.     # @a url: The url to split, without! scheme specification.
  425.     # @r List containing the constituents, suitable for 'array set'.
  426.  
  427.     if {[string match "*@*" $url]} {
  428.     set url [::split $url @]
  429.     return [list user [lindex $url 0] host [lindex $url 1]]
  430.     } else {
  431.     return [list user $url]
  432.     }
  433. }
  434.  
  435. proc ::uri::JoinMailto args {
  436.     array set components {
  437.     user {} host {}
  438.     }
  439.     array set components $args
  440.  
  441.     return mailto:$components(user)@$components(host)
  442. }
  443.  
  444. proc ::uri::SplitNews {url} {
  445.     if { [string first @ $url] >= 0 } {
  446.     return [list message-id $url]
  447.     } else {
  448.     return [list newsgroup-name $url]
  449.     }
  450. }
  451.  
  452. proc ::uri::JoinNews args {
  453.     array set components {
  454.     message-id {} newsgroup-name {}
  455.     }
  456.     array set components $args
  457.     return news:$components(message-id)$components(newsgroup-name)
  458. }
  459.  
  460. proc ::uri::GetUPHP {urlvar} {
  461.     # @c Parse user, password host and port out of the url stored in
  462.     # @c variable <a urlvar>.
  463.     # @d Side effect: The extracted information is removed from the given url.
  464.     # @r List containing the extracted information in a format suitable for
  465.     # @r 'array set'.
  466.     # @a urlvar: Name of the variable containing the url to parse.
  467.  
  468.     upvar \#0 [namespace current]::basic::user        user
  469.     upvar \#0 [namespace current]::basic::password    password
  470.     upvar \#0 [namespace current]::basic::hostname    hostname
  471.     upvar \#0 [namespace current]::basic::hostnumber    hostnumber
  472.     upvar \#0 [namespace current]::basic::port        port
  473.  
  474.     upvar $urlvar url
  475.  
  476.     array set parts {user {} pwd {} host {} port {}}
  477.  
  478.     # syntax
  479.     # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
  480.     # "//" already cut off by caller
  481.  
  482.     set upPattern "^(${user})(:(${password}))?@"
  483.  
  484.     if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
  485.     set fu    [lindex $theUser 0]
  486.     set tu    [lindex $theUser 1]
  487.  
  488.     set fp    [lindex $thePassword 0]
  489.     set tp    [lindex $thePassword 1]
  490.  
  491.     set parts(user)    [string range $url $fu $tu]
  492.     set parts(pwd)    [string range $url $fp $tp]
  493.  
  494.     set  matchEnd   [lindex $match 1]
  495.     incr matchEnd
  496.  
  497.     set url    [string range $url $matchEnd end]
  498.     }
  499.  
  500.     set hpPattern "^($hostname|$hostnumber)(:($port))?"
  501.  
  502.     if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
  503.     set fh    [lindex $theHost 0]
  504.     set th    [lindex $theHost 1]
  505.  
  506.     set fp    [lindex $thePort 0]
  507.     set tp    [lindex $thePort 1]
  508.  
  509.     set parts(host)    [string range $url $fh $th]
  510.     set parts(port)    [string range $url $fp $tp]
  511.  
  512.     set  matchEnd   [lindex $match 1]
  513.     incr matchEnd
  514.  
  515.     set url    [string range $url $matchEnd end]
  516.     }
  517.  
  518.     return [array get parts]
  519. }
  520.  
  521. proc ::uri::GetHostPort {urlvar} {
  522.     # @c Parse host and port out of the url stored in variable <a urlvar>.
  523.     # @d Side effect: The extracted information is removed from the given url.
  524.     # @r List containing the extracted information in a format suitable for
  525.     # @r 'array set'.
  526.     # @a urlvar: Name of the variable containing the url to parse.
  527.  
  528.     upvar #0 [namespace current]::basic::hostname    hostname
  529.     upvar #0 [namespace current]::basic::hostnumber    hostnumber
  530.     upvar #0 [namespace current]::basic::port        port
  531.  
  532.     upvar $urlvar url
  533.  
  534.     set pattern "^(${hostname}|${hostnumber})(:(${port}))?"
  535.  
  536.     if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
  537.     set fromHost    [lindex $host 0]
  538.     set toHost    [lindex $host 1]
  539.  
  540.     set fromPort    [lindex $thePort 0]
  541.     set toPort    [lindex $thePort 1]
  542.  
  543.     set parts(host)    [string range $url $fromHost $toHost]
  544.     set parts(port)    [string range $url $fromPort $toPort]
  545.  
  546.     set  matchEnd   [lindex $match 1]
  547.     incr matchEnd
  548.  
  549.     set url [string range $url $matchEnd end]
  550.     }
  551.  
  552.     return [array get parts]
  553. }
  554.  
  555. # ::uri::resolve --
  556. #
  557. #    Resolve an arbitrary URL, given a base URL
  558. #
  559. # Arguments:
  560. #    base    base URL (absolute)
  561. #    url    arbitrary URL
  562. #
  563. # Results:
  564. #    Returns a URL
  565.  
  566. proc ::uri::resolve {base url} {
  567.     if {[string length $url]} {
  568.     if {[isrelative $url]} {
  569.  
  570.         array set baseparts [split $base]
  571.  
  572.         switch -- $baseparts(scheme) {
  573.         http -
  574.         https -
  575.         ftp -
  576.         file {
  577.             array set relparts [split $url]
  578.             if { [string match /* $url] } {
  579.             catch { set baseparts(path) $relparts(path) }
  580.             } elseif { [string match */ $baseparts(path)] } {
  581.             set baseparts(path) "$baseparts(path)$relparts(path)"
  582.             } else {
  583.             if { [string length $relparts(path)] > 0 } {
  584.                 set path [lreplace [::split $baseparts(path) /] end end]
  585.                 set baseparts(path) "[::join $path /]/$relparts(path)"
  586.             }
  587.             }
  588.             catch { set baseparts(query) $relparts(query) }
  589.             catch { set baseparts(fragment) $relparts(fragment) }
  590.             return [eval join [array get baseparts]]
  591.         }
  592.         default {
  593.             return -code error "unable to resolve relative URL \"$url\""
  594.         }
  595.         }
  596.  
  597.     } else {
  598.         return $url
  599.     }
  600.     } else {
  601.     return $base
  602.     }
  603. }
  604.  
  605. # ::uri::isrelative --
  606. #
  607. #    Determines whether a URL is absolute or relative
  608. #
  609. # Arguments:
  610. #    url    URL to check
  611. #
  612. # Results:
  613. #    Returns 1 if the URL is relative, 0 otherwise
  614.  
  615. proc ::uri::isrelative url {
  616.     return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
  617. }
  618.  
  619. # ::uri::geturl --
  620. #
  621. #    Fetch the data from an arbitrary URL.
  622. #
  623. #    This package provides a handler for the file:
  624. #    scheme, since this conflicts with the file command.
  625. #
  626. # Arguments:
  627. #    url    address of data resource
  628. #    args    configuration options
  629. #
  630. # Results:
  631. #    Depends on scheme
  632.  
  633. proc ::uri::geturl {url args} {
  634.     array set urlparts [split $url]
  635.  
  636.     switch -- $urlparts(scheme) {
  637.     file {
  638.         return [eval file_geturl [list $url] $args]
  639.     }
  640.     default {
  641.         # Load a geturl package for the scheme first and only if
  642.         # that fails the scheme package itself. This prevents
  643.         # cyclic dependencies between packages.
  644.         if {[catch {package require $urlparts(scheme)::geturl}]} {
  645.         package require $urlparts(scheme)
  646.         }
  647.         return [eval [list $urlparts(scheme)::geturl $url] $args]
  648.     }
  649.     }
  650. }
  651.  
  652. # ::uri::file_geturl --
  653. #
  654. #    geturl implementation for file: scheme
  655. #
  656. # TODO:
  657. #    This is an initial, basic implementation.
  658. #    Eventually want to support all options for geturl.
  659. #
  660. # Arguments:
  661. #    url    URL to fetch
  662. #    args    configuration options
  663. #
  664. # Results:
  665. #    Returns data from file
  666.  
  667. proc ::uri::file_geturl {url args} {
  668.     variable file:counter
  669.  
  670.     set var [namespace current]::file[incr file:counter]
  671.     upvar #0 $var state
  672.     array set state {data {}}
  673.  
  674.     array set parts [split $url]
  675.  
  676.     set ch [open $parts(path)]
  677.     # Could determine text/binary from file extension,
  678.     # except on Macintosh
  679.     # fconfigure $ch -translation binary
  680.     set state(data) [read $ch]
  681.     close $ch
  682.  
  683.     return $var
  684. }
  685.  
  686. # ::uri::join --
  687. #
  688. #    Format a URL
  689. #
  690. # Arguments:
  691. #    args    components, key-value format
  692. #
  693. # Results:
  694. #    A URL
  695.  
  696. proc ::uri::join args {
  697.     array set components $args
  698.  
  699.     return [eval [list Join[string totitle $components(scheme)]] $args]
  700. }
  701.  
  702. # ::uri::canonicalize --
  703. #
  704. #    Canonicalize a URL
  705. #
  706. # Acknowledgements:
  707. #    Andreas Kupries <andreas_kupries@users.sourceforge.net>
  708. #
  709. # Arguments:
  710. #    uri    URI (which contains a path component)
  711. #
  712. # Results:
  713. #    The canonical form of the URI
  714.  
  715. proc ::uri::canonicalize uri {
  716.  
  717.     # Make uri canonical with respect to dots (path changing commands)
  718.     #
  719.     # Remove single dots (.)  => pwd not changing
  720.     # Remove double dots (..) => gobble previous segment of path
  721.     #
  722.     # Fixes for this command:
  723.     #
  724.     # * Ignore any url which cannot be split into components by this
  725.     #   module. Just assume that such urls do not have a path to
  726.     #   canonicalize.
  727.     #
  728.     # * Ignore any url which could be split into components, but does
  729.     #   not have a path component.
  730.     #
  731.     # In the text above 'ignore' means
  732.     # 'return the url unchanged to the caller'.
  733.  
  734.     if {[catch {array set u [uri::split $uri]}]} {
  735.     return $uri
  736.     }
  737.     if {![info exists u(path)]} {
  738.     return $uri
  739.     }
  740.  
  741.     set uri $u(path)
  742.  
  743.     # Remove leading "./" "../" "/.." (and "/../")
  744.     regsub -all -- {^(\./)+}    $uri {}  uri
  745.     regsub -all -- {^/(\.\./)+} $uri {/} uri
  746.     regsub -all -- {^(\.\./)+}  $uri {}  uri
  747.  
  748.     # Remove inner /./ and /../
  749.     while {[regsub -all -- {/\./}         $uri {/} uri]} {}
  750.     while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
  751.     while {[regsub -all -- {^[^/]+/\.\./} $uri {}  uri]} {}
  752.     # Munge trailing /..
  753.     while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
  754.     if { $uri == ".." } { set uri "/" }
  755.  
  756.     set u(path) $uri
  757.     set uri [eval uri::join [array get u]]
  758.  
  759.     return $uri
  760. }
  761.  
  762. # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  763. # regular expressions covering various url schemes
  764.  
  765. # Currently known URL schemes:
  766. #
  767. # (RFC 1738)
  768. # ------------------------------------------------
  769. # scheme    basic syntax of scheme specific part
  770. # ------------------------------------------------
  771. # ftp        //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
  772. #
  773. # http        //<host>:<port>/<path>?<searchpart>
  774. #
  775. # gopher    //<host>:<port>/<gophertype><selector>
  776. #                <gophertype><selector>%09<search>
  777. #        <gophertype><selector>%09<search>%09<gopher+_string>
  778. #
  779. # mailto    <rfc822-addr-spec>
  780. # news        <newsgroup-name>
  781. #        <message-id>
  782. # nntp        //<host>:<port>/<newsgroup-name>/<article-number>
  783. # telnet    //<user>:<password>@<host>:<port>/
  784. # wais        //<host>:<port>/<database>
  785. #        //<host>:<port>/<database>?<search>
  786. #        //<host>:<port>/<database>/<wtype>/<wpath>
  787. # file        //<host>/<path>
  788. # prospero    //<host>:<port>/<hsoname>;<field>=<value>
  789. # ------------------------------------------------
  790. #
  791. # (RFC 2111)
  792. # ------------------------------------------------
  793. # scheme    basic syntax of scheme specific part
  794. # ------------------------------------------------
  795. # mid    message-id
  796. #        message-id/content-id
  797. # cid    content-id
  798. # ------------------------------------------------
  799.  
  800. # FTP
  801. uri::register ftp {
  802.     variable escape [set [namespace parent [namespace current]]::basic::escape]
  803.     variable login  [set [namespace parent [namespace current]]::basic::login]
  804.  
  805.     variable    charN    {[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
  806.     variable    char    "(${charN}|${escape})"
  807.     variable    segment    "${char}*"
  808.     variable    path    "${segment}(/${segment})*"
  809.  
  810.     variable    type        {[AaDdIi]}
  811.     variable    typepart    ";type=(${type})"
  812.     variable    schemepart    \
  813.             "//${login}(/${path}(${typepart})?)?"
  814.  
  815.     variable    url        "ftp:${schemepart}"
  816. }
  817.  
  818. # FILE
  819. uri::register file {
  820.     variable    host [set [namespace parent [namespace current]]::basic::host]
  821.     variable    path [set [namespace parent [namespace current]]::ftp::path]
  822.  
  823.     variable    schemepart    "//(${host}|localhost)?/${path}"
  824.     variable    url        "file:${schemepart}"
  825. }
  826.  
  827. # HTTP
  828. uri::register http {
  829.     variable    escape \
  830.         [set [namespace parent [namespace current]]::basic::escape]
  831.     variable    hostOrPort    \
  832.         [set [namespace parent [namespace current]]::basic::hostOrPort]
  833.  
  834.     variable    charN        {[a-zA-Z0-9$_.+!*'(,);:@&=-]}
  835.     variable    char        "($charN|${escape})"
  836.     variable    segment        "${char}*"
  837.  
  838.     variable    path        "${segment}(/${segment})*"
  839.     variable    search        $segment
  840.     variable    schemepart    \
  841.         "//${hostOrPort}(/${path}(\\?${search})?)?"
  842.  
  843.     variable    url        "http:${schemepart}"
  844. }
  845.  
  846. # GOPHER
  847. uri::register gopher {
  848.     variable    xChar \
  849.         [set [namespace parent [namespace current]]::basic::xChar]
  850.     variable    hostOrPort \
  851.         [set [namespace parent [namespace current]]::basic::hostOrPort]
  852.     variable    search \
  853.         [set [namespace parent [namespace current]]::http::search]
  854.  
  855.     variable    type        $xChar
  856.     variable    selector    "$xChar*"
  857.     variable    string        $selector
  858.     variable    schemepart    \
  859.         "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
  860.     variable    url        "gopher:${schemepart}"
  861. }
  862.  
  863. # MAILTO
  864. uri::register mailto {
  865.     variable xChar [set [namespace parent [namespace current]]::basic::xChar]
  866.     variable host  [set [namespace parent [namespace current]]::basic::host]
  867.  
  868.     variable schemepart    "$xChar+(@${host})?"
  869.     variable url    "mailto:${schemepart}"
  870. }
  871.  
  872. # NEWS
  873. uri::register news {
  874.     variable escape [set [namespace parent [namespace current]]::basic::escape]
  875.     variable alpha  [set [namespace parent [namespace current]]::basic::alpha]
  876.     variable host   [set [namespace parent [namespace current]]::basic::host]
  877.  
  878.     variable    aCharN        {[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
  879.     variable    aChar        "($aCharN|${escape})"
  880.     variable    gChar        {[a-zA-Z0-9$_.+-]}
  881.     variable    newsgroup-name    "${alpha}${gChar}*"
  882.     variable    message-id    "${aChar}+@${host}"
  883.     variable    schemepart    "\\*|${newsgroup-name}|${message-id}"
  884.     variable    url        "news:${schemepart}"
  885. }
  886.  
  887. # WAIS
  888. uri::register wais {
  889.     variable    uChar \
  890.         [set [namespace parent [namespace current]]::basic::xChar]
  891.     variable    hostOrPort \
  892.         [set [namespace parent [namespace current]]::basic::hostOrPort]
  893.     variable    search \
  894.         [set [namespace parent [namespace current]]::http::search]
  895.  
  896.     variable    db        "${uChar}*"
  897.     variable    type        "${uChar}*"
  898.     variable    path        "${uChar}*"
  899.  
  900.     variable    database    "//${hostOrPort}/${db}"
  901.     variable    index        "//${hostOrPort}/${db}\\?${search}"
  902.     variable    doc        "//${hostOrPort}/${db}/${type}/${path}"
  903.  
  904.     #variable    schemepart    "${doc}|${index}|${database}"
  905.  
  906.     variable    schemepart \
  907.         "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"
  908.  
  909.     variable    url        "wais:${schemepart}"
  910. }
  911.  
  912. # PROSPERO
  913. uri::register prospero {
  914.     variable    escape \
  915.         [set [namespace parent [namespace current]]::basic::escape]
  916.     variable    hostOrPort \
  917.         [set [namespace parent [namespace current]]::basic::hostOrPort]
  918.     variable    path \
  919.         [set [namespace parent [namespace current]]::ftp::path]
  920.  
  921.     variable    charN        {[a-zA-Z0-9$_.+!*'(,)?:@&-]}
  922.     variable    char        "(${charN}|$escape)"
  923.  
  924.     variable    fieldname    "${char}*"
  925.     variable    fieldvalue    "${char}*"
  926.     variable    fieldspec    ";${fieldname}=${fieldvalue}"
  927.  
  928.     variable    schemepart    "//${hostOrPort}/${path}(${fieldspec})*"
  929.     variable    url        "prospero:$schemepart"
  930. }
  931.  
  932. package provide uri 1.1.3
  933.