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