summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/uri
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:39:39 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:39:39 (GMT)
commitea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch)
tree6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/uri
parentb5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff)
parent7c621da28f07e449ad90c387344f07a453927569 (diff)
downloadblt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip
blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz
blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/uri')
-rw-r--r--tcllib/modules/uri/ChangeLog413
-rw-r--r--tcllib/modules/uri/pkgIndex.tcl6
-rw-r--r--tcllib/modules/uri/uri-rfc2396.test208
-rw-r--r--tcllib/modules/uri/uri.man197
-rw-r--r--tcllib/modules/uri/uri.tcl1050
-rw-r--r--tcllib/modules/uri/uri.test526
-rw-r--r--tcllib/modules/uri/uri_urn.pcx27
-rw-r--r--tcllib/modules/uri/urn-scheme.man41
-rw-r--r--tcllib/modules/uri/urn-scheme.tcl143
-rw-r--r--tcllib/modules/uri/urn.test175
10 files changed, 2786 insertions, 0 deletions
diff --git a/tcllib/modules/uri/ChangeLog b/tcllib/modules/uri/ChangeLog
new file mode 100644
index 0000000..f77f855
--- /dev/null
+++ b/tcllib/modules/uri/ChangeLog
@@ -0,0 +1,413 @@
+2013-12-06 Andreas Kupries <andreask@activestate.com>
+
+ * uri.tcl (::uri::split, ::uri::resolve): [Ticket cfb76ff94]:
+ * uri.test: Modified split so that a missing scheme for http(s),
+ * uri.man: ftp urls treats remainder as having a leading host
+ * pkgIndex.tcl: part. Extended testsuite. Updated 'resolve' to run
+ the relative url through split with a proper scheme prefix to
+ prevent misintepretation of the path as host-part. Bumped
+ version number to 1.2.4
+
+2013-11-07 Andreas Kupries <andreask@activestate.com>
+
+ * uri.tcl: [Ticket dc50cc65ea]: Accept schema names
+ * uri.test: case-insensitively. Report and patch by Harald
+ * pkgIndex.tcl: Oehlmann. Version bumped to 1.2.3. Extended
+ testsuite (uri-11.0).
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: [Bug #3235340]: Provide empty string as default
+ * uri.man: value for the fragment in an http url. Ensure that
+ * uri.tcl: a fragment after a query is properly split off, and
+ * uri.test: joined. Extended testsuite. Bumped to version 1.2.2.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-03-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * urn-scheme.man: Added documentation for package uri::urn.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2007-01-11 Andreas Kupries <andreask@activestate.com>
+
+ * uri.tcl (::uri::SplitHttp): [SF Tcllib Bug 1610655]. Modified to
+ * uri.man: slash of queries after the first question mark, not the
+ * uri.test: last. We have queries with subqueries in the wild,
+ * pkgIndex.tcl: bogus per the spec, but in use. Version has been
+ bumped to 1.2.1.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * uri.man: Bumped version to 1.2
+ * uri.tcl
+ * pkgIndex.tcl:
+
+2006-08-11 Andreas Kupries <andreask@activestate.com>
+
+ * uri.man: Fixed a typo I left in the manpage :(
+
+2006-08-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Added ldap to list of supported uri's, per the
+ * uri.man: patch by Pierre DAVID <Pierre.David@crc.u-strasbg.fr>,
+ * uri.test: with small modifications by myself. Extended code,
+ documentation, and testsuite.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.test: Fixed use of duplicate test names. Also fixed creation
+ and cleanup of temp. files by the testsuite.
+
+2006-01-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri-rfc2396.test: More boilerplate simplified via use of test support.
+ * uri.test:
+ * urn.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri-rfc2396.test: Hooked into the new common test support code.
+ * uri.test:
+ * urn.test:
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * uri.man: Added information about url constituents to the
+ documentation of uri::split. For the schemes we know them
+ for. This fixes [SF Tcllib Bug 1335320] by Kristoffer Lawson
+ <setok@users.sourceforge.net>.
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * urn.test: Fixed typo.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-07-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Fixed bug 1243171, reported by Jean-Luc Fontaine. The
+ list variable in a foreach had no $-prefix. D'oh.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * urn-scheme.tcl (urn::unquote): The latest unquote used features
+ specific to 8.3 (regexp -start), and the package claims
+ useability with 8.2. Added a check for the version of Tcl, and
+ for 8.2 we now provide a variant implementation of unquote for
+ 8.2 which does not use 'regexp -start', but simulates it.
+
+2004-08-03 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * urn-scheme.tcl: Fixed the unquote function which was broken.
+ * urn.test: Added some tests from RFC 2324 to check the
+ quote and unquote procedures.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Updated version number to sync with 1.6.1
+ * uri.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Rel. engineering. Updated version number
+ * uri.man: of uri to reflect its changes, to 1.1.4.
+ * pkgIndex.tcl:
+
+2004-05-03 Andreas Kupries <andreask@pliers.activestate.com>
+
+ * uri.test:
+ * uri.tcl (SplitHttp): Fixed [SF Tcllib Bug 936064]. Now
+ extracting user/password information from the Http URI as
+ well. Simple change from 'GetHostPort' to 'GetUPHP'. Updated the
+ test suite as well (One new test, and update of 4 existing
+ tests).
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * urn.test: Added dict sorting for reliable comparisons.
+
+2003-08-27 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uri.tcl: Applied a fix for bug #795032: damage to global vars.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * urn-scheme.tcl (::uri::urn::quote): Fix this to work properly
+ with tcl 8.2.
+
+2003-04-14 Andreas Kupries <andreask@activestate.com>
+
+ * uri.man:
+ * uri.tcl (split): Accepted the FR [#545368] by Mark G. Saye
+ <markgsaye@users.sourceforge.net>, with a slight difference. To
+ keep API compatibibility the http stays the default scheme if
+ none was specified.
+
+2003-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri-rfc2396.test: Added constraint 'knownBug' to these
+ tests. And reference to [#581781].
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * uri.test:
+ * uri.tcl (::uri::split): Fixed bug #676976 reported by Jason
+ Mills <jasonmills@users.sourceforge.net>. An incorrect regular
+ expression (typo in character class) accepted more character
+ than it should have.
+
+2003-04-10 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl:
+ * uri.man:
+ * uri.tcl: Fixed bug #614591. Set version
+ of the package to to 1.1.2.
+
+ * urn-scheme.tcl: Fixed bug #614591. Set version
+ of the package to to 1.0.1
+
+2003-03-28 Andreas Kupries <andreask@activestate.com>
+
+ * uri.man:
+ * uri-rfc2396.test: New file. First step towards conformance with
+ RFC 2396, a testsuite for checking conformant behaviour. Thanks
+ to Rolf Ade <pointsman@users.sourceforge.net>. Bug
+ #581781. Noted non-conformance in documentation, inviting help.
+
+2003-02-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uri.test (uri-4.1): Fixed bad test.
+
+2003-02-06 David N. Welton <davidw@dedasys.com>
+
+ * uri.tcl (uri::SplitMailto): Use 'string match' instead of
+ regexp.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.man: More semantic markup, less visual one.
+
+2003-01-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Bump ifneeded patchlevel to match the provide in
+ uri.tcl. See last change.
+
+2002-11-15 David N. Welton <davidw@dedasys.com>
+
+ * uri.tcl (uri::canonicalize): Take care of trailing .., as in
+ "http://foobar.com/foo/bar/..".
+
+ * uri.test: Test for the above condition.
+
+ * uri.tcl: Bump patchlevel in 'package provide'.
+
+ * uri.test: Added tests for 'news' splitting and joining.
+
+ * uri.man: Added 'news' to list of supported uri's.
+
+ * uri.tcl (uri::SplitNews) (uri::JoinNews): Join and split 'news'
+ URI's. Fixes 636977.
+
+ * uri.test: Added test to make sure that a URI can be split and
+ then joined. to make sure the change below works.
+
+ * uri.tcl (uri::JoinHttpInner): Make this proc deal with
+ 'fragments' - i.e. the #foo part of a URI. Fixes 638075.
+
+ * uri.test: Added tests relevant to the fix below.
+
+ * uri.tcl (uri::resolve): Fix handling of queries so that the
+ 'new' query overrides the 'old' one. This is how browsers do it.
+ Fixes 639036.
+
+2002-06-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * urn-scheme.tcl: Moved provide up to the front to prevent
+ problems with [pkg_mkIndex]. Added namespace creation commands
+ to the top for the same reason.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.man: Fixed formatting errors in the doctools manpage.
+
+2002-02-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Fixed "::uri::canonicalize" to pass the extended
+ testsuite. The change to testsuite and command implementation
+ here was triggered through work on a spider and real life urls,
+ some of which where handled incorrectly.
+
+ * uri.test: Extended the testsuite for "::uri::canonicalize" a
+ lot. Handling of uris with a path, without a path, unknown uri
+ schemes, path components which contain a ".", but are neither
+ "." nor "..".
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * urn-scheme.tcl: Frink run.
+
+ * Version is now 1.1.1 to distinguish from the code in tcllib
+ release 1.2
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.1
+
+2001-11-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.n: Updated documentation to cover the change below.
+
+ * uri.tcl: Changed geturl dispatcher to load a scheme::geturl
+ first and the scheme package only if that fails. See the ftp and
+ ftp::geturl packages. FR #476804.
+
+2001-10-31 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uri.tcl: Fixed the ftptype regexp so that the type identifier
+ can be extracted. Fixed the ftp join code to follow the specs
+ for the type identifier. Added tests.
+
+2001-10-31 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uri.tcl: Fixes for SF bug 474846 concerning bugs with ftp
+ userinfo and path construction.
+
+ * uri.test: New tests to chec the above fixes.
+
+2001-10-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * The changes below are made as part of accepting SF patch #470211
+ provided by Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uri.n: Documented "uri::register".
+
+ * urn-scheme.tcl: Changed to use the new registration
+ command. Added declaration of "schemepart" as that variable is
+ required for the registration.
+
+ * uri.tcl (uri::register): New command to register url
+ schemes. Rewrote the module to make use of this command when
+ declaring the standard schemes like ftp, http, ... Fixed a bug
+ in the url declarations (access to namespace basic was
+ incorrect). The command takes care to update the overall
+ variables tracking scheme information.
+
+ * pkgIndex.tcl: Added the new sub-package to our package index.
+
+ * urn.test:
+ * urn-scheme.tcl: New files, new sub-packages, provide the URN
+ schema for uri's and associated testsuite.
+
+2001-08-21 Don Porter <dgp@users.sourceforge.net>
+
+ * uri.n: Corrected title. The 'uri' package does not
+ provide "Tcl Built-In Commands."
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uri.tcl: Fixed dubious code reported by frink.
+
+2000-09-06 Brent Welch <welch@ajubasolutions.com>
+
+ * uri.tcl:
+ * uri.test:
+ Added https support
+
+2000-07-20 Eric Melski <ericm@ajubasolutions.com>
+
+ * uri.test:
+ * uri.tcl: Applied patch from Andreas Kupries, to correct infinite loop
+ condition in uri::canonicalize.
+
+2000-06-16 Eric Melski <ericm@ajubasolutions.com>
+
+ * uri.test: Fixed bad test, added tcltest::cleanupTests call.
+
+2000-06-13 Eric Melski <ericm@scriptics.com>
+
+ * uri: initial import of uri package.
+
diff --git a/tcllib/modules/uri/pkgIndex.tcl b/tcllib/modules/uri/pkgIndex.tcl
new file mode 100644
index 0000000..902efda
--- /dev/null
+++ b/tcllib/modules/uri/pkgIndex.tcl
@@ -0,0 +1,6 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ # FRINK: nocheck
+ return
+}
+package ifneeded uri 1.2.6 [list source [file join $dir uri.tcl]]
+package ifneeded uri::urn 1.0.3 [list source [file join $dir urn-scheme.tcl]]
diff --git a/tcllib/modules/uri/uri-rfc2396.test b/tcllib/modules/uri/uri-rfc2396.test
new file mode 100644
index 0000000..53a188f
--- /dev/null
+++ b/tcllib/modules/uri/uri-rfc2396.test
@@ -0,0 +1,208 @@
+# -*- tcl -*-
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal uri.tcl uri
+}
+
+# -------------------------------------------------------------------------
+
+test uri-rfc2396-1.1 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g:h]
+} g:h
+
+test uri-rfc2396-1.2 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g]
+} http://a/b/c/g
+
+test uri-rfc2396-1.3 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ./g]
+} http://a/b/c/g
+
+test uri-rfc2396-1.4 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g/]
+} http://a/b/c/g/
+
+test uri-rfc2396-1.5 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q /g]
+} http://a/g
+
+test uri-rfc2396-1.6 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q //g]
+} http://g
+
+test uri-rfc2396-1.7 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ?y]
+} http://a/b/c/?y
+
+test uri-rfc2396-1.8 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g?y]
+} http://a/b/c/g?y
+
+test uri-rfc2396-1.9 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q \#s]
+} {(current document)\#s}
+
+test uri-rfc2396-1.10 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\#s]
+} http://a/b/c/g\#s
+
+test uri-rfc2396-1.11 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g?y\#s]
+} http://a/b/c/g?y\#s
+
+test uri-rfc2396-1.12 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q \;x]
+} http://a/b/c/\;x
+
+test uri-rfc2396-1.13 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\;x]
+} http://a/b/c/g\;x
+
+test uri-rfc2396-1.14 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\;x?y#s]
+} http://a/b/c/g\;x?y#s
+
+test uri-rfc2396-1.15 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q .]
+} http://a/b/c/
+
+test uri-rfc2396-1.16 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ./]
+} http://a/b/c/
+
+test uri-rfc2396-1.17 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ..]
+} http://a/b/
+
+test uri-rfc2396-1.18 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../]
+} http://a/b/
+
+test uri-rfc2396-1.19 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../g]
+} http://a/b/g
+
+test uri-rfc2396-1.20 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../..]
+} http://a/
+
+test uri-rfc2396-1.21 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../../]
+} http://a/
+
+test uri-rfc2396-1.22 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../../g]
+} http://a/g
+
+
+test uri-rfc2396-2.1 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g:h]
+} g:h
+
+test uri-rfc2396-2.2 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g]
+} http://a/b/c/g
+
+test uri-rfc2396-2.3 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ./g]
+} http://a/b/c/g
+
+test uri-rfc2396-2.4 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g/]
+} http://a/b/c/g/
+
+test uri-rfc2396-2.5 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p /g]
+} http://a/g
+
+test uri-rfc2396-2.6 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p //g]
+} http://g
+
+test uri-rfc2396-2.7 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ?y]
+} http://a/b/c/?y
+
+test uri-rfc2396-2.8 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g?y]
+} http://a/b/c/g?y
+
+test uri-rfc2396-2.9 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p \#s]
+} {(current document)\#s}
+
+test uri-rfc2396-2.10 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g\#s]
+} http://a/b/c/g\#s
+
+test uri-rfc2396-2.11 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g?y\#s]
+} http://a/b/c/g?y\#s
+
+test uri-rfc2396-2.12 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p \;x]
+} http://a/b/c/\;x
+
+test uri-rfc2396-2.13 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g\;x]
+} http://a/b/c/g\;x
+
+test uri-rfc2396-2.14 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p g\;x?y#s]
+} http://a/b/c/g\;x?y#s
+
+test uri-rfc2396-2.15 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p .]
+} http://a/b/c/
+
+test uri-rfc2396-2.16 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ./]
+} http://a/b/c/
+
+test uri-rfc2396-2.17 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ..]
+} http://a/b/
+
+test uri-rfc2396-2.18 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ../]
+} http://a/b/
+
+test uri-rfc2396-2.19 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ../g]
+} http://a/b/g
+
+test uri-rfc2396-2.20 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ../..]
+} http://a/
+
+test uri-rfc2396-2.21 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ../../]
+} http://a/
+
+test uri-rfc2396-2.22 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+ uri::canonicalize [uri::resolve http://a/b/c/d\;p ../../g]
+} http://a/g
+
+
+#test uri-rfc2396-2. {uri::resolve} {knownBug sf-tcllib-bug-581781} {
+# uri::resolve http://a/b/c/d\;p
+#}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/uri/uri.man b/tcllib/modules/uri/uri.man
new file mode 100644
index 0000000..2d1d92c
--- /dev/null
+++ b/tcllib/modules/uri/uri.man
@@ -0,0 +1,197 @@
+[vset VERSION 1.2.6]
+[manpage_begin uri n [vset VERSION]]
+[keywords {fetching information}]
+[keywords file]
+[keywords ftp]
+[keywords gopher]
+[keywords http]
+[keywords ldap]
+[keywords mailto]
+[keywords news]
+[keywords prospero]
+[keywords {rfc 2255}]
+[keywords {rfc 2396}]
+[keywords uri]
+[keywords url]
+[keywords wais]
+[keywords www]
+[moddesc {Tcl Uniform Resource Identifier Management}]
+[titledesc {URI utilities}]
+[category Networking]
+[require Tcl 8.2]
+[require uri [opt [vset VERSION]]]
+[description]
+
+This package contains two parts. First it provides regular expressions
+for a number of url/uri schemes. Second it provides a number of
+commands for manipulating urls/uris and fetching data specified by
+them. For the latter this package analyses the requested url/uri and
+then dispatches it to the appropriate package (http, ftp, ...) for
+actual fetching.
+
+[para]
+
+The package currently does not conform to
+RFC 2396 ([uri http://www.rfc-editor.org/rfc/rfc2396.txt]),
+but quite likely should be. Patches and other help are welcome.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd uri::split] [arg url] [opt [arg defaultscheme]]]
+
+[cmd uri::split] takes an [arg url], decodes it and then returns a
+list of key/value pairs suitable for [cmd "array set"] containing the
+constituents of the [arg url]. If the scheme is missing from the url
+it defaults to the value of [arg defaultscheme] if it was specified,
+or [term http] else. Currently only the schemes [term http],
+
+[term ftp], [term mailto], [term urn], [term news], [term ldap] and
+[term file] are supported by the package itself.
+
+See section [sectref EXTENDING] on how to expand that range.
+
+[para]
+
+The set of constituents of an url (= the set of keys in the returned
+dictionary) is dependent on the scheme of the url. The only key which
+is therefore always present is [const scheme]. For the following
+schemes the constituents and their keys are known:
+
+[list_begin definitions]
+[def ftp]
+[const user], [const pwd], [const host], [const port],
+[const path], [const type]
+
+[def http(s)]
+[const user], [const pwd], [const host], [const port],
+[const path], [const query], [const fragment]. The fragment
+is optional.
+
+[def file]
+[const path], [const host]. The host is optional.
+
+[def mailto]
+[const user], [const host]. The host is optional.
+
+[def news]
+Either [const message-id] or [const newsgroup-name].
+
+[list_end]
+[para]
+
+[call [cmd uri::join] [opt "[arg key] [arg value]"]...]
+
+[cmd uri::join] takes a list of key/value pairs (generated by
+
+[cmd uri::split], for example) and returns the canonical url they
+represent. Currently only the schemes [term http], [term ftp],
+[term mailto], [term urn], [term news], [term ldap] and [term file]
+are supported. See section [sectref EXTENDING] on how to expand that
+range.
+
+[call [cmd uri::resolve] [arg base] [arg url]]
+
+[cmd uri::resolve] resolves the specified [arg url] relative to
+
+[arg base]. In other words: A non-relative [arg url] is returned
+unchanged, whereas for a relative [arg url] the missing parts are
+taken from [arg base] and prepended to it. The result of this
+operation is returned. For an empty [arg url] the result is
+
+[arg base].
+
+[call [cmd uri::isrelative] [arg url]]
+
+[cmd uri::isrelative] determines whether the specified [arg url] is
+absolute or relative.
+
+[call [cmd uri::geturl] [arg url] [opt "[arg options]..."]]
+
+[cmd uri::geturl] decodes the specified [arg url] and then dispatches
+the request to the package appropriate for the scheme found in the
+url. The command assumes that the package to handle the given scheme
+either has the same name as the scheme itself (including possible
+capitalization) followed by [cmd ::geturl], or, in case of this
+failing, has the same name as the scheme itself (including possible
+capitalization). It further assumes that whatever package was loaded
+provides a [cmd geturl]-command in the namespace of the same name as
+the package itself. This command is called with the given [arg url]
+and all given [arg options]. Currently [cmd geturl] does not handle
+any options itself.
+
+[para]
+
+[emph Note:] [term file]-urls are an exception to the rule
+described above. They are handled internally.
+
+[para]
+
+It is not possible to specify results of the command. They depend on
+the [cmd geturl]-command for the scheme the request was dispatched to.
+
+[call [cmd uri::canonicalize] [arg uri]]
+
+[cmd uri::canonicalize] returns the canonical form of a URI. The
+canonical form of a URI is one where relative path specifications,
+ie. . and .., have been resolved.
+
+[call [cmd uri::register] [arg schemeList] [arg script]]
+
+[cmd uri::register] registers the first element of [arg schemeList] as
+a new scheme and the remaining elements as aliases for this scheme. It
+creates the namespace for the scheme and executes the [arg script] in
+the new namespace. The script has to declare variables containing the
+regular expressions relevant to the scheme. At least the variable
+[var schemepart] has to be declared as that one is used to extend
+the variables keeping track of the registered schemes.
+
+[list_end]
+
+[section SCHEMES]
+
+In addition to the commands mentioned above this package provides
+regular expression to recognize urls for a number of url schemes.
+
+[para]
+
+For each supported scheme a namespace of the same name as the scheme
+itself is provided inside of the namespace [emph uri] containing the
+variable [var url] whose contents are a regular expression to
+recognize urls of that scheme. Additional variables may contain
+regular expressions for parts of urls for that scheme.
+
+[para]
+
+The variable [var uri::schemes] contains a list of all supported
+schemes. Currently these are [term ftp], [term ldap], [term file],
+
+[term http], [term gopher], [term mailto], [term news],
+[term wais] and [term prospero].
+
+[section EXTENDING]
+
+Extending the range of schemes supported by [cmd uri::split] and
+
+[cmd uri::join] is easy because both commands do not handle the
+request by themselves but dispatch it to another command in the
+[emph uri] namespace using the scheme of the url as criterion.
+
+[para]
+
+[cmd uri::split] and [cmd uri::join]
+
+call [cmd "Split[lb]string totitle <scheme>[rb]"]
+and [cmd "Join[lb]string totitle <scheme>[rb]"] respectively.
+
+[section CREDITS]
+[para]
+
+Original code (regular expressions) by Andreas Kupries.
+Modularisation by Steve Ball, also the split/join/resolve
+functionality.
+
+[vset CATEGORY uri]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/uri/uri.tcl b/tcllib/modules/uri/uri.tcl
new file mode 100644
index 0000000..47dff48
--- /dev/null
+++ b/tcllib/modules/uri/uri.tcl
@@ -0,0 +1,1050 @@
+# uri.tcl --
+#
+# URI parsing and fetch
+#
+# Copyright (c) 2000 Zveno Pty Ltd
+# Copyright (c) 2006 Pierre DAVID <Pierre.David@crc.u-strasbg.fr>
+# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Steve Ball, http://www.zveno.com/
+# Derived from urls.tcl by Andreas Kupries
+#
+# TODO:
+# Handle www-url-encoding details
+#
+# CVS: $Id: uri.tcl,v 1.36 2011/03/23 04:39:54 andreas_kupries Exp $
+
+package require Tcl 8.2
+
+namespace eval ::uri {
+
+ namespace export split join
+ namespace export resolve isrelative
+ namespace export geturl
+ namespace export canonicalize
+ namespace export register
+
+ variable file:counter 0
+
+ # extend these variable in the coming namespaces
+ variable schemes {}
+ variable schemePattern ""
+ variable url ""
+ variable url2part
+ array set url2part {}
+
+ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ # basic regular expressions used in URL syntax.
+
+ namespace eval basic {
+ variable loAlpha {[a-z]}
+ variable hiAlpha {[A-Z]}
+ variable digit {[0-9]}
+ variable alpha {[a-zA-Z]}
+ variable safe {[$_.+-]}
+ variable extra {[!*'(,)]}
+ # danger in next pattern, order important for []
+ variable national {[][|\}\{\^~`]}
+ variable punctuation {[<>#%"]} ;#" fake emacs hilit
+ variable reserved {[;/?:@&=]}
+ variable hex {[0-9A-Fa-f]}
+ variable alphaDigit {[A-Za-z0-9]}
+ variable alphaDigitMinus {[A-Za-z0-9-]}
+
+ # next is <national | punctuation>
+ variable unsafe {[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
+ variable escape "%${hex}${hex}"
+
+ # unreserved = alpha | digit | safe | extra
+ # xchar = unreserved | reserved | escape
+
+ variable unreserved {[a-zA-Z0-9$_.+!*'(,)-]}
+ variable uChar "(${unreserved}|${escape})"
+ variable xCharN {[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
+ variable xChar "(${xCharN}|${escape})"
+ variable digits "${digit}+"
+
+ variable toplabel \
+ "(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
+ variable domainlabel \
+ "(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"
+
+ variable hostname \
+ "((${domainlabel}\\.)*${toplabel})"
+ variable hostnumber4 \
+ "(?:${digits}\\.${digits}\\.${digits}\\.${digits})"
+ variable hostnumber6 {(?:\[[^]]*\])}
+ variable hostnumber "(${hostnumber4}|${hostnumber6})"
+
+ variable host "(${hostname}|${hostnumber})"
+
+ variable port $digits
+ variable hostOrPort "${host}(:${port})?"
+
+ variable usrCharN {[a-zA-Z0-9$_.+!*'(,);?&=-]}
+ variable usrChar "(${usrCharN}|${escape})"
+ variable user "${usrChar}*"
+ variable password $user
+ variable login "(${user}(:${password})?@)?${hostOrPort}"
+ } ;# basic {}
+}
+
+
+# ::uri::register --
+#
+# Register a scheme (and aliases) in the package. The command
+# creates a namespace below "::uri" with the same name as the
+# scheme and executes the script declaring the pattern variables
+# for this scheme in the new namespace. At last it updates the
+# uri variables keeping track of overall scheme information.
+#
+# The script has to declare at least the variable "schemepart",
+# the pattern for an url of the registered scheme after the
+# scheme declaration. Not declaring this variable is an error.
+#
+# Arguments:
+# schemeList Name of the scheme to register, plus aliases
+# script Script declaring the scheme patterns
+#
+# Results:
+# None.
+
+proc ::uri::register {schemeList script} {
+ variable schemes
+ variable schemePattern
+ variable url
+ variable url2part
+
+ # Check scheme and its aliases for existence.
+ foreach scheme $schemeList {
+ if {[lsearch -exact $schemes $scheme] >= 0} {
+ return -code error \
+ "trying to register scheme (\"$scheme\") which is already known"
+ }
+ }
+
+ # Get the main scheme
+ set scheme [lindex $schemeList 0]
+
+ if {[catch {namespace eval $scheme $script} msg]} {
+ catch {namespace delete $scheme}
+ return -code error \
+ "error while evaluating scheme script: $msg"
+ }
+
+ if {![info exists ${scheme}::schemepart]} {
+ namespace delete $scheme
+ return -code error \
+ "Variable \"schemepart\" is missing."
+ }
+
+ # Now we can extend the variables which keep track of the registered schemes.
+
+ eval [linsert $schemeList 0 lappend schemes]
+ set schemePattern "([::join $schemes |]):"
+
+ foreach s $schemeList {
+ # FRINK: nocheck
+ set url2part($s) "${s}:[set ${scheme}::schemepart]"
+ # FRINK: nocheck
+ append url "(${s}:[set ${scheme}::schemepart])|"
+ }
+ set url [string trimright $url |]
+ return
+}
+
+# ::uri::split --
+#
+# Splits the given <a url> into its constituents.
+#
+# Arguments:
+# url the URL to split
+#
+# Results:
+# Tcl list containing constituents, suitable for 'array set'.
+
+proc ::uri::split {url {defaultscheme http}} {
+
+ set url [string trim $url]
+ set scheme {}
+
+ # RFC 1738: scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
+ regexp -- {^([A-Za-z0-9+.-][A-Za-z0-9+.-]*):} $url dummy scheme
+
+ if {$scheme == {}} {
+ set scheme $defaultscheme
+ switch -- $scheme {
+ http - https - ftp {
+ # Force an empty host part
+ set url //$url
+ }
+ }
+ }
+
+ # ease maintenance: dynamic dispatch, able to handle all schemes
+ # added in future!
+
+ if {[::info procs Split[string totitle $scheme]] == {}} {
+ error "unknown scheme '$scheme' in '$url'"
+ }
+
+ regsub -- "^${scheme}:" $url {} url
+
+ set parts(scheme) [string tolower $scheme]
+ array set parts [Split[string totitle $scheme] $url]
+
+ # should decode all encoded characters!
+
+ return [array get parts]
+}
+
+proc ::uri::SplitFtp {url} {
+ # @c Splits the given ftp-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+ #
+ # additional rules:
+ #
+ # <user>:<password> are optional, detectable by presence of @.
+ # <password> is optional too.
+ #
+ # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+ # <cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]
+
+ upvar \#0 [namespace current]::ftp::typepart ftptype
+
+ array set parts {user {} pwd {} host {} port {} path {} type {}}
+
+ # slash off possible type specification
+
+ if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {
+
+ set from [lindex $ftype 0]
+ set to [lindex $ftype 1]
+
+ set parts(type) [string range $url $from $to]
+
+ set from [lindex $dummy 0]
+ set url [string replace $url $from end]
+ }
+
+ # Handle user, password, host and port
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ array set parts [GetUPHP url]
+ }
+
+ set parts(path) [string trimleft $url /]
+
+ return [array get parts]
+}
+
+proc ::uri::JoinFtp args {
+ array set components {
+ user {} pwd {} host {} port {}
+ path {} type {}
+ }
+ array set components $args
+
+ set userPwd {}
+ if {[string length $components(user)] || [string length $components(pwd)]} {
+ set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
+ }
+
+ set port {}
+ if {[string length $components(port)]} {
+ set port :$components(port)
+ }
+
+ set type {}
+ if {[string length $components(type)]} {
+ set type \;type=$components(type)
+ }
+
+ return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
+}
+
+proc ::uri::SplitHttps {url} {
+ return [SplitHttp $url]
+}
+
+proc ::uri::SplitHttp {url} {
+ # @c Splits the given http-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<host>:<port>/<path>?<searchpart>
+ #
+ # where <host> and <port> are as described in Section 3.1. If :<port>
+ # is omitted, the port defaults to 80. No user name or password is
+ # allowed. <path> is an HTTP selector, and <searchpart> is a query
+ # string. The <path> is optional, as is the <searchpart> and its
+ # preceding "?". If neither <path> nor <searchpart> is present, the "/"
+ # may also be omitted.
+ #
+ # Within the <path> and <searchpart> components, "/", ";", "?" are
+ # reserved. The "/" character may be used within HTTP to designate a
+ # hierarchical structure.
+ #
+ # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]
+
+ upvar #0 [namespace current]::http::search search
+ upvar #0 [namespace current]::http::segment segment
+
+ array set parts {host {} port {} path {} query {} fragment {}}
+
+ set searchPattern "\\?(${search})\$"
+ set fragmentPattern "#(${segment})\$"
+
+ # slash off possible fragment.
+
+ # NOTE: This must be done before the query, because a fragment can
+ # follow a query, and slashing off the query first will take the
+ # fragment with it. Bug #3235340.
+
+ if {[regexp -indices -- $fragmentPattern $url match fragment]} {
+ set from [lindex $fragment 0]
+ set to [lindex $fragment 1]
+
+ set parts(fragment) [string range $url $from $to]
+
+ set url [string replace $url [lindex $match 0] end]
+ }
+
+ # slash off possible query. the 'search' regexp, while official,
+ # is not good enough. We have apparently lots of urls in the wild
+ # which contain unquoted urls with queries in a query. The RE
+ # finds the embedded query, not the actual one. Using string first
+ # now instead of a RE
+
+ if {[set pos [string first ? $url]] >= 0} {
+ incr pos
+ set parts(query) [string range $url $pos end]
+ incr pos -1
+ set url [string replace $url $pos end]
+ }
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ array set parts [GetUPHP url]
+ }
+
+ set parts(path) [string trimleft $url /]
+
+ return [array get parts]
+}
+
+proc ::uri::JoinHttp {args} {
+ return [eval [linsert $args 0 ::uri::JoinHttpInner http 80]]
+}
+
+proc ::uri::JoinHttps {args} {
+ return [eval [linsert $args 0 ::uri::JoinHttpInner https 443]]
+}
+
+proc ::uri::JoinHttpInner {scheme defport args} {
+ array set components {host {} path {} query {} fragment {}}
+ set components(port) $defport
+ array set components $args
+
+ set port {}
+ if {[string length $components(port)] && $components(port) != $defport} {
+ set port :$components(port)
+ }
+
+ set query {}
+ if {[string length $components(query)]} {
+ set query ?$components(query)
+ }
+
+ regsub -- {^/} $components(path) {} components(path)
+
+ if { $components(fragment) != "" } {
+ set components(fragment) "#$components(fragment)"
+ } else {
+ set components(fragment) ""
+ }
+
+ return $scheme://$components(host)$port/$components(path)$query$components(fragment)
+}
+
+proc ::uri::SplitFile {url} {
+ # @c Splits the given file-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ upvar #0 [namespace current]::basic::hostname hostname
+ upvar #0 [namespace current]::basic::hostnumber hostnumber
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ set hostPattern "^($hostname|$hostnumber)"
+ switch -exact -- $::tcl_platform(platform) {
+ windows {
+ # Catch drive letter
+ append hostPattern :?
+ }
+ default {
+ # Proceed as usual
+ }
+ }
+
+ if {[regexp -indices -- $hostPattern $url match host]} {
+ set fh [lindex $host 0]
+ set th [lindex $host 1]
+
+ set parts(host) [string range $url $fh $th]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+ }
+
+ set parts(path) $url
+
+ return [array get parts]
+}
+
+proc ::uri::JoinFile args {
+ array set components {
+ host {} port {} path {}
+ }
+ array set components $args
+
+ switch -exact -- $::tcl_platform(platform) {
+ windows {
+ if {[string length $components(host)]} {
+ return file://$components(host):$components(path)
+ } else {
+ return file://$components(path)
+ }
+ }
+ default {
+ return file://$components(host)$components(path)
+ }
+ }
+}
+
+proc ::uri::SplitMailto {url} {
+ # @c Splits the given mailto-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ if {[string match "*@*" $url]} {
+ set url [::split $url @]
+ return [list user [lindex $url 0] host [lindex $url 1]]
+ } else {
+ return [list user $url]
+ }
+}
+
+proc ::uri::JoinMailto args {
+ array set components {
+ user {} host {}
+ }
+ array set components $args
+
+ return mailto:$components(user)@$components(host)
+}
+
+proc ::uri::SplitNews {url} {
+ if { [string first @ $url] >= 0 } {
+ return [list message-id $url]
+ } else {
+ return [list newsgroup-name $url]
+ }
+}
+
+proc ::uri::JoinNews args {
+ array set components {
+ message-id {} newsgroup-name {}
+ }
+ array set components $args
+ return news:$components(message-id)$components(newsgroup-name)
+}
+
+proc ::uri::SplitLdaps {url} {
+ ::uri::SplitLdap $url
+}
+
+proc ::uri::SplitLdap {url} {
+ # @c Splits the given Ldap-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
+ #
+ # where <host> and <port> are as described in Section 5 of RFC 1738.
+ # No user name or password is allowed.
+ # If omitted, the port defaults to 389 for ldap, 636 for ldaps
+ # <dn> is the base DN for the search
+ # <attrs> is a comma separated list of attributes description
+ # <scope> is either "base", "one" or "sub".
+ # <filter> is a RFC 2254 filter specification
+ # <extensions> are documented in RFC 2255
+ #
+
+ array set parts {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
+
+ # host port dn attrs scope filter extns
+ set re {//((?:[^:?/]+)|(?:\[[^\]]*\]))(?::([0-9]+))?(?:/([^?]+)(?:\?([^?]*)(?:\?(base|one|sub)?(?:\?([^?]*)(?:\?(.*))?)?)?)?)?}
+
+ if {! [regexp $re $url match parts(host) parts(port) \
+ parts(dn) parts(attrs) parts(scope) parts(filter) \
+ parts(extensions)]} then {
+ return -code error "unable to match URL \"$url\""
+ }
+
+ set parts(attrs) [::split $parts(attrs) ","]
+
+ return [array get parts]
+}
+
+proc ::uri::JoinLdap {args} {
+ return [eval [linsert $args 0 ::uri::JoinLdapInner ldap 389]]
+}
+
+proc ::uri::JoinLdaps {args} {
+ return [eval [linsert $args 0 ::uri::JoinLdapInner ldaps 636]]
+}
+
+proc ::uri::JoinLdapInner {scheme defport args} {
+ array set components {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
+ set components(port) $defport
+ array set components $args
+
+ set port {}
+ if {[string length $components(port)] && $components(port) != $defport} {
+ set port :$components(port)
+ }
+
+ set url "$scheme://$components(host)$port"
+
+ set components(attrs) [::join $components(attrs) ","]
+
+ set s ""
+ foreach c {dn attrs scope filter extensions} {
+ if {[string equal $c "dn"]} then {
+ append s "/"
+ } else {
+ append s "?"
+ }
+ if {! [string equal $components($c) ""]} then {
+ append url "${s}$components($c)"
+ set s ""
+ }
+ }
+
+ return $url
+}
+
+proc ::uri::GetUPHP {urlvar} {
+ # @c Parse user, password host and port out of the url stored in
+ # @c variable <a urlvar>.
+ # @d Side effect: The extracted information is removed from the given url.
+ # @r List containing the extracted information in a format suitable for
+ # @r 'array set'.
+ # @a urlvar: Name of the variable containing the url to parse.
+
+ upvar \#0 [namespace current]::basic::user user
+ upvar \#0 [namespace current]::basic::password password
+ upvar \#0 [namespace current]::basic::hostname hostname
+ upvar \#0 [namespace current]::basic::hostnumber hostnumber
+ upvar \#0 [namespace current]::basic::port port
+
+ upvar $urlvar url
+
+ array set parts {user {} pwd {} host {} port {}}
+
+ # syntax
+ # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+ # "//" already cut off by caller
+
+ set upPattern "^(${user})(:(${password}))?@"
+
+ if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
+ set fu [lindex $theUser 0]
+ set tu [lindex $theUser 1]
+
+ set fp [lindex $thePassword 0]
+ set tp [lindex $thePassword 1]
+
+ set parts(user) [string range $url $fu $tu]
+ set parts(pwd) [string range $url $fp $tp]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ set hpPattern "^($hostname|$hostnumber)(:($port))?"
+
+ if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
+ set fh [lindex $theHost 0]
+ set th [lindex $theHost 1]
+
+ set fp [lindex $thePort 0]
+ set tp [lindex $thePort 1]
+
+ set parts(host) [string range $url $fh $th]
+ set parts(port) [string range $url $fp $tp]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ return [array get parts]
+}
+
+proc ::uri::GetHostPort {urlvar} {
+ # @c Parse host and port out of the url stored in variable <a urlvar>.
+ # @d Side effect: The extracted information is removed from the given url.
+ # @r List containing the extracted information in a format suitable for
+ # @r 'array set'.
+ # @a urlvar: Name of the variable containing the url to parse.
+
+ upvar #0 [namespace current]::basic::hostname hostname
+ upvar #0 [namespace current]::basic::hostnumber hostnumber
+ upvar #0 [namespace current]::basic::port port
+
+ upvar $urlvar url
+
+ set pattern "^(${hostname}|${hostnumber})(:(${port}))?"
+
+ if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
+ set fromHost [lindex $host 0]
+ set toHost [lindex $host 1]
+
+ set fromPort [lindex $thePort 0]
+ set toPort [lindex $thePort 1]
+
+ set parts(host) [string range $url $fromHost $toHost]
+ set parts(port) [string range $url $fromPort $toPort]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ return [array get parts]
+}
+
+# ::uri::resolve --
+#
+# Resolve an arbitrary URL, given a base URL
+#
+# Arguments:
+# base base URL (absolute)
+# url arbitrary URL
+#
+# Results:
+# Returns a URL
+
+proc ::uri::resolve {base url} {
+ if {[string length $url]} {
+ if {[isrelative $url]} {
+ array set baseparts [split $base]
+
+ switch -- $baseparts(scheme) {
+ http -
+ https -
+ ftp -
+ file {
+ array set relparts [split $baseparts(scheme):$url]
+ if { [string match /* $url] } {
+ catch { set baseparts(path) $relparts(path) }
+ # RFC 3986 section 4.2 - no scheme, but authority (host), keep authority
+ catch {
+ if {$relparts(host) != ""} {
+ set baseparts(host) $relparts(host)
+ }
+ }
+ } elseif { [string match */ $baseparts(path)] } {
+ set baseparts(path) "$baseparts(path)$relparts(path)"
+ } else {
+ if { [string length $relparts(path)] > 0 } {
+ set path [lreplace [::split $baseparts(path) /] end end]
+ set baseparts(path) "[::join $path /]/$relparts(path)"
+ }
+ }
+ catch { set baseparts(query) $relparts(query) }
+ catch { set baseparts(fragment) $relparts(fragment) }
+ return [eval [linsert [array get baseparts] 0 join]]
+ }
+ default {
+ return -code error "unable to resolve relative URL \"$url\""
+ }
+ }
+ } else {
+ return $url
+ }
+ } else {
+ return $base
+ }
+}
+
+# ::uri::isrelative --
+#
+# Determines whether a URL is absolute or relative
+#
+# Arguments:
+# url URL to check
+#
+# Results:
+# Returns 1 if the URL is relative, 0 otherwise
+
+proc ::uri::isrelative url {
+ return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
+}
+
+# ::uri::geturl --
+#
+# Fetch the data from an arbitrary URL.
+#
+# This package provides a handler for the file:
+# scheme, since this conflicts with the file command.
+#
+# Arguments:
+# url address of data resource
+# args configuration options
+#
+# Results:
+# Depends on scheme
+
+proc ::uri::geturl {url args} {
+ array set urlparts [split $url]
+
+ switch -- $urlparts(scheme) {
+ file {
+ return [eval [linsert $args 0 file_geturl $url]]
+ }
+ default {
+ # Load a geturl package for the scheme first and only if
+ # that fails the scheme package itself. This prevents
+ # cyclic dependencies between packages.
+ if {[catch {package require $urlparts(scheme)::geturl}]} {
+ package require $urlparts(scheme)
+ }
+ return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]]
+ }
+ }
+}
+
+# ::uri::file_geturl --
+#
+# geturl implementation for file: scheme
+#
+# TODO:
+# This is an initial, basic implementation.
+# Eventually want to support all options for geturl.
+#
+# Arguments:
+# url URL to fetch
+# args configuration options
+#
+# Results:
+# Returns data from file
+
+proc ::uri::file_geturl {url args} {
+ variable file:counter
+
+ set var [namespace current]::file[incr file:counter]
+ upvar #0 $var state
+ array set state {data {}}
+
+ array set parts [split $url]
+
+ set ch [open $parts(path)]
+ # Could determine text/binary from file extension,
+ # except on Macintosh
+ # fconfigure $ch -translation binary
+ set state(data) [read $ch]
+ close $ch
+
+ return $var
+}
+
+# ::uri::join --
+#
+# Format a URL
+#
+# Arguments:
+# args components, key-value format
+#
+# Results:
+# A URL
+
+proc ::uri::join args {
+ array set components $args
+
+ return [eval [linsert $args 0 Join[string totitle $components(scheme)]]]
+}
+
+# ::uri::canonicalize --
+#
+# Canonicalize a URL
+#
+# Acknowledgements:
+# Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# Arguments:
+# uri URI (which contains a path component)
+#
+# Results:
+# The canonical form of the URI
+
+proc ::uri::canonicalize uri {
+
+ # Make uri canonical with respect to dots (path changing commands)
+ #
+ # Remove single dots (.) => pwd not changing
+ # Remove double dots (..) => gobble previous segment of path
+ #
+ # Fixes for this command:
+ #
+ # * Ignore any url which cannot be split into components by this
+ # module. Just assume that such urls do not have a path to
+ # canonicalize.
+ #
+ # * Ignore any url which could be split into components, but does
+ # not have a path component.
+ #
+ # In the text above 'ignore' means
+ # 'return the url unchanged to the caller'.
+
+ if {[catch {array set u [::uri::split $uri]}]} {
+ return $uri
+ }
+ if {![info exists u(path)]} {
+ return $uri
+ }
+
+ set uri $u(path)
+
+ # Remove leading "./" "../" "/.." (and "/../")
+ regsub -all -- {^(\./)+} $uri {} uri
+ regsub -all -- {^/(\.\./)+} $uri {/} uri
+ regsub -all -- {^(\.\./)+} $uri {} uri
+
+ # Remove inner /./ and /../
+ while {[regsub -all -- {/\./} $uri {/} uri]} {}
+ while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
+ while {[regsub -all -- {^[^/]+/\.\./} $uri {} uri]} {}
+ # Munge trailing /..
+ while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
+ if { $uri == ".." } { set uri "/" }
+
+ set u(path) $uri
+ set uri [eval [linsert [array get u] 0 ::uri::join]]
+
+ return $uri
+}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# regular expressions covering various url schemes
+
+# Currently known URL schemes:
+#
+# (RFC 1738)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# ftp //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+#
+# http //<host>:<port>/<path>?<searchpart>
+#
+# gopher //<host>:<port>/<gophertype><selector>
+# <gophertype><selector>%09<search>
+# <gophertype><selector>%09<search>%09<gopher+_string>
+#
+# mailto <rfc822-addr-spec>
+# news <newsgroup-name>
+# <message-id>
+# nntp //<host>:<port>/<newsgroup-name>/<article-number>
+# telnet //<user>:<password>@<host>:<port>/
+# wais //<host>:<port>/<database>
+# //<host>:<port>/<database>?<search>
+# //<host>:<port>/<database>/<wtype>/<wpath>
+# file //<host>/<path>
+# prospero //<host>:<port>/<hsoname>;<field>=<value>
+# ------------------------------------------------
+#
+# (RFC 2111)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# mid message-id
+# message-id/content-id
+# cid content-id
+# ------------------------------------------------
+#
+# (RFC 2255)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# ldap //<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
+# ------------------------------------------------
+
+# FTP
+uri::register ftp {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable login [set [namespace parent [namespace current]]::basic::login]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
+ variable char "(${charN}|${escape})"
+ variable segment "${char}*"
+ variable path "${segment}(/${segment})*"
+
+ variable type {[AaDdIi]}
+ variable typepart ";type=(${type})"
+ variable schemepart \
+ "//${login}(/${path}(${typepart})?)?"
+
+ variable url "ftp:${schemepart}"
+}
+
+# FILE
+uri::register file {
+ variable host [set [namespace parent [namespace current]]::basic::host]
+ variable path [set [namespace parent [namespace current]]::ftp::path]
+
+ variable schemepart "//(${host}|localhost)?/${path}"
+ variable url "file:${schemepart}"
+}
+
+# HTTP
+uri::register http {
+ variable escape \
+ [set [namespace parent [namespace current]]::basic::escape]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,);:@&=-]}
+ variable char "($charN|${escape})"
+ variable segment "${char}*"
+
+ variable path "${segment}(/${segment})*"
+ variable search $segment
+ variable schemepart \
+ "//${hostOrPort}(/${path}(\\?${search})?)?"
+
+ variable url "http:${schemepart}"
+}
+
+# GOPHER
+uri::register gopher {
+ variable xChar \
+ [set [namespace parent [namespace current]]::basic::xChar]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable search \
+ [set [namespace parent [namespace current]]::http::search]
+
+ variable type $xChar
+ variable selector "$xChar*"
+ variable string $selector
+ variable schemepart \
+ "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
+ variable url "gopher:${schemepart}"
+}
+
+# MAILTO
+uri::register mailto {
+ variable xChar [set [namespace parent [namespace current]]::basic::xChar]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+
+ variable schemepart "$xChar+(@${host})?"
+ variable url "mailto:${schemepart}"
+}
+
+# NEWS
+uri::register news {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable alpha [set [namespace parent [namespace current]]::basic::alpha]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+
+ variable aCharN {[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
+ variable aChar "($aCharN|${escape})"
+ variable gChar {[a-zA-Z0-9$_.+-]}
+ variable newsgroup-name "${alpha}${gChar}*"
+ variable message-id "${aChar}+@${host}"
+ variable schemepart "\\*|${newsgroup-name}|${message-id}"
+ variable url "news:${schemepart}"
+}
+
+# WAIS
+uri::register wais {
+ variable uChar \
+ [set [namespace parent [namespace current]]::basic::xChar]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable search \
+ [set [namespace parent [namespace current]]::http::search]
+
+ variable db "${uChar}*"
+ variable type "${uChar}*"
+ variable path "${uChar}*"
+
+ variable database "//${hostOrPort}/${db}"
+ variable index "//${hostOrPort}/${db}\\?${search}"
+ variable doc "//${hostOrPort}/${db}/${type}/${path}"
+
+ #variable schemepart "${doc}|${index}|${database}"
+
+ variable schemepart \
+ "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"
+
+ variable url "wais:${schemepart}"
+}
+
+# PROSPERO
+uri::register prospero {
+ variable escape \
+ [set [namespace parent [namespace current]]::basic::escape]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable path \
+ [set [namespace parent [namespace current]]::ftp::path]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&-]}
+ variable char "(${charN}|$escape)"
+
+ variable fieldname "${char}*"
+ variable fieldvalue "${char}*"
+ variable fieldspec ";${fieldname}=${fieldvalue}"
+
+ variable schemepart "//${hostOrPort}/${path}(${fieldspec})*"
+ variable url "prospero:$schemepart"
+}
+
+# LDAP
+uri::register ldap {
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ # very crude parsing
+ variable dn {[^?]*}
+ variable attrs {[^?]*}
+ variable scope "base|one|sub"
+ variable filter {[^?]*}
+ # extensions are not handled yet
+
+ variable schemepart "//${hostOrPort}(/${dn}(\?${attrs}(\?(${scope})(\?${filter})?)?)?)?"
+ variable url "ldap:$schemepart"
+}
+
+package provide uri 1.2.6
diff --git a/tcllib/modules/uri/uri.test b/tcllib/modules/uri/uri.test
new file mode 100644
index 0000000..b4cea77
--- /dev/null
+++ b/tcllib/modules/uri/uri.test
@@ -0,0 +1,526 @@
+# Tests for the uri module.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2000 by Zveno Pty Ltd.
+#
+# RCS: @(#) $Id: uri.test,v 1.25 2011/03/23 04:39:54 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal uri.tcl uri
+}
+
+# -------------------------------------------------------------------------
+# Split tests
+
+test uri-1.0 {uri::split - http w/- nested query} {
+ dictsort [uri::split http://test.net/path/path2?query=url?otherquery]
+} {fragment {} host test.net path path/path2 port {} pwd {} query query=url?otherquery scheme http user {}}
+
+test uri-1.1 {uri::split - http w/- query} {
+ dictsort [uri::split http://test.net/path/path2?query]
+} {fragment {} host test.net path path/path2 port {} pwd {} query query scheme http user {}}
+
+test uri-1.2 {uri::split - https w/- query} {
+ dictsort [uri::split https://test.net/path/path2?query]
+} {fragment {} host test.net path path/path2 port {} pwd {} query query scheme https user {}}
+
+test uri-1.3 {uri::split - http w/- port} {
+ dictsort [uri::split http://test.net:8080]
+} {fragment {} host test.net path {} port 8080 pwd {} query {} scheme http user {}}
+
+test uri-1.4 {uri::split - https w/- port} {
+ dictsort [uri::split https://test.net:8888]
+} {fragment {} host test.net path {} port 8888 pwd {} query {} scheme https user {}}
+
+test uri-1.5 {uri::split - ftp} {
+ dictsort [uri::split ftp://ftp.test.net/path/to/resource]
+} {host ftp.test.net path path/to/resource port {} pwd {} scheme ftp type {} user {}}
+
+test uri-1.6 {uri::split - ftp with userinfo} {
+ dictsort [uri::split {ftp://user:passwd@localhost/a/b/c.d}]
+} {host localhost path a/b/c.d port {} pwd passwd scheme ftp type {} user user}
+
+test uri-1.7 {uri::split - ftp with type} {
+ dictsort [uri::split {ftp://localhost/a/b/c.d;type=i}]
+} {host localhost path a/b/c.d port {} pwd {} scheme ftp type i user {}}
+
+test uri-1.8 {uri::split - ftp with port} {
+ dictsort [uri::split {ftp://localhost:21/a/b/c.d}]
+} {host localhost path a/b/c.d port 21 pwd {} scheme ftp type {} user {}}
+
+test uri-1.9 {uri::split - news with message-id} {
+ dictsort [uri::split {news:87lm40t3v7.fsf@dedasys.com}]
+} {message-id 87lm40t3v7.fsf@dedasys.com scheme news}
+
+test uri-1.10 {uri::split - news with newsgroup-name} {
+ dictsort [uri::split {news:comp.lang.tcl}]
+} {newsgroup-name comp.lang.tcl scheme news}
+
+test uri-1.11 {uri::split - ldap simple} {
+ dictsort [uri::split {ldap://ldaphost}]
+} {attrs {} dn {} extensions {} filter {} host ldaphost port {} scheme ldap scope {}}
+
+test uri-1.12 {uri::split - ldaps with port} {
+ dictsort [uri::split {ldaps://h:636/}]
+} {attrs {} dn {} extensions {} filter {} host h port 636 scheme ldaps scope {}}
+
+test uri-1.13 {uri::split - ldap search} {
+ dictsort [uri::split {ldap://ldaphost/o=mycomp?uid,mail?sub?(uid=pda)}]
+} {attrs {uid mail} dn o=mycomp extensions {} filter (uid=pda) host ldaphost port {} scheme ldap scope sub}
+
+test uri-1.14 {uri::split - ldap search with implicit scope an attributes} {
+ dictsort [uri::split {ldap://ldaphost:999/o=mycomp???(uid=pda)}]
+} {attrs {} dn o=mycomp extensions {} filter (uid=pda) host ldaphost port 999 scheme ldap scope {}}
+
+test uri-1.15 {uri::split - https with IPv6} {
+ dictsort [uri::split {https://[2001:db8::7]:8080?foo=bar}]
+} {fragment {} host {[2001:db8::7]} path {} port 8080 pwd {} query foo=bar scheme https user {}}
+
+test uri-1.16 {uri::split - ftp with auth and IPv6} {
+ dictsort [uri::split {ftp://user:pass@[2001:db8::7]/alt}]
+} {host {[2001:db8::7]} path alt port {} pwd pass scheme ftp type {} user user}
+
+test uri-1.17 {uri::split - ldaps IPv6 search with port} {
+ dictsort [uri::split {ldaps://[2001:db8::7]:987/o=mycomp?uid,mail?sub?(uid=pda)}]
+} {attrs {uid mail} dn o=mycomp extensions {} filter (uid=pda) host {[2001:db8::7]} port 987 scheme ldaps scope sub}
+
+# -------------------------------------------------------------------------
+
+test uri-2.1 {uri::join - http} {
+ uri::join scheme http path / host www.w3.org
+} http://www.w3.org/
+
+test uri-2.2 {uri::join - https} {
+ uri::join scheme https path / host www.w3.org
+} https://www.w3.org/
+
+test uri-2.3 {uri::join - http w/- query} {
+ uri::join scheme http query abc=def&ghi=jkl host www.test.net path /path/
+} http://www.test.net/path/?abc=def&ghi=jkl
+
+test uri-2.4 {uri::join - https w/- query} {
+ uri::join scheme https query abc=def&ghi=jkl host www.test.net path /path/
+} https://www.test.net/path/?abc=def&ghi=jkl
+
+test uri-2.5 {uri::join - http w/- port} {
+ uri::join scheme http port 8080 host www.test.net path /path/
+} http://www.test.net:8080/path/
+
+test uri-2.6 {uri::join - https w/- port} {
+ uri::join scheme https port 8888 host www.test.net path /path/
+} https://www.test.net:8888/path/
+
+test uri-2.7 {uri::join - ftp} {
+ uri::join host ftp.test.net path /my/file scheme ftp
+} ftp://ftp.test.net/my/file
+
+test uri-2.8 {uri::join - identity function} {
+ eval uri::join [uri::split http://www.w3.org/XML/?abc=def]
+} http://www.w3.org/XML/?abc=def
+
+test uri-2.9 {uri::join - ftp userinfo check} {
+ eval uri::join scheme ftp host localhost port 21 path /filename user user pwd passwd
+} {ftp://user:passwd@localhost:21/filename}
+
+test uri-2.10 {uri::join - ftp userinfo check with no passwd} {
+ eval uri::join scheme ftp host localhost path /filename user user
+} {ftp://user@localhost/filename}
+
+test uri-2.11 {uri::join - ftp path prefix} {
+ eval uri::join scheme ftp host localhost path a/b/c.d
+} ftp://localhost/a/b/c.d
+
+test uri-2.12 {uri::join - ftp w/- image type} {
+ eval uri::join scheme ftp host localhost path a/b/c.d type i
+} {ftp://localhost/a/b/c.d;type=i}
+
+test uri-2.13 {uri::join - ftp w/- ascii type} {
+ eval uri::join scheme ftp host localhost path a/b/c.d type a
+} {ftp://localhost/a/b/c.d;type=a}
+
+# I am not sure that this shouldn't produce an error. The semi-colon is
+# reserved so in this case with an invalid suffix the semi-colon should
+# probably be quoted. [PT]
+test uri-2.14 {uri::join - ftp w/- invalid type} {
+ eval uri::join scheme ftp host localhost path a/b/c.d type X
+} {ftp://localhost/a/b/c.d;type=X}
+
+test uri-2.15 {uri::join - news message-id} {
+ eval uri::join scheme news message-id 87lm40t3v7.fsf@dedasys.com
+} {news:87lm40t3v7.fsf@dedasys.com}
+
+test uri-2.16 {uri::join - news newsgroup-name} {
+ eval uri::join scheme news newsgroup-name comp.lang.tcl
+} {news:comp.lang.tcl}
+
+test uri-2.17 {uri::join - ldap simple} {
+ uri::join scheme ldap host ldaphost
+} {ldap://ldaphost}
+
+test uri-2.18 {uri::join - ldaps with default port} {
+ uri::join scheme ldaps host ldaphost port 636
+} {ldaps://ldaphost}
+
+test uri-2.19 {uri::join - ldaps with port} {
+ uri::join scheme ldaps host ldaphost port 999
+} {ldaps://ldaphost:999}
+
+test uri-2.20 {uri::join - ldap search} {
+ # I should use "attrs {uid mail}" and not "attrs uid,mail"
+ # but this is a perverse effect of the "eval" command
+ uri::join attrs uid,mail dn o=mycomp filter (uid=pda) host ldaphost scheme ldap scope sub
+} {ldap://ldaphost/o=mycomp?uid,mail?sub?(uid=pda)}
+
+test uri-2.21 {uri::join - ldap search with implicit scope an attributes} {
+ uri::join dn o=mycomp filter (uid=pda) host ldaphost port 999 scheme ldap
+} {ldap://ldaphost:999/o=mycomp???(uid=pda)}
+
+
+# -------------------------------------------------------------------------
+
+test uri-3.1 {uri::resolve - relative URL, base trailing slash} {
+ uri::resolve http://www.w3.org/path/ test.html
+} http://www.w3.org/path/test.html
+
+test uri-3.2 {uri::resolve - relative URL path, base trailing slash} {
+ uri::resolve http://www.w3.org/path/ relpath/test.html
+} http://www.w3.org/path/relpath/test.html
+
+test uri-3.3 {uri::resolve - relative URL, base no trailing slash} {
+ uri::resolve http://www.w3.org/path test.html
+} http://www.w3.org/test.html
+
+test uri-3.4 {uri::resolve - relative URL path, base no trailing slash} {
+ uri::resolve http://www.w3.org/path relpath/test.html
+} http://www.w3.org/relpath/test.html
+
+test uri-3.5 {uri::resolve - relative URL w/- query} {
+ uri::resolve http://www.w3.org/path/ test.html?abc=def
+} http://www.w3.org/path/test.html?abc=def
+
+test uri-3.6 {uri::resolve - absolute URL} {
+ uri::resolve http://www.w3.org/path/ http://test.net/test.html
+} http://test.net/test.html
+
+test uri-3.7 {uri::resolve - two queries - one sans path} {
+ uri::resolve http://www.example.com/foo/bar.rvt?foo=bar ?shoo=bee
+} http://www.example.com/foo/bar.rvt?shoo=bee
+
+test uri-3.8 {uri::resolve - two queries} {
+ uri::resolve http://www.example.com/baz/?foo=bar ?shoo=bee
+} http://www.example.com/baz/?shoo=bee
+
+test uri-3.9 {uri::resolve - two absolute URL's with queries} {
+ uri::resolve http://www.example.com/?foo=bar http://www.example.com/?shoo=bee
+} http://www.example.com/?shoo=bee
+
+test uri-3.10 {uri::resolve - two queries,
+ one absolute URL, one absolute path} {
+ uri::resolve http://www.example.com/baz?foo=bar /baz?shoo=bee
+} http://www.example.com/baz?shoo=bee
+
+
+test uri-3.11 {uri::resolve - scheme-relative url with authority, rfc3986 4.2} {
+ uri::resolve http://www.foo.com/ //www.bar.com/
+} http://www.bar.com/
+
+test uri-3.12 {uri::resolve - scheme-relative url with authority, rfc3986 4.2} {
+ uri::resolve https://www.foo.com/ //www.bar.com/
+} https://www.bar.com/
+
+test uri-3.13 {uri::resolve - scheme-relative url with authority, rfc3986 4.2} {
+ uri::resolve https://www.foo.com/ //www.bar.com
+} https://www.bar.com/
+
+
+# -------------------------------------------------------------------------
+
+test uri-4.1 {uri::geturl} {
+ set data [info commands]
+ set file [makeFile {} __testdata]
+ set f [open $file w]
+ puts -nonewline $f $data
+ close $f
+
+ set token [uri::geturl file://$file]
+ removeFile __testdata
+ string compare $data [set [subst $token](data)]
+} 0
+
+# -------------------------------------------------------------------------
+
+test uri-5.1-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/path1/./remove/../path2/resource
+} http://www.test.net/path1/path2/resource
+
+test uri-5.2-0 {uri::canonicalize infinite loop} {
+ uri::canonicalize http://www.test.net/../path2/resource
+} {http://www.test.net/path2/resource}
+
+test uri-5.3-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/./path1/./remove/../path2/../resource
+} http://www.test.net/path1/resource
+
+test uri-5.4-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/./././path1/./remove/../path2/../resource
+} http://www.test.net/path1/resource
+
+test uri-5.5-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/./././path1/./remove/path2/../../resource
+} http://www.test.net/path1/resource
+
+test uri-5.6-0 {uri::canonicalize infinite loop} {
+ uri::canonicalize http://www.test.net/../../../path2/resource
+} {http://www.test.net/path2/resource}
+
+test uri-5.7-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/path1/./remove/../path.html/resource
+} http://www.test.net/path1/path.html/resource
+
+test uri-5.8-0 {uri::canonicalize infinite loop} {
+ uri::canonicalize http://www.test.net/../path.html/resource
+} {http://www.test.net/path.html/resource}
+
+test uri-5.9-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/./path1/./remove/../path.html/../resource
+} http://www.test.net/path1/resource
+
+test uri-5.10-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/./././path1/./remove/../path.html/../resource
+} http://www.test.net/path1/resource
+
+test uri-5.11-0 {uri::canonicalize} {
+ uri::canonicalize http://www.test.net/./././path1/./remove/path.html/../../resource
+} http://www.test.net/path1/resource
+
+test uri-5.12-0 {uri::canonicalize infinite loop} {
+ uri::canonicalize http://www.test.net/../../../path.html/resource
+} {http://www.test.net/path.html/resource}
+
+test uri-5.13-0 {uri::canonicalize} {
+ uri::canonicalize http://www.eldritchpress.org/jc/../help.html
+} {http://www.eldritchpress.org/help.html}
+
+test uri-5.14-0 {uri::canonicalize trailing ..} {
+ uri::canonicalize http://www.example.com/foo/bar/..
+} {http://www.example.com/foo/}
+
+test uri-5.15-0 {uri::canonicalize trailing ..} {
+ uri::canonicalize http://www.example.com/..
+} {http://www.example.com/}
+
+test uri-5.1-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/path1/./remove/../path2/resource
+} ftp://ftp.test.net/path1/path2/resource
+
+test uri-5.2-1 {uri::canonicalize infinite loop} {
+ uri::canonicalize ftp://ftp.test.net/../path2/resource
+} {ftp://ftp.test.net/path2/resource}
+
+test uri-5.3-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/./path1/./remove/../path2/../resource
+} ftp://ftp.test.net/path1/resource
+
+test uri-5.4-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/./././path1/./remove/../path2/../resource
+} ftp://ftp.test.net/path1/resource
+
+test uri-5.5-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/./././path1/./remove/path2/../../resource
+} ftp://ftp.test.net/path1/resource
+
+test uri-5.6-1 {uri::canonicalize infinite loop} {
+ uri::canonicalize ftp://ftp.test.net/../../../path2/resource
+} {ftp://ftp.test.net/path2/resource}
+
+test uri-5.7-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/path1/./remove/../path.html/resource
+} ftp://ftp.test.net/path1/path.html/resource
+
+test uri-5.8-1 {uri::canonicalize infinite loop} {
+ uri::canonicalize ftp://ftp.test.net/../path.html/resource
+} {ftp://ftp.test.net/path.html/resource}
+
+test uri-5.9-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/./path1/./remove/../path.html/../resource
+} ftp://ftp.test.net/path1/resource
+
+test uri-5.10-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/./././path1/./remove/../path.html/../resource
+} ftp://ftp.test.net/path1/resource
+
+test uri-5.11-1 {uri::canonicalize} {
+ uri::canonicalize ftp://ftp.test.net/./././path1/./remove/path.html/../../resource
+} ftp://ftp.test.net/path1/resource
+
+test uri-5.12-1 {uri::canonicalize infinite loop} {
+ uri::canonicalize ftp://ftp.test.net/../../../path.html/resource
+} {ftp://ftp.test.net/path.html/resource}
+
+test uri-5.1-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/path1/./remove/../path2/resource
+} file://goo.test.net/path1/path2/resource
+
+test uri-5.2-2 {uri::canonicalize infinite loop} {
+ uri::canonicalize file://goo.test.net/../path2/resource
+} {file://goo.test.net/path2/resource}
+
+test uri-5.3-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/./path1/./remove/../path2/../resource
+} file://goo.test.net/path1/resource
+
+test uri-5.4-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/./././path1/./remove/../path2/../resource
+} file://goo.test.net/path1/resource
+
+test uri-5.5-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/./././path1/./remove/path2/../../resource
+} file://goo.test.net/path1/resource
+
+test uri-5.6-2 {uri::canonicalize infinite loop} {
+ uri::canonicalize file://goo.test.net/../../../path2/resource
+} {file://goo.test.net/path2/resource}
+
+test uri-5.7-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/path1/./remove/../path.html/resource
+} file://goo.test.net/path1/path.html/resource
+
+test uri-5.8-2 {uri::canonicalize infinite loop} {
+ uri::canonicalize file://goo.test.net/../path.html/resource
+} {file://goo.test.net/path.html/resource}
+
+test uri-5.9-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/./path1/./remove/../path.html/../resource
+} file://goo.test.net/path1/resource
+
+test uri-5.10-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/./././path1/./remove/../path.html/../resource
+} file://goo.test.net/path1/resource
+
+test uri-5.11-2 {uri::canonicalize} {
+ uri::canonicalize file://goo.test.net/./././path1/./remove/path.html/../../resource
+} file://goo.test.net/path1/resource
+
+test uri-5.12-2 {uri::canonicalize infinite loop} {
+ uri::canonicalize file://goo.test.net/../../../path.html/resource
+} {file://goo.test.net/path.html/resource}
+
+test uri-5.1-3 {uri::canonicalize} {
+ uri::canonicalize file:///path1/./remove/../path2/resource
+} file:///path1/path2/resource
+
+test uri-5.2-3 {uri::canonicalize infinite loop} {
+ uri::canonicalize file:///../path2/resource
+} {file:///path2/resource}
+
+test uri-5.3-3 {uri::canonicalize} {
+ uri::canonicalize file:///./path1/./remove/../path2/../resource
+} file:///path1/resource
+
+test uri-5.4-3 {uri::canonicalize} {
+ uri::canonicalize file:///./././path1/./remove/../path2/../resource
+} file:///path1/resource
+
+test uri-5.5-3 {uri::canonicalize} {
+ uri::canonicalize file:///./././path1/./remove/path2/../../resource
+} file:///path1/resource
+
+test uri-5.6-3 {uri::canonicalize infinite loop} {
+ uri::canonicalize file:///../../../path2/resource
+} {file:///path2/resource}
+
+test uri-5.7-3 {uri::canonicalize} {
+ uri::canonicalize file:///path1/./remove/../path.html/resource
+} file:///path1/path.html/resource
+
+test uri-5.8-3 {uri::canonicalize infinite loop} {
+ uri::canonicalize file:///../path.html/resource
+} {file:///path.html/resource}
+
+test uri-5.9-3 {uri::canonicalize} {
+ uri::canonicalize file:///./path1/./remove/../path.html/../resource
+} file:///path1/resource
+
+test uri-5.10-3 {uri::canonicalize} {
+ uri::canonicalize file:///./././path1/./remove/../path.html/../resource
+} file:///path1/resource
+
+test uri-5.11-3 {uri::canonicalize} {
+ uri::canonicalize file:///./././path1/./remove/path.html/../../resource
+} file:///path1/resource
+
+test uri-5.12-3 {uri::canonicalize infinite loop} {
+ uri::canonicalize file:///../../../path.html/resource
+} {file:///path.html/resource}
+
+test uri-6.0 {uri::canonicalize} {
+ uri::canonicalize telnet://goo.test.net/
+} telnet://goo.test.net/
+
+test uri-7.0 {uri::split & uri::join} {
+ set ls [uri::split http://tcl.apache.org/websh/faq.ws3\#generic?foo=bar]
+ eval uri::join $ls
+} {http://tcl.apache.org/websh/faq.ws3#generic?foo=bar}
+
+# -------------------------------------------------------------------------
+
+test uri-8.0 {uri::split bug #676976, ill. char in scheme} {
+ set ls [uri::split ht,tp://tcl.apache.org/websh]
+ eval uri::join $ls
+} {http://ht/,tp://tcl.apache.org/websh}
+
+# -------------------------------------------------------------------------
+
+test uri-9.0 {uri::split bug #936064, user information} {
+ dictsort [uri::split http://foo:bar@baz.com:80/bla/]
+} {fragment {} host baz.com path bla/ port 80 pwd bar query {} scheme http user foo}
+
+# -------------------------------------------------------------------------
+
+test uri-10.0 {uri::split bug #3235340, fragments after queries} {
+ dictsort [uri::split http://baz.com/foo?bar=baz#quux]
+} {fragment quux host baz.com path foo port {} pwd {} query bar=baz scheme http user {}}
+
+test uri-10.1 {uri::join bug #3235340, fragments after queries} {
+ uri::join fragment quux host baz.com path foo port {} pwd {} query bar=baz scheme http user {}
+} {http://baz.com/foo?bar=baz#quux}
+
+# -------------------------------------------------------------------------
+
+test uri-11.0 {uri::split, case-insensitive schemata, ticket dc50cc65ea} {
+ dictsort [uri::split hTTp://foo:bar@baz.com:80/bla/]
+} {fragment {} host baz.com path bla/ port 80 pwd bar query {} scheme http user foo}
+
+# -------------------------------------------------------------------------
+
+test uri-12.0 {uri::split, host-only without scheme, ticket cfb76ff494} {
+ dictsort [uri::split www.test.de]
+} {fragment {} host www.test.de path {} port {} pwd {} query {} scheme http user {}}
+
+test uri-12.1 {uri::split, host-only without scheme, ticket cfb76ff494} {
+ dictsort [uri::split http://www.test.de]
+} {fragment {} host www.test.de path {} port {} pwd {} query {} scheme http user {}}
+
+# -------------------------------------------------------------------------
+
+
+testsuiteCleanup
+return
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/uri/uri_urn.pcx b/tcllib/modules/uri/uri_urn.pcx
new file mode 100644
index 0000000..b7422f3
--- /dev/null
+++ b/tcllib/modules/uri/uri_urn.pcx
@@ -0,0 +1,27 @@
+# -*- tcl -*- uri_urn.pcx
+# Syntax of the commands provided by package uri::urn.
+#
+# For use by TclDevKit's static syntax checker (v4.1+).
+# See http://www.activestate.com/solutions/tcl/
+# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
+# for the specification of the format of the code in this file.
+#
+
+package require pcx
+pcx::register uri::urn
+pcx::tcldep 1.0 needs tcl 8.4
+
+namespace eval ::uri {}
+namespace eval ::uri::urn {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::uri::urn::quote \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::uri::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/uri/urn-scheme.man b/tcllib/modules/uri/urn-scheme.man
new file mode 100644
index 0000000..5487f76
--- /dev/null
+++ b/tcllib/modules/uri/urn-scheme.man
@@ -0,0 +1,41 @@
+[vset VERSION 1.0.3]
+[manpage_begin uri_urn n [vset VERSION]]
+[keywords {rfc 2141}]
+[keywords uri]
+[keywords url]
+[keywords urn]
+[moddesc {Tcl Uniform Resource Identifier Management}]
+[titledesc {URI utilities, URN scheme}]
+[category Networking]
+[require Tcl 8.2]
+[require uri::urn [opt [vset VERSION]]]
+[description]
+
+This package provides two commands to quote and unquote the disallowed
+characters for url using the [term urn] scheme, registers the scheme
+with the package [package uri], and provides internal helpers which
+will be automatically used by the commands [cmd uri::split] and
+[cmd uri::join] of package [package uri] to handle urls using the
+[term urn] scheme.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd uri::urn::quote] [arg url]]
+
+This command quotes the characters disallowed by the [term urn] scheme
+(per RFC 2141 sec2.2) in the [arg url] and returns the modified url as
+its result.
+
+[call [cmd uri::urn::unquote] [arg url]]
+
+This commands performs the reverse of [cmd ::uri::urn::quote]. It
+takes an [term urn] url, removes the quoting from all disallowed
+characters, and returns the modified urls as its result.
+
+[list_end]
+
+[vset CATEGORY uri]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/uri/urn-scheme.tcl b/tcllib/modules/uri/urn-scheme.tcl
new file mode 100644
index 0000000..2ebcf43
--- /dev/null
+++ b/tcllib/modules/uri/urn-scheme.tcl
@@ -0,0 +1,143 @@
+# 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 eval ::uri {}
+namespace eval ::uri::urn {}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Called by uri::split with a url to split into its parts.
+#
+proc ::uri::SplitUrn {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"
+ }
+}
+
+
+# -------------------------------------------------------------------------
+
+proc ::uri::JoinUrn args {
+ #@c Join the parts of a URN scheme URI
+ #@a list of nid value nss value
+ #@r a valid string representation for your URI
+ variable urn::NIDpart
+
+ array set parts [list nid {} nss {}]
+ array set parts $args
+ if {! [regexp -- ^$NIDpart$ $parts(nid)]} {
+ error "invalid urn: nid is invalid"
+ }
+ set url "urn:$parts(nid):[urn::quote $parts(nss)]"
+ return $url
+}
+
+# -------------------------------------------------------------------------
+
+# Quote the disallowed characters according to the RFC for URN scheme.
+# ref: RFC2141 sec2.2
+proc ::uri::urn::quote {url} {
+ variable trans
+
+ set ndx 0
+ set result ""
+ while {[regexp -indices -- "\[^$trans\]" $url r]} {
+ set ndx [lindex $r 0]
+
+ set ch [string index $url $ndx]
+ if {$ch eq "\0"} {
+ error "invalid character: character $chr is not allowed"
+ }
+
+ # Decode into UTF-8 bytes.
+ set rep {}
+ foreach ch [split [encoding convertto utf-8 $ch] {}] {
+ scan $ch %c chr
+ append rep %[format %.2X $chr]
+ }
+
+ incr ndx -1
+ append result [string range $url 0 $ndx] $rep
+ incr ndx 2
+ set 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.
+
+ proc ::uri::urn::unquote {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]
+ # Recode the array of utf-8 bytes to the proper internal rep.
+ return [encoding convertfrom utf-8 $result]
+ }
+} else {
+ proc ::uri::urn::unquote {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]
+ # Recode the array of utf-8 bytes to the proper internal rep.
+ return [encoding convertfrom utf-8 $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 1.0.3
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/uri/urn.test b/tcllib/modules/uri/urn.test
new file mode 100644
index 0000000..4308aa9
--- /dev/null
+++ b/tcllib/modules/uri/urn.test
@@ -0,0 +1,175 @@
+# urn.test - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
+#
+# Provide a set of tests to excercise the urn-scheme package.
+#
+# @(#)$Id: urn.test,v 1.9 2006/10/09 21:41:42 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useLocal uri.tcl uri
+}
+testing {
+ useLocal urn-scheme.tcl uri::urn
+}
+
+# -------------------------------------------------------------------------
+# Tests to check for valid urn sections.
+
+test urn-1.1 {Check basic split} {
+ catch {uri::split urn:tcl:test} result
+ dictsort $result
+} {nid tcl nss test scheme urn}
+
+test urn-1.2 {Check basic join} {
+ catch {uri::join scheme urn nid tcl nss test} result
+ set result
+} {urn:tcl:test}
+
+test urn-1.3 {Split permissible NID} {
+ catch {uri::split urn:tcl-TCL-0123456789:test} result
+ dictsort $result
+} {nid tcl-TCL-0123456789 nss test scheme urn}
+
+test urn-1.4 {Join permissible NID} {
+ catch {uri::join scheme urn nid tcl-TCL-0123456789 nss test} result
+ set result
+} {urn:tcl-TCL-0123456789:test}
+
+test urn-1.5 {Split permissible NSS} {
+ catch {uri::split {urn:tcl:Test-0123456789()+,-.:=@;$_!*'}} result
+ dictsort $result
+} {nid tcl nss {Test-0123456789()+,-.:=@;$_!*'} scheme urn}
+
+test urn-1.6 {Join permissible NSS} {
+ catch {uri::join scheme urn nid tcl nss {Test-0123456789()+,-.:=@;$_!*'}} result
+ set result
+} {urn:tcl:Test-0123456789()+,-.:=@;$_!*'}
+
+# -------------------------------------------------------------------------
+# Now some tests that should fail.
+
+test urn-2.1 {NID too long} {
+ set nid ThisURNNIDparthastoomanycharacters
+ set nss test
+ if {[catch {uri:split urn:$nid:$nss} result]} {
+ set result ok
+ }
+ set result
+} {ok}
+
+test urn-2.2 {NID too long} {
+ set nid ThisURNNIDparthastoomanycharacters
+ set nss test
+ if {[catch {uri:join scheme urn nid $nid nss $nss} result]} {
+ set result ok
+ }
+ set result
+} {ok}
+
+test urn-2.3 {NID containing invalid characters} {
+ set nid {This-NID//notOK}
+ set nss test
+ if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
+ set result ok
+ }
+ set result
+} {ok}
+
+test urn-2.4 {NID containing no characters} {
+ set nid {}
+ set nss test
+ if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
+ set result ok
+ }
+ set result
+} {ok}
+
+test urn-2.5 {NID beginning with hyphen} {
+ set nid {-notvalid}
+ set nss test
+ if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
+ set result ok
+ }
+ set result
+} {ok}
+
+
+# Check the Namespace Specific String.
+
+test urn-3.1 {NSS containing reserved characters} {
+ set nid {tcl}
+ set nss {%}
+ catch {uri::join scheme urn nid $nid nss $nss} result
+ set result
+} {urn:tcl:%25}
+
+test urn-3.2 {NSS containing reserved characters} {
+ set nid {tcl}
+ set nss {/?#}
+ catch {uri::join scheme urn nid $nid nss $nss} result
+ set result
+} {urn:tcl:%2F%3F%23}
+
+test urn-3.3 {NSS containing reserved characters} {
+ set nid {tcl}
+ set nss {urn-test}
+ catch {uri::join scheme urn nid $nid nss $nss} result
+ set result
+} {urn:tcl:urn-test}
+
+test urn-3.4 {NSS containing illegal characters} {
+ set nid {tcl}
+ set nss "\u00" ;# 0 is the only character explicitly denied.
+ if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
+ set result ok
+ }
+ set result
+} {ok}
+
+# -------------------------------------------------------------------------
+# Quoting checks - various UTF-8 representations for 'coffee' (RFC 2324, section 3)
+
+catch { unset data }
+lappend data "coffee" "coffee"
+lappend data "\x4B\x61\x66\x66\x65\x65" "Kaffee"
+lappend data "q\u00e6hv\u00e6" "q%C3%A6hv%C3%A6" ;# aserbaidjani
+lappend data "\u0642\u0647\u0648\u0629" "%D9%82%D9%87%D9%88%D8%A9" ;# arabic
+lappend data "\u03ba\u03b1\u03c6\u03ad" "%CE%BA%CE%B1%CF%86%CE%AD" ;# greek
+lappend data "\u0915\u094c\u092b\u0940" "%E0%A4%95%E0%A5%8C%E0%A4%AB%E0%A5%80" ;# hindi
+
+# Ticket [daa83d2edf].
+lappend data "\u4f60\u597d" "%E4%BD%A0%E5%A5%BD" ;# chinese 'How are you?'
+
+set n 0
+foreach {utf8 quoted} $data {
+ test urn-4.[incr n] [list quote utf8 string] {
+ list [catch {uri::urn::quote $utf8} msg] $msg
+ } [list 0 $quoted]
+}
+
+set n 0
+foreach {utf8 quoted} $data {
+ test urn-5.[incr n] [list unquote utf8 string] {
+ list [catch {uri::urn::unquote $quoted} msg] $msg
+ } [list 0 $utf8]
+}
+
+# -------------------------------------------------------------------------
+# Clean up the tests
+
+unset data
+testsuiteCleanup
+return
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
generated by cgit v0.12 at 2025-03-31 06:09:11 (GMT)