Check-in [85e715fbdd]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:add selected tcllib upstream changes
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 85e715fbdd64a50f41a29d5f99ece0acac8629d0
User & Date: chw 2017-01-07 01:51:28
Context
2017-01-07
02:12
improve startup regarding wayland video driver availability check-in: 9a8b462b73 user: chw tags: trunk
01:51
add selected tcllib upstream changes check-in: 85e715fbdd user: chw tags: trunk
2017-01-06
11:50
add tcl upstream changes check-in: c49bc80a32 user: chw tags: trunk
Changes

Changes to assets/tcllib1.18/pt/pkgIndex.tcl.

49
50
51
52
53
54
55


56
57
58
59
60
61
62
63
64

65
66
67
# Import core functionality: Conversion from a specific format to PEG.
package ifneeded pt::peg::from::json      1 [list source [file join $dir pt_peg_from_json.tcl]]
package ifneeded pt::peg::from::peg   1.0.3 [list source [file join $dir pt_peg_from_peg.tcl]]

# PARAM runtime.
package ifneeded pt::rde      1.1 [list source [file join $dir pt_rdengine.tcl]]
package ifneeded pt::rde::oo  1.1 [list source [file join $dir pt_rdengine_oo.tcl]]



# PEG grammar specification, as CONTAINER
package ifneeded pt::peg::container::peg 1 [list source [file join $dir pt_peg_container_peg.tcl]]

# */PARAM support (canned configurations).
package ifneeded pt::cparam::configuration::critcl  1.0.2 [list source [file join $dir pt_cparam_config_critcl.tcl]]
package ifneeded pt::cparam::configuration::tea     0.1   [list source [file join $dir pt_cparam_config_tea.tcl]]
package ifneeded pt::tclparam::configuration::snit  1.0.2 [list source [file join $dir pt_tclparam_config_snit.tcl]]
package ifneeded pt::tclparam::configuration::tcloo 1.0.4 [list source [file join $dir pt_tclparam_config_tcloo.tcl]]


# Parser generator core.
package ifneeded pt::pgen 1.0.3 [list source [file join $dir pt_pgen.tcl]]







>
>









>



49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Import core functionality: Conversion from a specific format to PEG.
package ifneeded pt::peg::from::json      1 [list source [file join $dir pt_peg_from_json.tcl]]
package ifneeded pt::peg::from::peg   1.0.3 [list source [file join $dir pt_peg_from_peg.tcl]]

# PARAM runtime.
package ifneeded pt::rde      1.1 [list source [file join $dir pt_rdengine.tcl]]
package ifneeded pt::rde::oo  1.1 [list source [file join $dir pt_rdengine_oo.tcl]]
package ifneeded pt::rde::nx  1.1 [list source [file join $dir pt_rdengine_nx.tcl]]


# PEG grammar specification, as CONTAINER
package ifneeded pt::peg::container::peg 1 [list source [file join $dir pt_peg_container_peg.tcl]]

# */PARAM support (canned configurations).
package ifneeded pt::cparam::configuration::critcl  1.0.2 [list source [file join $dir pt_cparam_config_critcl.tcl]]
package ifneeded pt::cparam::configuration::tea     0.1   [list source [file join $dir pt_cparam_config_tea.tcl]]
package ifneeded pt::tclparam::configuration::snit  1.0.2 [list source [file join $dir pt_tclparam_config_snit.tcl]]
package ifneeded pt::tclparam::configuration::tcloo 1.0.4 [list source [file join $dir pt_tclparam_config_tcloo.tcl]]
package ifneeded pt::tclparam::configuration::nx    1.0.0 [list source [file join $dir pt_tclparam_config_nx.tcl]]

# Parser generator core.
package ifneeded pt::pgen 1.0.3 [list source [file join $dir pt_pgen.tcl]]

Changes to assets/tcllib1.18/pt/pt_pgen.tcl.

21
22
23
24
25
26
27

28
29
30
31
32
33
34
..
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
100
101
102
103
104
105
106












107
108
109
110
111
112
113
package require pt::peg::to::param     ; # PARAM assembly, raw
package require pt::peg::to::tclparam  ; # PARAM assembly, embedded into Tcl
package require pt::peg::to::cparam    ; # PARAM assembly, embedded into C
package require pt::tclparam::configuration::snit  1.0.2 ; # PARAM/Tcl, snit::type
package require pt::tclparam::configuration::tcloo 1.0.4 ; # PARAM/Tcl, TclOO class
package require pt::cparam::configuration::critcl  1.0.2 ; # PARAM/C, in critcl
package require pt::cparam::configuration::tea   ; # PARAM/C, in TEA


# ### ### ### ######### ######### #########
## Implementation

namespace eval ::pt::pgen {
    namespace export json peg serial
    namespace ensemble create
................................................................................
    return [Write {*}$args [pt::peg::from::peg convert $input]]
}

# # ## ### ##### ######## #############
## Internals - Generating the parser.

namespace eval ::pt::pgen::Write {
    namespace export json peg container param snit oo critcl c tea
    namespace ensemble create
}

proc ::pt::pgen::Write::json {args} {
    # args = (option value)... grammar
    pt::peg::to::json configure {*}[lrange $args 0 end-1]
    return [pt::peg::to::json convert [lindex $args end]]
................................................................................
    # args = (option value)... grammar
    pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
    ClassPackageDefaults

    pt::tclparam::configuration::tcloo def \
	$class $package $version \
	{pt::peg::to::tclparam configure}













    return [pt::peg::to::tclparam convert [lindex $args end]]
}

proc ::pt::pgen::Write::tea {args} {
    # args = (option value)... grammar
    # Class   -> touches/defines variable 'class'







>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
package require pt::peg::to::param     ; # PARAM assembly, raw
package require pt::peg::to::tclparam  ; # PARAM assembly, embedded into Tcl
package require pt::peg::to::cparam    ; # PARAM assembly, embedded into C
package require pt::tclparam::configuration::snit  1.0.2 ; # PARAM/Tcl, snit::type
package require pt::tclparam::configuration::tcloo 1.0.4 ; # PARAM/Tcl, TclOO class
package require pt::cparam::configuration::critcl  1.0.2 ; # PARAM/C, in critcl
package require pt::cparam::configuration::tea   ; # PARAM/C, in TEA
package require pt::tclparam::configuration::nx 1.0.0 ; # PARAM/Tcl, NX class

# ### ### ### ######### ######### #########
## Implementation

namespace eval ::pt::pgen {
    namespace export json peg serial
    namespace ensemble create
................................................................................
    return [Write {*}$args [pt::peg::from::peg convert $input]]
}

# # ## ### ##### ######## #############
## Internals - Generating the parser.

namespace eval ::pt::pgen::Write {
    namespace export json peg container param snit oo critcl c tea nx
    namespace ensemble create
}

proc ::pt::pgen::Write::json {args} {
    # args = (option value)... grammar
    pt::peg::to::json configure {*}[lrange $args 0 end-1]
    return [pt::peg::to::json convert [lindex $args end]]
................................................................................
    # args = (option value)... grammar
    pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
    ClassPackageDefaults

    pt::tclparam::configuration::tcloo def \
	$class $package $version \
	{pt::peg::to::tclparam configure}

    return [pt::peg::to::tclparam convert [lindex $args end]]
}

proc ::pt::pgen::Write::nx {args} {
    # args = (option value)... grammar
    pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
    ClassPackageDefaults

    pt::tclparam::configuration::nx def \
	$class $package $version \
	{pt::peg::to::tclparam configure}

    return [pt::peg::to::tclparam convert [lindex $args end]]
}

proc ::pt::pgen::Write::tea {args} {
    # args = (option value)... grammar
    # Class   -> touches/defines variable 'class'

Added assets/tcllib1.18/pt/pt_rdengine_nx.tcl.



































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
# -*- tcl -*-
#
# Copyright (c) 2016 by Stefan Sobernig <stefan.sobernig@wu.ac.at>

# # ## ### ##### ######## ############# #####################
## Package description

## ...


# # ## ### ##### ######## ############# #####################
## Requisites

package require pt::rde::oo
package req nx

namespace eval ::pt::rde {

    ##
    ## Helper: An NX metaclass, which allows for deriving an NX class from
    ## a given TclOO class.
    ##
    
    nx::Class create ClassFactory -superclass nx::Class {
	:property prototype:required
	:method init {args} {
	    :alias instvar ::nsf::methods::object::instvar
	    namespace eval [namespace qualifier [self]] {
		namespace import ::nsf::my
	    }

	    ## clone constructor
	    lassign [info class constructor ${:prototype}] ctorParams ctorBody
	    :method init $ctorParams [:injectVars $ctorBody]
	    ## clone all methods
	    foreach m [info class methods ${:prototype} -private] {
		lassign [info class definition ${:prototype} $m] params body
		:method $m $params [:injectVars $body]
	    }
	}
	:method injectVars {body} {
	    if {![info exists :vars]} {
		set :vars [info class variables ${:prototype}]
	    }
	    if {[llength ${:vars}]} {
		append tmp [list :instvar {*}${:vars}] "\n" $body;
		return $tmp
	    } else {
		return $body;
	    }
	}
    }

    ##
    ## ::pt::rde::nx:
    ##
    ## The NX derivative of ::pt::rde::oo, to be inherited
    ## by the generated grammar class.
    ##
    
    ClassFactory create nx -prototype ::pt::rde::oo
    
}

package provide pt::rde::nx [package req pt::rde::oo]

Added assets/tcllib1.18/pt/pt_tclparam_config_nx.tcl.



































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
# -*- tcl -*-
# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
# Copyright (c) 2016 Stefan Sobernig <stefan.sobernig@wu.ac.at>

# Canned configuration for the converter to Tcl/PARAM representation,
# causing generation of a proper NX class.

# The requirements of the embedded template are not our requirements.
# @mdgen NODEP: nx
# @mdgen NODEP: pt::rde::nx

# # ## ### ##### ######## ############# #####################
## Requirements

package require Tcl 8.5              ; # Required runtime.

# # ## ### ##### ######## ############# #####################
##

namespace eval ::pt::tclparam::configuration::nx {
    namespace export   def
    namespace ensemble create
}

# # ## ### ##### ######## #############
## Public API

# Check that the proposed serialization of an abstract syntax tree is
# indeed such.

proc ::pt::tclparam::configuration::nx::def {class pkg version cmd} {

    lappend map @@PKG@@     $pkg
    lappend map @@VERSION@@ $version
    lappend map @@CLASS@@   $class
    lappend map \n\t        \n ;# undent the template

    {*}$cmd -runtime-command :
    {*}$cmd -self-command    :
    {*}$cmd -proc-command    :method
    {*}$cmd -prelude         {}
    {*}$cmd -namespace       {}
    {*}$cmd -main            MAIN
    {*}$cmd -indent          4
    {*}$cmd -template        [string trim \
				  [string map $map {
	## -*- tcl -*-
	##
	## NX-based Tcl/PARAM implementation of the parsing
	## expression grammar
	##
	##	@name@
	##
	## Generated from file	@file@
	##            for user  @user@
	##
	# # ## ### ##### ######## ############# #####################
	## Requirements

	package require Tcl 8.5
	package require nx
	package require pt::rde::nx ; # NX-based implementation of the
				      # PARAM virtual machine
				      # underlying the Tcl/PARAM code
				      # used below.

	# # ## ### ##### ######## ############# #####################
	##

	nx::Class create @@CLASS@@ -superclasses pt::rde::nx {
	    # # ## ### ##### ######## #############
	    ## Public API
	    
	    :public method parse {channel} {
		:reset $channel
		:MAIN ; # Entrypoint for the generated code.
		return [:complete]
	    }

	    :public method parset {text} {
		:reset {}
		:data $text
		:MAIN ; # Entrypoint for the generated code.
		return [:complete]
	    }

	    # # ## ### ###### ######## #############
	    ## BEGIN of GENERATED CODE. DO NOT EDIT.

@code@
	    ## END of GENERATED CODE. DO NOT EDIT.
	    # # ## ### ###### ######## #############
	}

	# # ## ### ##### ######## ############# #####################
	## Ready

	package provide @@PKG@@ @@VERSION@@
	# return
    }]]

    return
}

# # ## ### ##### ######## #############

namespace eval ::pt::tclparam::configuration::nx {}

# # ## ### ##### ######## ############# #####################
## Ready

package provide pt::tclparam::configuration::nx 1.0.0
return

Changes to assets/tcllib1.18/uri/pkgIndex.tcl.

1
2
3
4
5
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]]




|

1
2
3
4
5
6
if {![package vsatisfies [package provide Tcl] 8.2]} {
    # FRINK: nocheck
    return
}
package ifneeded uri      1.2.7 [list source [file join $dir uri.tcl]]
package ifneeded uri::urn 1.0.3 [list source [file join $dir urn-scheme.tcl]]

Changes to assets/tcllib1.18/uri/uri.tcl.

1
2
3
4
5
6
7

8
9
10
11
12
13
14
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

100
101
102




103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177





178

179
180
181
182
183
184
185
...
240
241
242
243
244
245
246


247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
...
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
345
346
347
348
349
350
351


352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388

389
390
391
392
393
394
395
...
425
426
427
428
429
430
431

432
433
434
435
436
437
438
439
...
543
544
545
546
547
548
549






















550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
...
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
...
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626

627
628



629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653




654
655
656
657
658
659
660
661
662
663
664

665
666
667
668
669
670
671

672



673
674
675
676
677





678






679
680

681


682
683

684
685
686






687
688



















689








690
691

692


693
694
695
696




697
698
699

700


701
702
703
704
705
706
707
708
...
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
...
801
802
803
804
805
806
807

808
809
810
811
812
813
814
...
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848

849
850
851

852
853
854
































855




856
857
858
859
860
861
862
863
...
865
866
867
868
869
870
871

872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920

921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
# 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 $
................................................................................
    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"
	}
................................................................................
    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
#
................................................................................
#	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!

................................................................................

    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} {
................................................................................
    #
    #   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.

................................................................................
}

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 {[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.
................................................................................
	    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
    set url_save $url

    array set parts {user {} pwd {} host {} port {}}

................................................................................

	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]
................................................................................
    
    if {![string match /* $url] && $url ne {}} {
	error [list {invalid url} $url $url_save]
    }

    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:
................................................................................
 
# ::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

................................................................................
    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
# ------------------------------------------------
................................................................................
# ------------------------------------------------
# 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







>







 







<
<
<
<





<
<

<
<
<
<
<
<
<



<
<
<

<
<
<
<
<
<
<
<



|








|
<
|


<





|



<
|




|
<

>
|
|
|
>
>
>
>










<
<
<







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|







 







|
|





|
>
>
>
>
>
|
>







 







>
>

<




<
<
<
<
<
<
<
<
<
<





|







 







<
<
<


<
|







 







>
>
|
<


<
<
<
<
<













|







|
<




|
>







 







>
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











|
<







 







|







 








|
<
<
<
<
<
|
<
<
<
>
|
<
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
>
>









<
|
>
|

|
|
|
|
|
>
|
>
>
>
|
|
<
|
|
>
>
>
>
>
|
>
>
>
>
>
>
|
|
>
|
>
>
|
<
>
|
|
|
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
<
>
|
>
>
|
<
|
|
>
>
>
>

<

>

>
>
|







 







|







 







>







 







|

|
|
|
|
|
<
>
|
|
<
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|







 







>

|













|







 







|
<
<
<
<
<
<
<
<
|
|
<
<
>
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
24
25
26
27
28
29
30




31
32
33
34
35


36







37
38
39



40








41
42
43
44
45
46
47
48
49
50
51
52
53

54
55
56

57
58
59
60
61
62
63
64
65

66
67
68
69
70
71

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90



91
92
93
94
95
96
97
...
101
102
103
104
105
106
107



















108
109
110
111
112
113
114
115
116
117
...
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
...
202
203
204
205
206
207
208
209
210
211

212
213
214
215










216
217
218
219
220
221
222
223
224
225
226
227
228
...
242
243
244
245
246
247
248



249
250

251
252
253
254
255
256
257
258
...
294
295
296
297
298
299
300
301
302
303

304
305





306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327

328
329
330
331
332
333
334
335
336
337
338
339
340
...
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
...
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529

530
531
532
533
534
535
536
...
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
...
576
577
578
579
580
581
582
583
584





585



586
587

588
589
590
591
























592
593
594
595
596
597
598
599
600
601
602
603
604

605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641

642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682

683
684
685
686
687

688
689
690
691
692
693
694

695
696
697
698
699
700
701
702
703
704
705
706
707
...
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
...
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
...
834
835
836
837
838
839
840
841
842
843
844
845
846
847

848
849
850

851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
...
938
939
940
941
942
943
944
945








946
947


948
949

950



































































































































951
# 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>
# Copyright (c) 2017 Keith Nash <kjnash@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 $
................................................................................
    namespace export canonicalize
    namespace export register

    variable file:counter 0

    # extend these variable in the coming namespaces
    variable schemes       {}





    # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # basic regular expressions used in URL syntax.

    namespace eval basic {


	variable	digit		{[0-9]}







	variable	hex		{[0-9A-Fa-f]}
	variable	alphaDigit	{[A-Za-z0-9]}
	variable	alphaDigitMinus	{[A-Za-z0-9-]}



	variable	escape		"%${hex}${hex}"








	variable	digits		"${digit}+"

	variable	toplabel	\
		"(${alphaDigit}${alphaDigitMinus}*${alphaDigit}\\.?|${alphaDigit}\\.?)"
	variable	domainlabel	\
		"(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"

	variable	hostname	\
		"((${domainlabel}\\.)*${toplabel})"
	variable	hostnumber4	\
		"(?:${digits}\\.${digits}\\.${digits}\\.${digits})"
	variable	hostnumber6	{(?:\[[^]]*\])}
	variable	hostnumber	"(${hostnumber4}|${hostnumber6})"

	variable	hostspec	"${hostname}|${hostnumber}"

	variable	port		$digits


	variable	usrCharN	{[a-zA-Z0-9$_.+!*'(,);?&=-]}
	variable	usrChar		"(${usrCharN}|${escape})"
	variable	user		"${usrChar}*"
	variable	password	$user
	# Used by commands: hostspec port user password
    } ;# basic {}
}
 

# ::uri::register (DEPRECATED) --
#
#	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.

#
# REASON FOR DEPRECATION
#	- Registration defines a namespace and pattern variables.
#	- From v1.2.7, the built-in schemes (and the urn scheme) do this without
#	  calling uri::register.
#	- Before v1.2.7, uri::register prevented re-registration of the same
#	  scheme name(s), and maintained variables that were not used for
#	  anything.
#	- The command is retained for use by third-party legacy code.
#
# 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




    # 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"
	}
................................................................................
    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"
    }



















    return
}
 
# ::uri::split --
#
#	Splits the given <a url> into its constituents.
#
# Arguments:
#	url	the URL to split
#
................................................................................
#	Tcl list containing constituents, suitable for 'array set'.

proc ::uri::split {url {defaultscheme http}} {

    set url [string trim $url]
    set scheme {}

    # RFC 3986 Sec 3.1: scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )
    regexp -- {^([A-Za-z][A-Za-z0-9+.-]*):} $url dummy scheme

    if {$scheme == {}} {
	set scheme $defaultscheme
	switch -- $scheme {
	    http - https - ftp {
		# x/y     -> //x/y    PREPEND //
		# /x/y    -> ///x/y   PREPEND //
		# //x/y   -> //x/y
		# ///x/y  -> ///x/y
		# ////x/y -> ////x/y
		if {[string range $url 0 1] != "//"} {
		    set url //$url
		}
	    }
	}
    }

    # ease maintenance: dynamic dispatch, able to handle all schemes
    # added in future!

................................................................................

    set parts(path) [string trimleft $url /]

    return [array get parts]
}
 
proc ::uri::JoinFtp args {
    set uphp [eval [linsert $args 0 ComposeUPHP {}]]

    array set components {

	path {} type {}
    }
    array set components $args











    set type {}
    if {[string length $components(type)]} {
	set type \;type=$components(type)
    }

    return ftp://${uphp}/[string trimleft $components(path) /]$type
}
 
proc ::uri::SplitHttps {url} {
    return [SplitHttp $url]
}

proc ::uri::SplitHttp {url} {
................................................................................
    #
    #   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>]




    array set parts {host {} port {} path {} query {} fragment {}}


    set fragmentPattern "#(.*)\$"

    # 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.

................................................................................
}

proc ::uri::JoinHttps {args} {
    return [eval [linsert $args 0 ::uri::JoinHttpInner https 443]]
}

proc ::uri::JoinHttpInner {scheme defport args} {
    set uphp [eval [linsert $args 0 ComposeUPHP $defport]]

    array set components {path {} query {} fragment {}}

    array set components $args






    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://$uphp/$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::hostspec	hostspec


    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	set hostPattern "^($hostspec)"

	switch -exact -- $::tcl_platform(platform) {
	    windows {
		# Catch drive letter
		append hostPattern :?
	    }
	    default {
		# Proceed as usual
................................................................................
	    if {[string length $components(host)]} {
		return file://$components(host):$components(path)
	    } else {
		return file://$components(path)
	    }
	}
	default {
	    set components(path) [string trimleft $components(path) /]
	    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.
................................................................................
	    append url "${s}$components($c)"
	    set s ""
	}
    }

    return $url
}
 
proc ::uri::ComposeUPHP {defport args} {
    # user:pwd@host:port

    array set components {
	user {} pwd {} host {} port {}
    }
    set       components(port) $defport
    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)] && $components(port) != $defport} {
	set port :$components(port)
    }

    return ${userPwd}$components(host)${port}
}
 
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::hostspec	hostspec

    upvar \#0 [namespace current]::basic::port		port

    upvar $urlvar url
    set url_save $url

    array set parts {user {} pwd {} host {} port {}}

................................................................................

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    set hpPattern "^($hostspec)(:($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]
................................................................................
    
    if {![string match /* $url] && $url ne {}} {
	error [list {invalid url} $url $url_save]
    }

    return [array get parts]
}
 
# ::uri::resolve --





#



#	Resolve an arbitrary URL, given a base URL
#

# This code depends on the ability of uri::split to process relative URIs.
# N.B. http(s): and ftp: path does not begin with "/" and may be empty.
# The file: path (unix) always begins "/", even if a host is specified.
#
























# RFC 3986 Sec. 5.2 defines how URI relative resolution should proceed.
# This command is a "strict parser" in the sense of Sec. 5.2.2: it does not
# allow a relative URI such as "http:foo/bar.html".  See also the last example
# in Sec. 5.4.2 and uri-rfc2396.test test uri-rfc2396-11.19.
#
# Arguments:
#	base	base URL (absolute)
#	url	arbitrary URL
#
# Results:
#	Returns a URL

proc ::uri::resolve {base url} {

    if {[isrelative $url]} {
	set canon 1
	array set baseparts [split $base]

	switch -- $baseparts(scheme) {
	    http -
	    https -
	    ftp -
	    file {
		set changed 0
		array set relparts [split $baseparts(scheme):$url]
		if {[array names relparts path] != {path}} {
		    set relparts(path) {}
		}
		if { [string match /* $url] } {
		    set baseparts(path) $relparts(path)

		    catch {
			if {$relparts(host) != ""} {
			    # RFC 3986 section 4.2 and 5.2.2.
			    # url has no scheme, but has authority
			    # ("UPHP" or User,Password,Host,Port). Use that
			    # authority. Do not transfer credentials or port
			    # number from the base authority.
			    set baseparts(host) $relparts(host)
			    set baseparts(user) {}
			    set baseparts(pwd)  {}
			    set baseparts(port) {}
			    set baseparts(user) $relparts(user)
			    set baseparts(pwd)  $relparts(pwd)
			    set baseparts(port) $relparts(port)
			}
		    }
		    set changed 1
		} elseif {    [string match */ $baseparts(path)]
			   && ([string length $relparts(path)] > 0)
		} {
		    set baseparts(path) "$baseparts(path)$relparts(path)"

		    set changed 1
		} elseif { [string length $relparts(path)] > 0 } {
		    set path [lreplace [::split $baseparts(path) /] end end]
		    set baseparts(path) "[::join $path /]/$relparts(path)"
		    set changed 1
		} else {
		    # Do not overwrite baseparts(path).  In this case,
		    # RFC 3986 Sec. 5.2.2 does not demand canonicalization.
		    # FIXME check whether it assumes the base URI is already canonical.
		    set canon 0
		}
	    }
	    default {
		return -code error "unable to resolve relative URL \"$url\""
	    }
	}

	# query and fragment are defined for http, https; not for file, ftp
	# FIXME check the RFCs re fragment: it is useful in HTML documents when
	# accessed by file or ftp.
	switch -- $baseparts(scheme) {
	    http -
	    https {
		if {[array names relparts query] != {query}} {
		    set relparts(query) {}
		}
		if {[array names relparts fragment] != {fragment}} {
		    set relparts(fragment) {}
		}

		if {$changed || ($relparts(query) != {})} {
		    set baseparts(query) $relparts(query)
		    set changed 1
		} else {
		    # Keep base query.
		    # FIXME error if url has empty query "?".
		}

		# RFC 3986 section 5.2.2 requires that the base fragment
		# is always discarded.
		set baseparts(fragment) $relparts(fragment)

		# FIXME (in split/join) empty fragment "#".
	    }
	    ftp -
	    file -
	    default {

	    }
	}
	set url [eval [linsert [array get baseparts] 0 join]]
	if {$canon} {
	    # RFC 3986 section 5.2.2 requires us to canonicalize the path.
	    set url [canonicalize $url]
	} else {

	}
	return $url
    } else {
	# RFC 3986 section 5.2.2 requires us to canonicalize the path.
	set url [canonicalize $url]
	return $url
    }
}
 
# ::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-Za-z][A-Za-z0-9+.-]*:} $url]}]
}
 
# ::uri::geturl --
#
#	Fetch the data from an arbitrary URL.
#
#	This package provides a handler for the file:
................................................................................
 
# ::uri::canonicalize --
#
#	Canonicalize a URL
#
# Acknowledgements:
#	Andreas Kupries <andreas_kupries@users.sourceforge.net>
#	Keith Nash <kjnash@users.sourceforge.net>
#
# Arguments:
#	uri	URI (which contains a path component)
#
# Results:
#	The canonical form of the URI

................................................................................
    if {[catch {array set u [::uri::split $uri]}]} {
	return $uri
    }
    if {![info exists u(path)]} {
	return $uri
    }

    set oldList [::split $u(path) /]

    if {[lindex $oldList 0] == {}} {
	set lead 1
    } else {
	set lead 0
    }


    set end [llength $oldList]
    incr end -1


    # i - index of element seg in oldList
    # j - index of last element written to newList
    set i 0
    set j -1
    set newList {}
    foreach seg $oldList {
	if {($seg == {}) && ($i != 0) && ($i != $end)} {
	    # Throw away this empty segment.
	    # This merges adjacent "/".
	    # If the first or last segment is empty, it is handled at "else".
	} elseif {($seg == {.}) && ($i == $end)} {
	    # Replace "." with {} to keep a trailing "/" in path.
	    lappend newList {}
	    incr j
	} elseif {$seg == {.}} {
	    # Throw away this "." segment.
	} elseif {($seg == {..}) && ($j > $lead - 1) && ($i == $end)} {
	    # Remove the element previously added to newList, and
	    # replace it with {} to keep a trailing "/" in path.
	    set newList [lreplace $newList $j $j {}]
	} elseif {($seg == {..}) && ($j > $lead - 1)} {
	    # Remove the element previously added to newList.
	    set newList [lreplace $newList $j $j]
	    incr j -1
	} elseif {($seg == {..}) && ($i == $end)} {
	    # Can't go any deeper in newList, but this path needs a
	    # leading "/".
	    lappend newList {}
	    incr j
	} elseif {$seg == {..}} {
	    # Can't go any deeper in newList.
	} else {
	    # A "normal" path segment!
	    lappend newList $seg
	    incr j
	}

	incr i
    }

    set u(path) [::join $newList /]
    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>
#    		//<user>:<password>@<host>:<port>/fpath;type=<typecode>
#
# http		//<host>:<port>/<hpath>?<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>/<fpath>
# prospero	//<host>:<port>/<hsoname>;<field>=<value>
# ------------------------------------------------
#
# (RFC 2111)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
................................................................................
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# ldap		//<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
# ------------------------------------------------

# FTP
namespace eval ::uri::ftp {








    variable	Type		{[AaDdIi]}
    variable	typepart	";type=(${Type})"


    # Used elsewhere: typepart
}





































































































































package provide uri 1.2.7

Changes to assets/tcllib1.18/uri/urn-scheme.tcl.

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
        # 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:







|





|
<










119
120
121
122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140
141
142
        # Recode the array of utf-8 bytes to the proper internal rep.
        return [encoding convertfrom utf-8 $result]
    }
}

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

namespace eval ::uri::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)"
        # Used elsewhere: NIDpart trans URNpart

}

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

package provide uri::urn 1.0.3

# -------------------------------------------------------------------------
# Local Variables:
#   indent-tabs-mode: nil
# End:

jni/tcl/compat/zlib/win32/zlib1.dll became a regular file.

cannot compute difference between binary files

jni/tcl/compat/zlib/win64/zlib1.dll became a regular file.

cannot compute difference between binary files

jni/tcl/compat/zlib/zlib2ansi became a regular file.