Tcl Library Source Code

Changes On Branch toad-mimefix
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki
Hide Diff Patch Unified Diff

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

Changes In Branch toad-mimefix Excluding Merge-Ins

This is equivalent to a diff from c0c1f0de61 to a202a3b3ac

2018-12-06
20:29
Pulling changes from pooryorick branch check-in: e338b5bee7 user: hypnotoad tags: hypnotoad
04:00
Bodges to get the httpd and mime tests to run again. Closed-Leaf check-in: a202a3b3ac user: hypnotoad tags: toad-mimefix
03:40
Removing ncgi from the httpd tests. (It doesn't use ncgi anyway) check-in: 37595e2619 user: hypnotoad tags: toad-mimefix
03:32
Provisional patch to fix to make the ego and chan modules conform to some semblance of a community standard -- Start of the pooryorick branch check-in: b45ea48529 user: hypnotoad tags: toad-mimefix
03:32
Fixing version of textutil::wcswidth in the pkgIndex file check-in: c0c1f0de61 user: hypnotoad tags: hypnotoad
03:01
Resolving a merge conflict check-in: 4c7e4bc7e7 user: hypnotoad tags: hypnotoad

Changes to modules/chan/base.tcl. 

1
2
3
4
5
6
7
8
9
10


11
12
13
14
15
16
17

#! /usr/bin/env tclsh

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############




proc .init {_ channame args} {
    $_ .vars chan close
    if {$channame ni [::chan names]} {
	error [list {unknown channel} $channame]
    }
    set chan $channame

<
<







|
>
>










1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17



# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############
package require ego
tcllib::ego .new ::tcllib::chan::base
::tcllib::chan::base .eval {

proc .init {_ channame args} {
    $_ .vars chan close
    if {$channame ni [::chan names]} {
	error [list {unknown channel} $channame]
    }
    set chan $channame
︙︙
107
108
109
110
111
112
113
114


115



	proc $name {_ args} [string map [
	    list @name@ [list $name]] {
	    ::chan @name@ [$_ $ chan] {*}$args
	}]
	.my .method $name
    }
} [namespace current]]














|
>
>
|
>
>

107
108
109
110
111
112
113
114
115
116
117
118
119

	proc $name {_ args} [string map [
	    list @name@ [list $name]] {
	    ::chan @name@ [$_ $ chan] {*}$args
	}]
	.my .method $name
    }
} [namespace current]]
}
namespace eval ::tcllib::chan {
	namespace export base
}
package provide {chan base} 0.1

Changes to modules/chan/coroutine.tcl. 

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19

#! /usr/bin/tclsh

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############

package require coroutine



proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize
	foreach name {












|
>








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

#! /usr/bin/tclsh

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############

package require coroutine
package require ego
namespace eval ::tcllib::chan::coroutine {

proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize
	foreach name {
︙︙
31
32
33
34
35
36
37







}


proc read {_ args} {
	$_ .vars chan
	tailcall ::coroutine::util::read $chan {*}$args
}














>
>
>
>
>
>

32
33
34
35
36
37
38
39
40
41
42
43
44

}


proc read {_ args} {
	$_ .vars chan
	tailcall ::coroutine::util::read $chan {*}$args
}
}

package provide {chan coroutine} 0.1
namespace eval ::tcllib::chan {
	namespace export coroutine
}

Changes to modules/chan/getslimit.tcl. 

1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17

#! /usr/bin/env tclsh

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############


variable buf bufcount eof getslimit

proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize

<
<







|
>










1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16



# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############
package require ego
namespace eval ::tcllib::chan::getslimit {
variable buf bufcount eof getslimit

proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize
︙︙
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

	    }
	}
    } elseif {[llength $args]} {
	dict size $args
	foreach {key val} $args[set args {}] {
	    if {$key eq {-getslimit}} {
		set getslimit $val
	    } else {    
		lappend args $key $val
	    }
	}
	if {[llength $args]} {
	    uplevel 1 [list $_ .prototype configure {*}$args]
	}
	set res {}








|








44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

	    }
	}
    } elseif {[llength $args]} {
	dict size $args
	foreach {key val} $args[set args {}] {
	    if {$key eq {-getslimit}} {
		set getslimit $val
	    } else {
		lappend args $key $val
	    }
	}
	if {[llength $args]} {
	    uplevel 1 [list $_ .prototype configure {*}$args]
	}
	set res {}
︙︙
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

proc  eof _ {
    $_ .vars bufcount eof
    return [expr {$eof || ( [$_ .prototype eof] && $bufcount == 0 )}]
}


proc gets {_ args} {
    $_ .vars buf bufcount chan eof getslimit 
    switch [llength $args] {
	1 {
	    lassign $args varname
	    upvar 1 $varname resvar
	}
	0 {}
	default {








|








67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

proc  eof _ {
    $_ .vars bufcount eof
    return [expr {$eof || ( [$_ .prototype eof] && $bufcount == 0 )}]
}


proc gets {_ args} {
    $_ .vars buf bufcount chan eof getslimit
    switch [llength $args] {
	1 {
	    lassign $args varname
	    upvar 1 $varname resvar
	}
	0 {}
	default {
︙︙
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

    } else {
	return $res
    }
}


proc read {_ args} {
    $_ .vars buf eof bufcount 
    if {$eof} {
	return {}
    }
    if {$bufcount} {
	if {[llength $args]} {
	    lassign $args size
	    if {$size <= $bufcount} {








|








125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

    } else {
	return $res
    }
}


proc read {_ args} {
    $_ .vars buf eof bufcount
    if {$eof} {
	return {}
    }
    if {$bufcount} {
	if {[llength $args]} {
	    lassign $args size
	    if {$size <= $bufcount} {
︙︙
151
152
153
154
155
156
157
158
159
160





	    set res $buf[set buf {}][$_ .prototype read {*}$args]
	}
    } else {
	set res [$_ .prototype read {*}$args]
    }
    return $res
}


package provide tcllib::chan::getslimit 1












|


>
>
>
>

150
151
152
153
154
155
156
157
158
159
160
161
162
163

	    set res $buf[set buf {}][$_ .prototype read {*}$args]
	}
    } else {
	set res [$_ .prototype read {*}$args]
    }
    return $res
}
}

package provide tcllib::chan::getslimit 1
package provide {chan getslimit} 0.1
namespace eval ::tcllib::chan {
	namespace export getslimit
}

Changes to modules/chan/pkgIndex.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

#! /usr/bin/env tclsh

if {![package vsatisfies [package provide Tcl] 8.6]} {return}

package ifneeded {chan getslimit} 0.1 [list ::apply {dir {
    package require ego
    namespace eval ::tcllib::chan::getslimit [list ::source $dir/getslimit.tcl]
    package provide {chan getslimit} 0.1
    namespace eval ::tcllib::chan {
	namespace export getslimit
    }
}} $dir]


package ifneeded {chan base} 0.1 [list ::apply {dir {
    package require ego
    tcllib::ego .new ::tcllib::chan::base 
    ::tcllib::chan::base .eval [list ::source  $dir/base.tcl]
    namespace eval ::tcllib::chan {
	namespace export base
    }
    package provide {chan base} 0.1
}} $dir]


package ifneeded {chan coroutine} 0.1 [list ::apply {dir {
    package require ego
    namespace eval ::tcllib::chan::coroutine [list ::source $dir/coroutine.tcl]
    package provide {chan coroutine} 0.1
    namespace eval ::tcllib::chan {
	namespace export coroutine
    }
}} $dir]

<
<


|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<



1
2
3









4










5










if {![package vsatisfies [package provide Tcl] 8.6]} {return}

package ifneeded {chan getslimit} 0.1 [list ::source [file join $dir getslimit.tcl]]









package ifneeded {chan base}      0.1 [list ::source [file join $dir base.tcl]]










package ifneeded {chan coroutine} 0.1 [list ::source [file join $dir coroutine.tcl]]

Changes to modules/ego/ego.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

#! /bin/env tclsh

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############


namespace ensemble create
namespace export *

proc .method {_ name args} {
	if {![llength $args]} {
		lappend args $name
	}
	set args [linsert $args[set args {}] 1 $_]
	set map [namespace ensemble configure $_ -map]
	dict set map $name $args 
	uplevel 1 [list ::namespace ensemble configure $_ -map $map]
	return
}
.method [namespace current] .method


proc $ {_ name args} {

<
<








>









|










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



# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############

namespace eval ::tcllib::ego {
namespace ensemble create
namespace export *

proc .method {_ name args} {
	if {![llength $args]} {
		lappend args $name
	}
	set args [linsert $args[set args {}] 1 $_]
	set map [namespace ensemble configure $_ -map]
	dict set map $name $args
	uplevel 1 [list ::namespace ensemble configure $_ -map $map]
	return
}
.method [namespace current] .method


proc $ {_ name args} {
︙︙
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

}
.method [namespace current] .as


proc .eval {_ args} {
	::tailcall ::namespace eval [$_ .namespace] {*}$args
}
.method [namespace current] .eval 


proc .insert {_ name} {
	set unknown1 [namespace ensemble configure $_ -unknown]
	set prototype1 [namespace ensemble configure $_ -prototype]

	if {[llength $unknown1]} {
		namespace ensemble configure $name -prototype $prototype1 \
			-unknown $unknown1 
	}

	namespace enemble configure $_ -prototype [list ::lindex $name] -unknown $unknown1
	return
}


proc .name _ {
	return $_
}
.method [namespace current] .name 


proc .namespace _ {
	namespace ensemble configure $_ -namespace
}
.method [namespace current] .namespace 


proc .new {_ name args} {
	global env
	set ns [uplevel 1 [list ::namespace eval $name {
		::namespace ensemble create
		::variable configured 0








|








|










|





|








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

}
.method [namespace current] .as


proc .eval {_ args} {
	::tailcall ::namespace eval [$_ .namespace] {*}$args
}
.method [namespace current] .eval


proc .insert {_ name} {
	set unknown1 [namespace ensemble configure $_ -unknown]
	set prototype1 [namespace ensemble configure $_ -prototype]

	if {[llength $unknown1]} {
		namespace ensemble configure $name -prototype $prototype1 \
			-unknown $unknown1
	}

	namespace enemble configure $_ -prototype [list ::lindex $name] -unknown $unknown1
	return
}


proc .name _ {
	return $_
}
.method [namespace current] .name


proc .namespace _ {
	namespace ensemble configure $_ -namespace
}
.method [namespace current] .namespace


proc .new {_ name args} {
	global env
	set ns [uplevel 1 [list ::namespace eval $name {
		::namespace ensemble create
		::variable configured 0
︙︙
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
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
148
149
150
151


	set prototype $_
	set map [namespace ensemble configure $_ -map]

	set prototypes {}
	while {[dict exists $map .prototype]} {
		set prototypes [list $map {*}$prototypes[set prototypes {}]]
		lassign [dict get $map .prototype] prototype 
		set map [namespace ensemble configure $prototype -map]
	}

	set map {}
	foreach {key val} [namespace ensemble configure $prototype -map] { 
		if {$key ne {.prototype}} {
			if {[lindex $val 1] eq $_} {
				set val [lreplace $val[set val {}] 1 1 $ns]
			}
		} else {
			error [list {how did we get to here?}]
		}
		lappend map $key $val 
	}

	namespace ensemble configure $ns -map $map

	set prototype $ns
	foreach map $prototypes {
		$ns .specialize
		dict unset map .prototype
		dict for {name cmd} $map {
			if {[lindex $cmd 1] eq $_} {
				# remove the original name from index 1 because .method is
				# going to add it back 
				$ns .method $name {*}[lreplace $cmd[set cmd {}] 1 1]
			} else {
				$ns .routine $name {*}$cmd
			}
		}
	}

	interp alias {} ${ns}::.my {} $ns 

	if {[llength $args]} {
		tailcall $ns .init {*}$args
	} else {
		return $ns
	}
}
.method [namespace current] .new 


proc .ondelete {_ trace args} {
    if {[llength $args] == 1} {
	lassign $args script
	trace remove command $_ delete $trace
	set trace {}








|




|







|











|







|







|








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
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
148
149
150


	set prototype $_
	set map [namespace ensemble configure $_ -map]

	set prototypes {}
	while {[dict exists $map .prototype]} {
		set prototypes [list $map {*}$prototypes[set prototypes {}]]
		lassign [dict get $map .prototype] prototype
		set map [namespace ensemble configure $prototype -map]
	}

	set map {}
	foreach {key val} [namespace ensemble configure $prototype -map] {
		if {$key ne {.prototype}} {
			if {[lindex $val 1] eq $_} {
				set val [lreplace $val[set val {}] 1 1 $ns]
			}
		} else {
			error [list {how did we get to here?}]
		}
		lappend map $key $val
	}

	namespace ensemble configure $ns -map $map

	set prototype $ns
	foreach map $prototypes {
		$ns .specialize
		dict unset map .prototype
		dict for {name cmd} $map {
			if {[lindex $cmd 1] eq $_} {
				# remove the original name from index 1 because .method is
				# going to add it back
				$ns .method $name {*}[lreplace $cmd[set cmd {}] 1 1]
			} else {
				$ns .routine $name {*}$cmd
			}
		}
	}

	interp alias {} ${ns}::.my {} $ns

	if {[llength $args]} {
		tailcall $ns .init {*}$args
	} else {
		return $ns
	}
}
.method [namespace current] .new


proc .ondelete {_ trace args} {
    if {[llength $args] == 1} {
	lassign $args script
	trace remove command $_ delete $trace
	set trace {}
︙︙
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222


223
224
225

		lappend args $name
	}
	set map [namespace ensemble configure $_ -map]
	dict set map $name $args
	uplevel 1 [list ::namespace ensemble configure $_ -map $map]
	return
}
.method [namespace current] .routine 


proc .specialize {_ args} {
	set ns [$_ .namespace] 
	while {[namespace which [set name ${ns}::[
		info cmdcount]_prototype]] ne {}} {}
	rename $_ $name
	
	set new [namespace eval ${ns} [
		list namespace ensemble create -command $_ -map [list \
			.prototype [list $name]
		] -unknown [
			list ::apply {{_ name args} {

			set prototype [lindex [dict get [namespace ensemble configure $_ -map] .prototype] 0]
			list $prototype $name
		}}]]]

	::trace add command $new delete [list ::apply {{ns oldname newname op} {
		if {[namespace exists $ns]} {
			namespace delete $ns
		}
	}} $ns]
	return
}
.method [namespace current] .specialize 


proc .vars {_ args} {
	set vars {}
	foreach arg $args {
		lassign $arg source target
		if {[llength $arg] == 1} {
			set target $source
		}
		lappend vars $source $target
	}
	uplevel 1 [list ::namespace upvar $_ {*}$vars]
}
.method [namespace current] .vars 


proc = {_ name val} {
	set [$_ .namespace]::$name $val
}
.method [namespace current] = 













|



|



|

















|













|





|
>
>




168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
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

		lappend args $name
	}
	set map [namespace ensemble configure $_ -map]
	dict set map $name $args
	uplevel 1 [list ::namespace ensemble configure $_ -map $map]
	return
}
.method [namespace current] .routine


proc .specialize {_ args} {
	set ns [$_ .namespace]
	while {[namespace which [set name ${ns}::[
		info cmdcount]_prototype]] ne {}} {}
	rename $_ $name

	set new [namespace eval ${ns} [
		list namespace ensemble create -command $_ -map [list \
			.prototype [list $name]
		] -unknown [
			list ::apply {{_ name args} {

			set prototype [lindex [dict get [namespace ensemble configure $_ -map] .prototype] 0]
			list $prototype $name
		}}]]]

	::trace add command $new delete [list ::apply {{ns oldname newname op} {
		if {[namespace exists $ns]} {
			namespace delete $ns
		}
	}} $ns]
	return
}
.method [namespace current] .specialize


proc .vars {_ args} {
	set vars {}
	foreach arg $args {
		lassign $arg source target
		if {[llength $arg] == 1} {
			set target $source
		}
		lappend vars $source $target
	}
	uplevel 1 [list ::namespace upvar $_ {*}$vars]
}
.method [namespace current] .vars


proc = {_ name val} {
	set [$_ .namespace]::$name $val
}
.method [namespace current] =
}
package provide ego 0.1

Changes to modules/ego/pkgIndex.tcl. 

1
2
3
4
5
6
7
8

#! /usr/bin/env tclsh

if {![package vsatisfies [package provide Tcl] 8.6]} {return}

package ifneeded ego 0.1 [list ::apply {dir {
    namespace eval ::tcllib::ego [list ::source $dir/ego.tcl]
    package provide ego 0.1
}} $dir]





|
<
<
<

1
2
3
4
5




#! /usr/bin/env tclsh

if {![package vsatisfies [package provide Tcl] 8.6]} {return}

package ifneeded ego 0.1 [list ::source [file join $dir ego.tcl]]

Changes to modules/httpd/httpd.test.

︙︙
15
16
17
18
19
20
21






22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


testsNeed TclOO 1

support {
  use [file join ${TCLLIBMOD} cmdline cmdline.tcl]      cmdline
  use [file join ${TCLLIBMOD} fileutil fileutil.tcl]    fileutil
  use [file join ${TCLLIBMOD} sha1 sha1.tcl]            sha1






  use [file join ${TCLLIBMOD} uri uri.tcl]              uri
  use [file join ${TCLLIBMOD} ncgi ncgi.tcl]            ncgi
  use [file join ${TCLLIBMOD} dns ip.tcl]               ip
  use [file join ${TCLLIBMOD} nettool nettool.tcl]      nettool
  use [file join ${TCLLIBMOD} coroutine coroutine.tcl]  coroutine
  use [file join ${TCLLIBMOD} cron cron.tcl]            cron
  use [file join ${TCLLIBMOD} virtchannel_core core.tcl] tcl::chan::core
  use [file join ${TCLLIBMOD} virtchannel_core events.tcl] tcl::chan::events
  use [file join ${TCLLIBMOD} virtchannel_base memchan.tcl] tcl::chan::memchan
  use [file join ${MODDIR} clay clay.tcl]               clay
}

testing {
  useLocal httpd.tcl httpd
}








>
>
>
>
>
>

<




|
|








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


testsNeed TclOO 1

support {
  use [file join ${TCLLIBMOD} cmdline cmdline.tcl]      cmdline
  use [file join ${TCLLIBMOD} fileutil fileutil.tcl]    fileutil
  use [file join ${TCLLIBMOD} sha1 sha1.tcl]            sha1
  use [file join ${TCLLIBMOD} namespacex  namespacex.tcl] namespacex
  use [file join ${TCLLIBMOD} ego  ego.tcl]             ego
  use [file join ${TCLLIBMOD} chan base.tcl]            {chan base}
  use [file join ${TCLLIBMOD} chan getslimit.tcl]       {chan getslimit}
  use [file join ${TCLLIBMOD} mime qp.tcl]              {mime qp}
  use [file join ${TCLLIBMOD} mime mime.tcl]            mime
  use [file join ${TCLLIBMOD} uri uri.tcl]              uri

  use [file join ${TCLLIBMOD} dns ip.tcl]               ip
  use [file join ${TCLLIBMOD} nettool nettool.tcl]      nettool
  use [file join ${TCLLIBMOD} coroutine coroutine.tcl]  coroutine
  use [file join ${TCLLIBMOD} cron cron.tcl]            cron
  #use [file join ${TCLLIBMOD} virtchannel_core core.tcl] tcl::chan::core
  #use [file join ${TCLLIBMOD} virtchannel_core events.tcl] tcl::chan::events
  use [file join ${TCLLIBMOD} virtchannel_base memchan.tcl] tcl::chan::memchan
  use [file join ${MODDIR} clay clay.tcl]               clay
}

testing {
  useLocal httpd.tcl httpd
}
︙︙

Changes to modules/mime/mime.test.

︙︙
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27



28

29

30
31
32
33
34
35
36

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

source [file join \
	[file dirname [file dirname [file dirname [
	    file normalize [info script]/...]]]]/devtools/testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2 

support {
    # This code loads md5x, i.e. md5 v2. Proper testing should do one
    # run using md5 v1, aka md5.tcl as well.
    use md5/md5x.tcl md5

    use namespacex/namespacex.tcl namespacex



}

testing {

    useLocal mime.tcl mime
}

package require {chan base}

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









|





<

>
>
>
|
>

>








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

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

source [file join \
	[file dirname [file dirname [file dirname [
	    file normalize [info script]/...]]]]/devtools/testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    # This code loads md5x, i.e. md5 v2. Proper testing should do one
    # run using md5 v1, aka md5.tcl as well.
    use md5/md5x.tcl md5

    use namespacex/namespacex.tcl namespacex
    use ego/ego.tcl   ego
    use chan/base.tcl {chan base}
    use chan/getslimit.tcl {chan getslimit}

}
testing {
    useLocal qp.tcl   {mime qp}
    useLocal mime.tcl mime
}

package require {chan base}

# -------------------------------------------------------------------------
︙︙
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

part3
--bar--
}

    set tok [.new {} -string $msg]
    set partToks [$tok property parts]

    set res {} 
    foreach childTok $partToks {
	lappend res [[$childTok body raw] read]
    }
    set res
}} [list part1 part2 part3]










|








231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

part3
--bar--
}

    set tok [.new {} -string $msg]
    set partToks [$tok property parts]

    set res {}
    foreach childTok $partToks {
	lappend res [[$childTok body raw] read]
    }
    set res
}} [list part1 part2 part3]
︙︙
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

    qp encode {How long is a piece of string ?} 1
}} How_long_is_a_piece_of_string_=3F


test mime-4.13 {Test qp::encode in no_softbreak mode} {cleanly {
    qp encode {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility} 0 1
}} {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility}
 


test mime-5.1 {Test word_encode with quoted-printable method} {cleanly {
    word_encode iso8859-1 quoted-printable {Test de contrôle effectué}
}} =?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?=










|








451
452
453
454
455
456
457
458
459
460
461
462
463
464
465

    qp encode {How long is a piece of string ?} 1
}} How_long_is_a_piece_of_string_=3F


test mime-4.13 {Test qp::encode in no_softbreak mode} {cleanly {
    qp encode {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility} 0 1
}} {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility}



test mime-5.1 {Test word_encode with quoted-printable method} {cleanly {
    word_encode iso8859-1 quoted-printable {Test de contrôle effectué}
}} =?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?=
︙︙
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674

    {(a b)}
    10 {(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)}
    {(a b)}
    11 {(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)}
    {(ax b)}
    12 {a         b         c}
    {a         b         c}
    13 {} 
    {}
} {
    test mime-6.$n {Test field_decode (from RFC 2047, part 8)} {cleanly {
	field_decode $encoded
    }} $expected ; # {}
}









|








664
665
666
667
668
669
670
671
672
673
674
675
676
677
678

    {(a b)}
    10 {(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)}
    {(a b)}
    11 {(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)}
    {(ax b)}
    12 {a         b         c}
    {a         b         c}
    13 {}
    {}
} {
    test mime-6.$n {Test field_decode (from RFC 2047, part 8)} {cleanly {
	field_decode $encoded
    }} $expected ; # {}
}
︙︙
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711

    test mime-9.0.$name {Test chunk handling of serialize and helpers} {cleanly {
	set in [makeFile [set data [string repeat [string repeat {123456789 } 10]\n 350]] input.txt]
	set mi [makeFile {} mime.txt]

	with.$name $in -canonical text/plain {
	    ::tcllib::chan::base .new chan1 [open $mi w]
	    chan1 configure -translation binary
	    $tok serialize -chan chan1 
	    chan1 close

	    with.$name $mi {
		set newdata [[$tok body raw] read]
		set res [string compare $data $newdata]

		removeFile input.txt








|








701
702
703
704
705
706
707
708
709
710
711
712
713
714
715

    test mime-9.0.$name {Test chunk handling of serialize and helpers} {cleanly {
	set in [makeFile [set data [string repeat [string repeat {123456789 } 10]\n 350]] input.txt]
	set mi [makeFile {} mime.txt]

	with.$name $in -canonical text/plain {
	    ::tcllib::chan::base .new chan1 [open $mi w]
	    chan1 configure -translation binary
	    $tok serialize -chan chan1
	    chan1 close

	    with.$name $mi {
		set newdata [[$tok body raw] read]
		set res [string compare $data $newdata]

		removeFile input.txt
︙︙
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841

    set msg "MIME-Version: 1.0
Content-Type: text/plain\r
\r
so plain
"

    set tok [.new {} -string $msg]
    [$tok body raw] read 
} "so plain\n"

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

test mime-14.0 {cleanly {
	hostname argument to parseaddress
}} {
	set parsed [parseaddress hostname fakedomain.fake {Here <h>}] 
    list [llength $parsed] [lindex $parsed 0]
} [list 1 [list address [email protected] comment {} domain {} error {} \
	friendly Here group {} local h memberP 0 phrase Here \
	proper {Here <[email protected]>} route {}]]











|







|








823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845

    set msg "MIME-Version: 1.0
Content-Type: text/plain\r
\r
so plain
"

    set tok [.new {} -string $msg]
    [$tok body raw] read
} "so plain\n"

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

test mime-14.0 {cleanly {
	hostname argument to parseaddress
}} {
	set parsed [parseaddress hostname fakedomain.fake {Here <h>}]
    list [llength $parsed] [lindex $parsed 0]
} [list 1 [list address [email protected] comment {} domain {} error {} \
	friendly Here group {} local h memberP 0 phrase Here \
	proper {Here <[email protected]>} route {}]]
︙︙
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996

} {test/test {foo {}}}


test mime-17.9 {
    header supplied by a component message, retrieved by lowercase name
} {
    set mime [.new {} -string {Content-Disposition: form-data; name="field2"}]
    $mime header get content-disposition 
} {form-data {name field2}}


test mime-17.10 {
    Content-Type is not automatically added to a subordinate
} {
    set mime [.new {} -string {Content-Disposition: form-data; name="field2"}]
    $mime header get content-disposition 
} {form-data {name field2}}


test mime-18.1 {
    non-seekable channel
} {
    set script [list puts -nonewline $message1]








|







|








978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000

} {test/test {foo {}}}


test mime-17.9 {
    header supplied by a component message, retrieved by lowercase name
} {
    set mime [.new {} -string {Content-Disposition: form-data; name="field2"}]
    $mime header get content-disposition
} {form-data {name field2}}


test mime-17.10 {
    Content-Type is not automatically added to a subordinate
} {
    set mime [.new {} -string {Content-Disposition: form-data; name="field2"}]
    $mime header get content-disposition
} {form-data {name field2}}


test mime-18.1 {
    non-seekable channel
} {
    set script [list puts -nonewline $message1]
︙︙
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

	cookie serialization
} {
	set mime [.new {} -spec http -string {}]
	$mime cookie set one two
	set res [$mime serialize]
	$mime .destroy
	return $res
	
} "Set-Cookie: one=two\r
\t; HttpOnly\r
\r
"

test mime-19.2 {
	cookie serialization
} {
	set mime [.new {} -spec http -string {}]
	$mime cookie set one two path /three/four
	set res [$mime serialize]
	$mime .destroy
	return $res
	
} "Set-Cookie: one=two\r
\t; path=/three/four\r
\t; HttpOnly\r
\r
"










|













|








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

	cookie serialization
} {
	set mime [.new {} -spec http -string {}]
	$mime cookie set one two
	set res [$mime serialize]
	$mime .destroy
	return $res

} "Set-Cookie: one=two\r
\t; HttpOnly\r
\r
"

test mime-19.2 {
	cookie serialization
} {
	set mime [.new {} -spec http -string {}]
	$mime cookie set one two path /three/four
	set res [$mime serialize]
	$mime .destroy
	return $res

} "Set-Cookie: one=two\r
\t; path=/three/four\r
\t; HttpOnly\r
\r
"
︙︙

This page was generated in about 0.058s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19