Tcl Library Source Code

Check-in [05366363a0]
Login

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

Overview
Comment:Mime: Fixed a wrong version number on the package httpd: The example now uses the uri::direct method where appropriate. Fixed some typos and bugs in the uri::direct method. Fixed places in the code where error pages were asking for the html::header and html::footer methods. They haven't existed for a while.
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:05366363a0de08f8189ed5e3eef81010a0b80e554e7e3b36553aff8d0aca418f
User & Date: hypnotoad 2018-09-11 18:19:49
Context
2018-09-11
18:49
Httpd Module: Servers now pass control off to reply objects via a tailcall. Removed a puts statement in the example httpd app that was logging to stdout check-in: 4b3bc8df0b user: hypnotoad tags: hypnotoad
18:19
Mime: Fixed a wrong version number on the package httpd: The example now uses the uri::direct method where appropriate. Fixed some typos and bugs in the uri::direct method. Fixed places in the code where error pages were asking for the html::header and html::footer methods. They haven't existed for a while. check-in: 05366363a0 user: hypnotoad tags: hypnotoad
17:18
Httpd module: Removed a puts statement injected during debugging. Fixing a typo in logging check-in: c14446b881 user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to examples/httpd/httpd.tcl.

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
...
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
162
163
164
165
166
167
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
    set ::fossil_exe fossil
  }
  if {[llength $args]==0} {
    return $::fossil_exe
  }
  return [exec ${::fossil_exe} {*}$args]
}

clay::define httpd::content.fossil_root {

  method content {} {
    my puts "<HTML><HEAD><TITLE>Local Fossil Repositories</TITLE></HEAD><BODY>"
    global recipe
    my puts "<UL>"
    set dbfiles [::fossil-list]
    foreach file [lsort -dictionary $dbfiles]  {
      dict set result [file rootname [file tail $file]] $file
    }
    foreach {module dbfile} [lsort -dictionary -stride 2 $result] {
      my puts "<li><a HREF=/fossil/$module>$module</a>"
    }
    my puts {</UL></BODY></HTML>}
  }
}


clay::define httpd::content.fossil_node_proxy {

  superclass httpd::content.proxy

  method FileName {} {
    set uri    [my request get REQUEST_URI]
................................................................................
    return [list localhost $port $SCRIPT_NAME]
  }
}

::clay::define ::docserver::server {
  superclass ::httpd::server

  method log args {
    #puts [list {*}$args]
  }

}

::clay::define ::docserver::dynamic {

  method content {} {
    my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
    my puts "<TABLE width=100%>"
    foreach {f v} [my request dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"

    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach {f v} [my clay dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }

}

::clay::define ::docserver::upload {
  superclass ::docserver::dynamic

  method content {} {
    my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
    my puts "<TABLE width=100%>"
    set FORMDAT [my FormData]
    foreach {f v} [my FormData] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach {f v} [my clay dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach part [dict getnull $FORMDAT MIME_PARTS] {
      my puts "<tr><td colspan=10><hr></td></tr>"
      foreach f [::mime::getheader $part -names] {
        my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
      }
      my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }
}
set serveropts [::httpd::server clay get server/]
foreach {f v}  [::clay::args_to_options {*}$::argv] {
  if {[dict exists $serveropts $f]} {
    dict set serveropts $f $v
  }
}
if {[dict exists $serveropts fossil]} {
  set ::fossil_exe [dict get $serveropts fossil]
}

::docserver::server create appmain doc_root $DEMOROOT {*}$argv
appmain plugin basic_url ::httpd::plugin.dict_dispatch
appmain uri add /tcllib* [list mixin {reply httpd::content.file} path [file join $tcllibroot embedded www]]
appmain uri add /fossil [list mixin {reply httpd::content.fossil_root}]












appmain uri add /fossil/* [list mixin {reply httpd::content.fossil_node_proxy}]
appmain uri add /upload [list mixin {reply ::docserver::upload}]
appmain uri add /dynamic [list mixin {reply ::docserver::dynamic}]
appmain uri add /listen [list mixin {reply ::docserver::listen}]
appmain uri add /send   [list mixin {reply ::docserver::send}]






































puts [list LISTENING on [appmain port_listening]]
cron::main







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







 







|
|

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

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












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


22
23
24
25
26
27
28


















29
30
31
32
33
34
35
...
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
152
153
154
155
156




157
158
159
160
161
162
163
164
165
166
167
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
    set ::fossil_exe fossil
  }
  if {[llength $args]==0} {
    return $::fossil_exe
  }
  return [exec ${::fossil_exe} {*}$args]
}



















clay::define httpd::content.fossil_node_proxy {

  superclass httpd::content.proxy

  method FileName {} {
    set uri    [my request get REQUEST_URI]
................................................................................
    return [list localhost $port $SCRIPT_NAME]
  }
}

::clay::define ::docserver::server {
  superclass ::httpd::server

  method debug args {
    puts [list DEBUG {*}$args]
  }





  method log args {




    puts [list LOG {*}$args]
  }







}






























set serveropts [::httpd::server clay get server/]
foreach {f v}  [::clay::args_to_options {*}$::argv] {
  if {[dict exists $serveropts $f]} {
    dict set serveropts $f $v
  }
}
if {[dict exists $serveropts fossil]} {
  set ::fossil_exe [dict get $serveropts fossil]
}

::docserver::server create appmain doc_root $DEMOROOT {*}$argv
appmain plugin basic_url ::httpd::plugin.dict_dispatch
appmain uri add * /tcllib* [list mixin {reply httpd::content.file} path [file join $tcllibroot embedded www]]
appmain uri direct * /fossil {} {
  my puts "<HTML><HEAD><TITLE>Local Fossil Repositories</TITLE></HEAD><BODY>"
  global recipe
  my puts "<UL>"
  set dbfiles [::fossil-list]
  foreach file [lsort -dictionary $dbfiles]  {
    dict set result [file rootname [file tail $file]] $file
  }
  foreach {module dbfile} [lsort -dictionary -stride 2 $result] {
    my puts "<li><a HREF=/fossil/$module>$module</a>"
  }
  my puts {</UL></BODY></HTML>}
}
appmain uri add * /fossil/* [list mixin {reply httpd::content.fossil_node_proxy}]




appmain uri direct * /upload {} {
  my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
  my puts "<TABLE width=100%>"
  set FORMDAT [my FormData]
  foreach {f v} [my FormData] {
      my puts "<tr><th>$f</th><td>$v</td></tr>"
  }
  my puts "<tr><td colspan=10><hr></td></tr>"
  foreach {f v} [my clay dump] {
      my puts "<tr><th>$f</th><td>$v</td></tr>"
  }
  my puts "<tr><td colspan=10><hr></td></tr>"
  foreach part [dict getnull $FORMDAT MIME_PARTS] {
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach f [::mime::getheader $part -names] {
      my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
    }
    my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
  }
  my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
  my puts </TABLE>
  my puts </BODY></HTML>
}
appmain uri direct * /dynamic {} {
  my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
  my puts "<TABLE width=100%>"
  foreach {f v} [my request dump] {
    my puts "<tr><th>$f</th><td>$v</td></tr>"
  }
  my puts "<tr><td colspan=10><hr></td></tr>"
  foreach {f v} [my clay dump] {
    my puts "<tr><th>$f</th><td>$v</td></tr>"
  }
  my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
  my puts </TABLE>
  my puts </BODY></HTML>
}

puts [list LISTENING on [appmain port_listening]]
cron::main

Changes to modules/httpd/build/plugin.tcl.

76
77
78
79
80
81
82
83
84
85
86
87
88

89
90
91
92
93
94
95
96
97
98
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }

  Ensemble uri::direct {vhosts patterns info body} {
    my variable url_patterns url_stream
    set body {}
    if {[dict exists $info superclass]} {
      append body \n "superclass {*}[dict get $info superclass]"
      dict unset info superclass
    }
    append body \n [list method content {} $body]

    set class [namespace current]::${vhosts}/${patterns}
    set class [string map $class {* %} $class]
    ::clay::define $class $body
    dict set info mixin content $class
    my uri add $vhosts $patterns $info
  }
}

::clay::define ::httpd::reply.memchan {
  superclass ::httpd::reply







|

|


|
>

|
|







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }

  Ensemble uri::direct {vhosts patterns info body} {
    my variable url_patterns url_stream
    set cbody {}
    if {[dict exists $info superclass]} {
      append cbody \n "superclass {*}[dict get $info superclass]"
      dict unset info superclass
    }
    append cbody \n [list method content {} $body]

    set class [namespace current]::${vhosts}/${patterns}
    set class [string map {* %} $class]
    ::clay::define $class $cbody
    dict set info mixin content $class
    my uri add $vhosts $patterns $info
  }
}

::clay::define ::httpd::reply.memchan {
  superclass ::httpd::reply

Changes to modules/httpd/build/reply.inc.

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
		set reply_body [my PostData [my request get CONTENT_LENGTH]]
	}
}
clay::define ::test::content.form_handler {
	method content {} {
	  set form [my FormData]
	  my reply set Content-Type {text/html; charset=UTF-8}
    my puts [my html header {My Dynamic Page}]
    my puts "<BODY>"
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"







|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
		set reply_body [my PostData [my request get CONTENT_LENGTH]]
	}
}
clay::define ::test::content.form_handler {
	method content {} {
	  set form [my FormData]
	  my reply set Content-Type {text/html; charset=UTF-8}
    my puts [my html_header {My Dynamic Page}]
    my puts "<BODY>"
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"

Changes to modules/httpd/build/server.tcl.

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
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html footer]
}
      }
      internal_error {
        return {
[my html header "$HTTP_STATUS"]
Error serving <b>[my request get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html footer]
        }
      }
      notfound {
        return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html footer]
        }
      }
    }
  }

  method Thread_start {} {}








|




|




|






|




|

|







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
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html_header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html_footer]
}
      }
      internal_error {
        return {
[my html_header "$HTTP_STATUS"]
Error serving <b>[my request get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html_footer]
        }
      }
      notfound {
        return {
[my html_header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html_footer]
        }
      }
    }
  }

  method Thread_start {} {}

Changes to modules/httpd/httpd.tcl.

858
859
860
861
862
863
864

865
866
867
868
869
870
871
....
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
....
1973
1974
1975
1976
1977
1978
1979

1980
1981

1982
1983
1984
1985
1986
1987
1988
....
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013

2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
      set mimetxt [my HttpHeaders $sock]
      dict set query UUID $uuid
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http [my ServerHeaders $ip $http_request $mimetxt]
      my Headers_Process query
      set reply [my dispatch $query]

    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
................................................................................
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html footer]
}
      }
      internal_error {
        return {
[my html header "$HTTP_STATUS"]
Error serving <b>[my request get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html footer]
        }
      }
      notfound {
        return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html footer]
        }
      }
    }
  }

  method Thread_start {} {}

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

  method Dispatch_Dict {data} {
    my variable url_patterns
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host hostpat} $url_patterns {

      if {![string match $host $vhost]} continue
      foreach {pattern info} $hostpat {

        if {![string match $pattern $uri]} continue
        set buffer $data
        foreach {f v} $info {
          dict set buffer $f $v
        }
        return $buffer
      }
................................................................................
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }

  Ensemble uri::direct {vhosts patterns info body} {
    my variable url_patterns url_stream
    set body {}
    if {[dict exists $info superclass]} {
      append body \n "superclass {*}[dict get $info superclass]"
      dict unset info superclass
    }
    append body \n [list method content {} $body]

    set class [namespace current]::${vhosts}/${patterns}
    set class [string map $class {* %} $class]
    ::clay::define $class $body
    dict set info mixin content $class
    my uri add $vhosts $patterns $info
  }
}

::clay::define ::httpd::reply.memchan {
  superclass ::httpd::reply







>







 







|




|




|






|




|

|







 







>


>







 







|

|


|
>

|
|







858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
....
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
....
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
....
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
      set mimetxt [my HttpHeaders $sock]
      dict set query UUID $uuid
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http [my ServerHeaders $ip $http_request $mimetxt]
      my Headers_Process query
      set reply [my dispatch $query]
      puts [list REPLY $reply]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
................................................................................
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html_header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html_footer]
}
      }
      internal_error {
        return {
[my html_header "$HTTP_STATUS"]
Error serving <b>[my request get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html_footer]
        }
      }
      notfound {
        return {
[my html_header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html_footer]
        }
      }
    }
  }

  method Thread_start {} {}

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

  method Dispatch_Dict {data} {
    my variable url_patterns
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host hostpat} $url_patterns {
      puts [list HOST $vhost | $host [string match $host $vhost]]
      if {![string match $host $vhost]} continue
      foreach {pattern info} $hostpat {
        puts [list URI $uri | $pattern [string match $pattern $uri]]
        if {![string match $pattern $uri]} continue
        set buffer $data
        foreach {f v} $info {
          dict set buffer $f $v
        }
        return $buffer
      }
................................................................................
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }

  Ensemble uri::direct {vhosts patterns info body} {
    my variable url_patterns url_stream
    set cbody {}
    if {[dict exists $info superclass]} {
      append cbody \n "superclass {*}[dict get $info superclass]"
      dict unset info superclass
    }
    append cbody \n [list method content {} $body]

    set class [namespace current]::${vhosts}/${patterns}
    set class [string map {* %} $class]
    ::clay::define $class $cbody
    dict set info mixin content $class
    my uri add $vhosts $patterns $info
  }
}

::clay::define ::httpd::reply.memchan {
  superclass ::httpd::reply

Changes to modules/mime/mime.tcl.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
...
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
....
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
....
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
....
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
....
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
....
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741

# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.5

package require tcl::chan::memchan
package require sha256

package provide mime 1.6

if {[catch {package require Trf 2.0}]} {

    # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
    # Warning!
    # These are a fragile emulations of the more general calling sequence
    # that appears to work with this code here.
................................................................................
                    mime::initializeaux $child \
                        -file $state(file) -root $state(root) \
                        -offset $start -count $count
		    parsepart $child
                }]} {
                    set nochild 1
                    set state(parts) [lrange $state(parts) 0 end-1]
                } 
	    } else {
                mime::initializeaux $child \
                    -file $state(file) -root $state(root) \
                    -offset $start -count $count
		parsepart $child
            }
            seek $state(fd) [set start $pos] start
................................................................................
            }

            mime-version {
                set state(version) $value
            }

            default {
		setinternal $token $mixed $value -mode append 
            }
        }

        if {$blankP} {
            break
        }
        set vline $line
................................................................................
			content-type {
			    if {[string match multipart/* $value]
				&&
				![dict exists $params boundary]
			    } {
				dict set params boundary [boundary]
			    }
			} 
			default {
			    #carry on
			}
		    }
		}
	    }
	    switch $options(-mode) {
................................................................................
#
#     Like copymessage, but produces a string rather than writing the message into a channel.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       The message. 

proc ::mime::buildmessage token {
    global errorCode errorInfo
    # FRINK: nocheck
    upvar 0 $token state

    set openP [info exists state(fd)]
................................................................................
		    [string last ) $note]
                        == [set len [expr {[string length $note] - 1}]]
		} {
                    set note [string range $note 0 [expr {$len - 1}]]
                }
                set friendly $note
            }
            
            if {
		$friendly eq {}
		&&
		[set mbox $state(local)] ne {}
	    } {
                #TODO: this path is not covered by tests
                set mbox [string trim $mbox \"]
................................................................................
# Results:
#    Returns the a string that contains the globally unique identifier
#       that should be used for the Content-ID of an e-mail message.

proc ::mime::uniqueID {} {
    set id [base64 -mode encode -- [
	sha2::sha256 -bin [expr {rand()}][pid][clock clicks][array get state]]]
    return $id 
}


# ::mime::parselexeme --
#
#    Used to implement a lookahead parser.
#







|







 







|







 







|







 







|







 







|







 







|







 







|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
...
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
....
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
....
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
....
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
....
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
....
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741

# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.5

package require tcl::chan::memchan
package require sha256

package provide mime 1.7

if {[catch {package require Trf 2.0}]} {

    # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
    # Warning!
    # These are a fragile emulations of the more general calling sequence
    # that appears to work with this code here.
................................................................................
                    mime::initializeaux $child \
                        -file $state(file) -root $state(root) \
                        -offset $start -count $count
		    parsepart $child
                }]} {
                    set nochild 1
                    set state(parts) [lrange $state(parts) 0 end-1]
                }
	    } else {
                mime::initializeaux $child \
                    -file $state(file) -root $state(root) \
                    -offset $start -count $count
		parsepart $child
            }
            seek $state(fd) [set start $pos] start
................................................................................
            }

            mime-version {
                set state(version) $value
            }

            default {
		setinternal $token $mixed $value -mode append
            }
        }

        if {$blankP} {
            break
        }
        set vline $line
................................................................................
			content-type {
			    if {[string match multipart/* $value]
				&&
				![dict exists $params boundary]
			    } {
				dict set params boundary [boundary]
			    }
			}
			default {
			    #carry on
			}
		    }
		}
	    }
	    switch $options(-mode) {
................................................................................
#
#     Like copymessage, but produces a string rather than writing the message into a channel.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       The message.

proc ::mime::buildmessage token {
    global errorCode errorInfo
    # FRINK: nocheck
    upvar 0 $token state

    set openP [info exists state(fd)]
................................................................................
		    [string last ) $note]
                        == [set len [expr {[string length $note] - 1}]]
		} {
                    set note [string range $note 0 [expr {$len - 1}]]
                }
                set friendly $note
            }

            if {
		$friendly eq {}
		&&
		[set mbox $state(local)] ne {}
	    } {
                #TODO: this path is not covered by tests
                set mbox [string trim $mbox \"]
................................................................................
# Results:
#    Returns the a string that contains the globally unique identifier
#       that should be used for the Content-ID of an e-mail message.

proc ::mime::uniqueID {} {
    set id [base64 -mode encode -- [
	sha2::sha256 -bin [expr {rand()}][pid][clock clicks][array get state]]]
    return $id
}


# ::mime::parselexeme --
#
#    Used to implement a lookahead parser.
#