Context Navigation

mime.tcl @ 8597867d

1941-docker-image-to-testdevel

Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f

Property mode set to 100644

File size: 106.8 KB

Line
1	# mime.tcl - MIME body parts
2	#
3	# (c) 1999-2000 Marshall T. Rose
4	# (c) 2000 Brent Welch
5	# (c) 2000 Sandeep Tamhankar
6	# (c) 2000 Dan Kuchler
7	# (c) 2000-2001 Eric Melski
8	# (c) 2001 Jeff Hobbs
9	# (c) 2001-2007 Andreas Kupries
10	# (c) 2002-2003 David Welton
11	# (c) 2003-2006 Pat Thoyts
12	# (c) 2005 Benjamin Riefenstahl
13	#
14	#
15	# See the file "license.terms" for information on usage and redistribution
16	# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17	#
18	# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
19	# unpublished package of 1999.
20	#
21
22	# new string features and inline scan are used, requiring 8.3.
23	package require Tcl 8.3
24
25	package provide mime 1.5.2
26
27	if {[catch {package require Trf 2.0}]} {
28
29	# Fall-back to tcl-based procedures of base64 and quoted-printable encoders
30	# Warning!
31	# These are a fragile emulations of the more general calling sequence
32	# that appears to work with this code here.
33
34	package require base64 2.0
35	set ::major [lindex [split [package require md5] .] 0]
36
37	# Create these commands in the mime namespace so that they
38	# won't collide with things at the global namespace level
39
40	namespace eval ::mime {
41	proc base64 {-mode what -- chunk} {
42	return [base64::$what $chunk]
43	}
44	proc quoted-printable {-mode what -- chunk} {
45	return [mime::qp_$what $chunk]
46	}
47
48	if {$::major < 2} {
49	# md5 v1, result is hex string ready for use.
50	proc md5 {-- string} {
51	return [md5::md5 $string]
52	}
53	} else {
54	# md5 v2, need option to get hex string
55	proc md5 {-- string} {
56	return [md5::md5 -hex $string]
57	}
58	}
59	}
60
61	unset ::major
62	}
63
64	#
65	# state variables:
66	#
67	# canonicalP: input is in its canonical form
68	# content: type/subtype
69	# params: seralized array of key/value pairs (keys are lower-case)
70	# encoding: transfer encoding
71	# version: MIME-version
72	# header: serialized array of key/value pairs (keys are lower-case)
73	# lowerL: list of header keys, lower-case
74	# mixedL: list of header keys, mixed-case
75	# value: either "file", "parts", or "string"
76	#
77	# file: input file
78	# fd: cached file-descriptor, typically for root
79	# root: token for top-level part, for (distant) subordinates
80	# offset: number of octets from beginning of file/string
81	# count: length in octets of (encoded) content
82	#
83	# parts: list of bodies (tokens)
84	#
85	# string: input string
86	#
87	# cid: last child-id assigned
88	#
89
90
91	namespace eval ::mime {
92	variable mime
93	array set mime { uid 0 cid 0 }
94
95	# 822 lexemes
96	variable addrtokenL [list ";" "," \
97	"<" ">" \
98	":" "." \
99	"(" ")" \
100	"@" "\"" \
101	"\[" "\]" \
102	"\\"]
103	variable addrlexemeL [list LX_SEMICOLON LX_COMMA \
104	LX_LBRACKET LX_RBRACKET \
105	LX_COLON LX_DOT \
106	LX_LPAREN LX_RPAREN \
107	LX_ATSIGN LX_QUOTE \
108	LX_LSQUARE LX_RSQUARE \
109	LX_QUOTE]
110
111	# 2045 lexemes
112	variable typetokenL [list ";" "," \
113	"<" ">" \
114	":" "?" \
115	"(" ")" \
116	"@" "\"" \
117	"\[" "\]" \
118	"=" "/" \
119	"\\"]
120	variable typelexemeL [list LX_SEMICOLON LX_COMMA \
121	LX_LBRACKET LX_RBRACKET \
122	LX_COLON LX_QUESTION \
123	LX_LPAREN LX_RPAREN \
124	LX_ATSIGN LX_QUOTE \
125	LX_LSQUARE LX_RSQUARE \
126	LX_EQUALS LX_SOLIDUS \
127	LX_QUOTE]
128
129	set encList [list \
130	ascii US-ASCII \
131	big5 Big5 \
132	cp1250 Windows-1250 \
133	cp1251 Windows-1251 \
134	cp1252 Windows-1252 \
135	cp1253 Windows-1253 \
136	cp1254 Windows-1254 \
137	cp1255 Windows-1255 \
138	cp1256 Windows-1256 \
139	cp1257 Windows-1257 \
140	cp1258 Windows-1258 \
141	cp437 IBM437 \
142	cp737 "" \
143	cp775 IBM775 \
144	cp850 IBM850 \
145	cp852 IBM852 \
146	cp855 IBM855 \
147	cp857 IBM857 \
148	cp860 IBM860 \
149	cp861 IBM861 \
150	cp862 IBM862 \
151	cp863 IBM863 \
152	cp864 IBM864 \
153	cp865 IBM865 \
154	cp866 IBM866 \
155	cp869 IBM869 \
156	cp874 "" \
157	cp932 "" \
158	cp936 GBK \
159	cp949 "" \
160	cp950 "" \
161	dingbats "" \
162	ebcdic "" \
163	euc-cn EUC-CN \
164	euc-jp EUC-JP \
165	euc-kr EUC-KR \
166	gb12345 GB12345 \
167	gb1988 GB1988 \
168	gb2312 GB2312 \
169	iso2022 ISO-2022 \
170	iso2022-jp ISO-2022-JP \
171	iso2022-kr ISO-2022-KR \
172	iso8859-1 ISO-8859-1 \
173	iso8859-2 ISO-8859-2 \
174	iso8859-3 ISO-8859-3 \
175	iso8859-4 ISO-8859-4 \
176	iso8859-5 ISO-8859-5 \
177	iso8859-6 ISO-8859-6 \
178	iso8859-7 ISO-8859-7 \
179	iso8859-8 ISO-8859-8 \
180	iso8859-9 ISO-8859-9 \
181	iso8859-10 ISO-8859-10 \
182	iso8859-13 ISO-8859-13 \
183	iso8859-14 ISO-8859-14 \
184	iso8859-15 ISO-8859-15 \
185	iso8859-16 ISO-8859-16 \
186	jis0201 JIS_X0201 \
187	jis0208 JIS_C6226-1983 \
188	jis0212 JIS_X0212-1990 \
189	koi8-r KOI8-R \
190	koi8-u KOI8-U \
191	ksc5601 KS_C_5601-1987 \
192	macCentEuro "" \
193	macCroatian "" \
194	macCyrillic "" \
195	macDingbats "" \
196	macGreek "" \
197	macIceland "" \
198	macJapan "" \
199	macRoman "" \
200	macRomania "" \
201	macThai "" \
202	macTurkish "" \
203	macUkraine "" \
204	shiftjis Shift_JIS \
205	symbol "" \
206	tis-620 TIS-620 \
207	unicode "" \
208	utf-8 UTF-8]
209
210	variable encodings
211	array set encodings $encList
212	variable reversemap
213	foreach {enc mimeType} $encList {
214	if {$mimeType != ""} {
215	set reversemap([string tolower $mimeType]) $enc
216	}
217	}
218
219	set encAliasList [list \
220	ascii ANSI_X3.4-1968 \
221	ascii iso-ir-6 \
222	ascii ANSI_X3.4-1986 \
223	ascii ISO_646.irv:1991 \
224	ascii ASCII \
225	ascii ISO646-US \
226	ascii us \
227	ascii IBM367 \
228	ascii cp367 \
229	cp437 cp437 \
230	cp437 437 \
231	cp775 cp775 \
232	cp850 cp850 \
233	cp850 850 \
234	cp852 cp852 \
235	cp852 852 \
236	cp855 cp855 \
237	cp855 855 \
238	cp857 cp857 \
239	cp857 857 \
240	cp860 cp860 \
241	cp860 860 \
242	cp861 cp861 \
243	cp861 861 \
244	cp861 cp-is \
245	cp862 cp862 \
246	cp862 862 \
247	cp863 cp863 \
248	cp863 863 \
249	cp864 cp864 \
250	cp865 cp865 \
251	cp865 865 \
252	cp866 cp866 \
253	cp866 866 \
254	cp869 cp869 \
255	cp869 869 \
256	cp869 cp-gr \
257	cp936 CP936 \
258	cp936 MS936 \
259	cp936 Windows-936 \
260	iso8859-1 ISO_8859-1:1987 \
261	iso8859-1 iso-ir-100 \
262	iso8859-1 ISO_8859-1 \
263	iso8859-1 latin1 \
264	iso8859-1 l1 \
265	iso8859-1 IBM819 \
266	iso8859-1 CP819 \
267	iso8859-2 ISO_8859-2:1987 \
268	iso8859-2 iso-ir-101 \
269	iso8859-2 ISO_8859-2 \
270	iso8859-2 latin2 \
271	iso8859-2 l2 \
272	iso8859-3 ISO_8859-3:1988 \
273	iso8859-3 iso-ir-109 \
274	iso8859-3 ISO_8859-3 \
275	iso8859-3 latin3 \
276	iso8859-3 l3 \
277	iso8859-4 ISO_8859-4:1988 \
278	iso8859-4 iso-ir-110 \
279	iso8859-4 ISO_8859-4 \
280	iso8859-4 latin4 \
281	iso8859-4 l4 \
282	iso8859-5 ISO_8859-5:1988 \
283	iso8859-5 iso-ir-144 \
284	iso8859-5 ISO_8859-5 \
285	iso8859-5 cyrillic \
286	iso8859-6 ISO_8859-6:1987 \
287	iso8859-6 iso-ir-127 \
288	iso8859-6 ISO_8859-6 \
289	iso8859-6 ECMA-114 \
290	iso8859-6 ASMO-708 \
291	iso8859-6 arabic \
292	iso8859-7 ISO_8859-7:1987 \
293	iso8859-7 iso-ir-126 \
294	iso8859-7 ISO_8859-7 \
295	iso8859-7 ELOT_928 \
296	iso8859-7 ECMA-118 \
297	iso8859-7 greek \
298	iso8859-7 greek8 \
299	iso8859-8 ISO_8859-8:1988 \
300	iso8859-8 iso-ir-138 \
301	iso8859-8 ISO_8859-8 \
302	iso8859-8 hebrew \
303	iso8859-9 ISO_8859-9:1989 \
304	iso8859-9 iso-ir-148 \
305	iso8859-9 ISO_8859-9 \
306	iso8859-9 latin5 \
307	iso8859-9 l5 \
308	iso8859-10 iso-ir-157 \
309	iso8859-10 l6 \
310	iso8859-10 ISO_8859-10:1992 \
311	iso8859-10 latin6 \
312	iso8859-14 iso-ir-199 \
313	iso8859-14 ISO_8859-14:1998 \
314	iso8859-14 ISO_8859-14 \
315	iso8859-14 latin8 \
316	iso8859-14 iso-celtic \
317	iso8859-14 l8 \
318	iso8859-15 ISO_8859-15 \
319	iso8859-15 Latin-9 \
320	iso8859-16 iso-ir-226 \
321	iso8859-16 ISO_8859-16:2001 \
322	iso8859-16 ISO_8859-16 \
323	iso8859-16 latin10 \
324	iso8859-16 l10 \
325	jis0201 X0201 \
326	jis0208 iso-ir-87 \
327	jis0208 x0208 \
328	jis0208 JIS_X0208-1983 \
329	jis0212 x0212 \
330	jis0212 iso-ir-159 \
331	ksc5601 iso-ir-149 \
332	ksc5601 KS_C_5601-1989 \
333	ksc5601 KSC5601 \
334	ksc5601 korean \
335	shiftjis MS_Kanji \
336	utf-8 UTF8]
337
338	foreach {enc mimeType} $encAliasList {
339	set reversemap([string tolower $mimeType]) $enc
340	}
341
342	namespace export initialize finalize getproperty \
343	getheader setheader \
344	getbody \
345	copymessage \
346	mapencoding \
347	reversemapencoding \
348	parseaddress \
349	parsedatetime \
350	uniqueID
351	}
352
353	# ::mime::initialize --
354	#
355	# Creates a MIME part, and returnes the MIME token for that part.
356	#
357	# Arguments:
358	# args Args can be any one of the following:
359	# ?-canonical type/subtype
360	# ?-param {key value}?...
361	# ?-encoding value?
362	# ?-header {key value}?... ?
363	# (-file name \| -string value \| -parts {token1 ... tokenN})
364	#
365	# If the -canonical option is present, then the body is in
366	# canonical (raw) form and is found by consulting either the -file,
367	# -string, or -part option.
368	#
369	# In addition, both the -param and -header options may occur zero
370	# or more times to specify "Content-Type" parameters (e.g.,
371	# "charset") and header keyword/values (e.g.,
372	# "Content-Disposition"), respectively.
373	#
374	# Also, -encoding, if present, specifies the
375	# "Content-Transfer-Encoding" when copying the body.
376	#
377	# If the -canonical option is not present, then the MIME part
378	# contained in either the -file or the -string option is parsed,
379	# dynamically generating subordinates as appropriate.
380	#
381	# Results:
382	# An initialized mime token.
383
384	proc ::mime::initialize {args} {
385	global errorCode errorInfo
386
387	variable mime
388
389	set token [namespace current]::[incr mime(uid)]
390	# FRINK: nocheck
391	variable $token
392	upvar 0 $token state
393
394	if {[set code [catch { eval [linsert $args 0 mime::initializeaux $token] } \
395	result]]} {
396	set ecode $errorCode
397	set einfo $errorInfo
398
399	catch { mime::finalize $token -subordinates dynamic }
400
401	return -code $code -errorinfo $einfo -errorcode $ecode $result
402	}
403
404	return $token
405	}
406
407	# ::mime::initializeaux --
408	#
409	# Configures the MIME token created in mime::initialize based on
410	# the arguments that mime::initialize supports.
411	#
412	# Arguments:
413	# token The MIME token to configure.
414	# args Args can be any one of the following:
415	# ?-canonical type/subtype
416	# ?-param {key value}?...
417	# ?-encoding value?
418	# ?-header {key value}?... ?
419	# (-file name \| -string value \| -parts {token1 ... tokenN})
420	#
421	# Results:
422	# Either configures the mime token, or throws an error.
423
424	proc ::mime::initializeaux {token args} {
425	global errorCode errorInfo
426	# FRINK: nocheck
427	variable $token
428	upvar 0 $token state
429
430	array set params [set state(params) ""]
431	set state(encoding) ""
432	set state(version) "1.0"
433
434	set state(header) ""
435	set state(lowerL) ""
436	set state(mixedL) ""
437
438	set state(cid) 0
439
440	set argc [llength $args]
441	for {set argx 0} {$argx < $argc} {incr argx} {
442	set option [lindex $args $argx]
443	if {[incr argx] >= $argc} {
444	error "missing argument to $option"
445	}
446	set value [lindex $args $argx]
447
448	switch -- $option {
449	-canonical {
450	set state(content) [string tolower $value]
451	}
452
453	-param {
454	if {[llength $value] != 2} {
455	error "-param expects a key and a value, not $value"
456	}
457	set lower [string tolower [set mixed [lindex $value 0]]]
458	if {[info exists params($lower)]} {
459	error "the $mixed parameter may be specified at most once"
460	}
461
462	set params($lower) [lindex $value 1]
463	set state(params) [array get params]
464	}
465
466	-encoding {
467	switch -- [set state(encoding) [string tolower $value]] {
468	7bit - 8bit - binary - quoted-printable - base64 {
469	}
470
471	default {
472	error "unknown value for -encoding $state(encoding)"
473	}
474	}
475	}
476
477	-header {
478	if {[llength $value] != 2} {
479	error "-header expects a key and a value, not $value"
480	}
481	set lower [string tolower [set mixed [lindex $value 0]]]
482	if {![string compare $lower content-type]} {
483	error "use -canonical instead of -header $value"
484	}
485	if {![string compare $lower content-transfer-encoding]} {
486	error "use -encoding instead of -header $value"
487	}
488	if {(![string compare $lower content-md5]) \
489	\|\| (![string compare $lower mime-version])} {
490	error "don't go there..."
491	}
492	if {[lsearch -exact $state(lowerL) $lower] < 0} {
493	lappend state(lowerL) $lower
494	lappend state(mixedL) $mixed
495	}
496
497	array set header $state(header)
498	lappend header($lower) [lindex $value 1]
499	set state(header) [array get header]
500	}
501
502	-file {
503	set state(file) $value
504	}
505
506	-parts {
507	set state(parts) $value
508	}
509
510	-string {
511	set state(string) $value
512
513	set state(lines) [split $value "\n"]
514	set state(lines.count) [llength $state(lines)]
515	set state(lines.current) 0
516	}
517
518	-root {
519	# the following are internal options
520
521	set state(root) $value
522	}
523
524	-offset {
525	set state(offset) $value
526	}
527
528	-count {
529	set state(count) $value
530	}
531
532	-lineslist {
533	set state(lines) $value
534	set state(lines.count) [llength $state(lines)]
535	set state(lines.current) 0
536	#state(string) is needed, but will be built when required
537	set state(string) ""
538	}
539
540	default {
541	error "unknown option $option"
542	}
543	}
544	}
545
546	#We only want one of -file, -parts or -string:
547	set valueN 0
548	foreach value [list file parts string] {
549	if {[info exists state($value)]} {
550	set state(value) $value
551	incr valueN
552	}
553	}
554	if {$valueN != 1 && ![info exists state(lines)]} {
555	error "specify exactly one of -file, -parts, or -string"
556	}
557
558	if {[set state(canonicalP) [info exists state(content)]]} {
559	switch -- $state(value) {
560	file {
561	set state(offset) 0
562	}
563
564	parts {
565	switch -glob -- $state(content) {
566	text/*
567	-
568	image/*
569	-
570	audio/*
571	-
572	video/* {
573	error "-canonical $state(content) and -parts do not mix"
574	}
575
576	default {
577	if {[string compare $state(encoding) ""]} {
578	error "-encoding and -parts do not mix"
579	}
580	}
581	}
582	}
583	default {# Go ahead}
584	}
585
586	if {[lsearch -exact $state(lowerL) content-id] < 0} {
587	lappend state(lowerL) content-id
588	lappend state(mixedL) Content-ID
589
590	array set header $state(header)
591	lappend header(content-id) [uniqueID]
592	set state(header) [array get header]
593	}
594
595	set state(version) 1.0
596
597	return
598	}
599
600	if {[string compare $state(params) ""]} {
601	error "-param requires -canonical"
602	}
603	if {[string compare $state(encoding) ""]} {
604	error "-encoding requires -canonical"
605	}
606	if {[string compare $state(header) ""]} {
607	error "-header requires -canonical"
608	}
609	if {[info exists state(parts)]} {
610	error "-parts requires -canonical"
611	}
612
613	if {[set fileP [info exists state(file)]]} {
614	if {[set openP [info exists state(root)]]} {
615	# FRINK: nocheck
616	variable $state(root)
617	upvar 0 $state(root) root
618
619	set state(fd) $root(fd)
620	} else {
621	set state(root) $token
622	set state(fd) [open $state(file) { RDONLY }]
623	set state(offset) 0
624	seek $state(fd) 0 end
625	set state(count) [tell $state(fd)]
626
627	fconfigure $state(fd) -translation binary
628	}
629	}
630
631	set code [catch { mime::parsepart $token } result]
632	set ecode $errorCode
633	set einfo $errorInfo
634
635	if {$fileP} {
636	if {!$openP} {
637	unset state(root)
638	catch { close $state(fd) }
639	}
640	unset state(fd)
641	}
642
643	return -code $code -errorinfo $einfo -errorcode $ecode $result
644	}
645
646	# ::mime::parsepart --
647	#
648	# Parses the MIME headers and attempts to break up the message
649	# into its various parts, creating a MIME token for each part.
650	#
651	# Arguments:
652	# token The MIME token to parse.
653	#
654	# Results:
655	# Throws an error if it has problems parsing the MIME token,
656	# otherwise it just sets up the appropriate variables.
657
658	proc ::mime::parsepart {token} {
659	# FRINK: nocheck
660	variable $token
661	upvar 0 $token state
662
663	if {[set fileP [info exists state(file)]]} {
664	seek $state(fd) [set pos $state(offset)] start
665	set last [expr {$state(offset)+$state(count)-1}]
666	} else {
667	set string $state(string)
668	}
669
670	set vline ""
671	while {1} {
672	set blankP 0
673	if {$fileP} {
674	if {($pos > $last) \|\| ([set x [gets $state(fd) line]] <= 0)} {
675	set blankP 1
676	} else {
677	incr pos [expr {$x+1}]
678	}
679	} else {
680
681	if { $state(lines.current) >= $state(lines.count) } {
682	set blankP 1
683	set line ""
684	} else {
685	set line [lindex $state(lines) $state(lines.current)]
686	incr state(lines.current)
687	set x [string length $line]
688	if { $x == 0 } { set blankP 1 }
689	}
690
691	}
692
693	if {(!$blankP) && ([string last "\r" $line] == [expr {$x-1}])} {
694
695	set line [string range $line 0 [expr {$x-2}]]
696	if {$x == 1} {
697	set blankP 1
698	}
699	}
700
701	if {(!$blankP) \
702	&& (([string first " " $line] == 0) \
703	\|\| ([string first "\t" $line] == 0))} {
704	append vline "\n" $line
705	continue
706	}
707
708	if {![string compare $vline ""]} {
709	if {$blankP} {
710	break
711	}
712
713	set vline $line
714	continue
715	}
716
717	if {([set x [string first ":" $vline]] <= 0) \
718	\|\| (![string compare \
719	[set mixed \
720	[string trimright \
721	[string range \
722	$vline 0 [expr {$x-1}]]]] \
723	""])} {
724	error "improper line in header: $vline"
725	}
726	set value [string trim [string range $vline [expr {$x+1}] end]]
727	switch -- [set lower [string tolower $mixed]] {
728	content-type {
729	if {[info exists state(content)]} {
730	error "multiple Content-Type fields starting with $vline"
731	}
732
733	if {![catch { set x [parsetype $token $value] }]} {
734	set state(content) [lindex $x 0]
735	set state(params) [lindex $x 1]
736	}
737	}
738
739	content-md5 {
740	}
741
742	content-transfer-encoding {
743	if {([string compare $state(encoding) ""]) \
744	&& ([string compare $state(encoding) \
745	[string tolower $value]])} {
746	error "multiple Content-Transfer-Encoding fields starting with $vline"
747	}
748
749	set state(encoding) [string tolower $value]
750	}
751
752	mime-version {
753	set state(version) $value
754	}
755
756	default {
757	if {[lsearch -exact $state(lowerL) $lower] < 0} {
758	lappend state(lowerL) $lower
759	lappend state(mixedL) $mixed
760	}
761
762	array set header $state(header)
763	lappend header($lower) $value
764	set state(header) [array get header]
765	}
766	}
767
768	if {$blankP} {
769	break
770	}
771	set vline $line
772	}
773
774	if {![info exists state(content)]} {
775	set state(content) text/plain
776	set state(params) [list charset us-ascii]
777	}
778
779	if {![string match multipart/* $state(content)]} {
780	if {$fileP} {
781	set x [tell $state(fd)]
782	incr state(count) [expr {$state(offset)-$x}]
783	set state(offset) $x
784	} else {
785	# rebuild string, this is cheap and needed by other functions
786	set state(string) [join [lrange $state(lines) \
787	$state(lines.current) end] "\n"]
788	}
789
790	if {[string match message/* $state(content)]} {
791	# FRINK: nocheck
792	variable [set child $token-[incr state(cid)]]
793
794	set state(value) parts
795	set state(parts) $child
796	if {$fileP} {
797	mime::initializeaux $child \
798	-file $state(file) -root $state(root) \
799	-offset $state(offset) -count $state(count)
800	} else {
801	mime::initializeaux $child \
802	-lineslist [lrange $state(lines) \
803	$state(lines.current) end]
804	}
805	}
806
807	return
808	}
809
810	set state(value) parts
811
812	set boundary ""
813	foreach {k v} $state(params) {
814	if {![string compare $k boundary]} {
815	set boundary $v
816	break
817	}
818	}
819	if {![string compare $boundary ""]} {
820	error "boundary parameter is missing in $state(content)"
821	}
822	if {![string compare [string trim $boundary] ""]} {
823	error "boundary parameter is empty in $state(content)"
824	}
825
826	if {$fileP} {
827	set pos [tell $state(fd)]
828	}
829
830	set inP 0
831	set moreP 1
832	while {$moreP} {
833	if {$fileP} {
834	if {$pos > $last} {
835	error "termination string missing in $state(content)"
836	set line "--$boundary--"
837	} else {
838	if {[set x [gets $state(fd) line]] < 0} {
839	error "end-of-file encountered while parsing $state(content)"
840	}
841	}
842	incr pos [expr {$x+1}]
843	} else {
844
845	if { $state(lines.current) >= $state(lines.count) } {
846	error "end-of-string encountered while parsing $state(content)"
847	} else {
848	set line [lindex $state(lines) $state(lines.current)]
849	incr state(lines.current)
850	set x [string length $line]
851	}
852
853	set x [string length $line]
854	}
855	if {[string last "\r" $line] == [expr {$x-1}]} {
856	set line [string range $line 0 [expr {$x-2}]]
857	}
858
859	if {[string first "--$boundary" $line] != 0} {
860	if {$inP && !$fileP} {
861	lappend start $line
862	}
863
864	continue
865	}
866
867	if {!$inP} {
868	if {![string compare $line "--$boundary"]} {
869	set inP 1
870	if {$fileP} {
871	set start $pos
872	} else {
873	set start [list]
874	}
875	}
876
877	continue
878	}
879
880	if {([set moreP [string compare $line "--$boundary--"]]) \
881	&& ([string compare $line "--$boundary"])} {
882	if {$inP && !$fileP} {
883	lappend start $line
884	}
885	continue
886	}
887	# FRINK: nocheck
888	variable [set child $token-[incr state(cid)]]
889
890	lappend state(parts) $child
891
892	if {$fileP} {
893	if {[set count [expr {$pos-($start+$x+3)}]] < 0} {
894	set count 0
895	}
896
897	mime::initializeaux $child \
898	-file $state(file) -root $state(root) \
899	-offset $start -count $count
900
901	seek $state(fd) [set start $pos] start
902	} else {
903	mime::initializeaux $child -lineslist $start
904	set start ""
905	}
906	}
907	}
908
909	# ::mime::parsetype --
910	#
911	# Parses the string passed in and identifies the content-type and
912	# params strings.
913	#
914	# Arguments:
915	# token The MIME token to parse.
916	# string The content-type string that should be parsed.
917	#
918	# Results:
919	# Returns the content and params for the string as a two element
920	# tcl list.
921
922	proc ::mime::parsetype {token string} {
923	global errorCode errorInfo
924	# FRINK: nocheck
925	variable $token
926	upvar 0 $token state
927
928	variable typetokenL
929	variable typelexemeL
930
931	set state(input) $string
932	set state(buffer) ""
933	set state(lastC) LX_END
934	set state(comment) ""
935	set state(tokenL) $typetokenL
936	set state(lexemeL) $typelexemeL
937
938	set code [catch { mime::parsetypeaux $token $string } result]
939	set ecode $errorCode
940	set einfo $errorInfo
941
942	unset state(input) \
943	state(buffer) \
944	state(lastC) \
945	state(comment) \
946	state(tokenL) \
947	state(lexemeL)
948
949	return -code $code -errorinfo $einfo -errorcode $ecode $result
950	}
951
952	# ::mime::parsetypeaux --
953	#
954	# A helper function for mime::parsetype. Parses the specified
955	# string looking for the content type and params.
956	#
957	# Arguments:
958	# token The MIME token to parse.
959	# string The content-type string that should be parsed.
960	#
961	# Results:
962	# Returns the content and params for the string as a two element
963	# tcl list.
964
965	proc ::mime::parsetypeaux {token string} {
966	# FRINK: nocheck
967	variable $token
968	upvar 0 $token state
969
970	if {[string compare [parselexeme $token] LX_ATOM]} {
971	error [format "expecting type (found %s)" $state(buffer)]
972	}
973	set type [string tolower $state(buffer)]
974
975	switch -- [parselexeme $token] {
976	LX_SOLIDUS {
977	}
978
979	LX_END {
980	if {[string compare $type message]} {
981	error "expecting type/subtype (found $type)"
982	}
983
984	return [list message/rfc822 ""]
985	}
986
987	default {
988	error [format "expecting \"/\" (found %s)" $state(buffer)]
989	}
990	}
991
992	if {[string compare [parselexeme $token] LX_ATOM]} {
993	error [format "expecting subtype (found %s)" $state(buffer)]
994	}
995	append type [string tolower /$state(buffer)]
996
997	array set params ""
998	while {1} {
999	switch -- [parselexeme $token] {
1000	LX_END {
1001	return [list $type [array get params]]
1002	}
1003
1004	LX_SEMICOLON {
1005	}
1006
1007	default {
1008	error [format "expecting \";\" (found %s)" $state(buffer)]
1009	}
1010	}
1011
1012	switch -- [parselexeme $token] {
1013	LX_END {
1014	return [list $type [array get params]]
1015	}
1016
1017	LX_ATOM {
1018	}
1019
1020	default {
1021	error [format "expecting attribute (found %s)" $state(buffer)]
1022	}
1023	}
1024
1025	set attribute [string tolower $state(buffer)]
1026
1027	if {[string compare [parselexeme $token] LX_EQUALS]} {
1028	error [format "expecting \"=\" (found %s)" $state(buffer)]
1029	}
1030
1031	switch -- [parselexeme $token] {
1032	LX_ATOM {
1033	}
1034
1035	LX_QSTRING {
1036	set state(buffer) \
1037	[string range $state(buffer) 1 \
1038	[expr {[string length $state(buffer)]-2}]]
1039	}
1040
1041	default {
1042	error [format "expecting value (found %s)" $state(buffer)]
1043	}
1044	}
1045	set params($attribute) $state(buffer)
1046	}
1047	}
1048
1049	# ::mime::finalize --
1050	#
1051	# mime::finalize destroys a MIME part.
1052	#
1053	# If the -subordinates option is present, it specifies which
1054	# subordinates should also be destroyed. The default value is
1055	# "dynamic".
1056	#
1057	# Arguments:
1058	# token The MIME token to parse.
1059	# args Args can be optionally be of the following form:
1060	# ?-subordinates "all" \| "dynamic" \| "none"?
1061	#
1062	# Results:
1063	# Returns an empty string.
1064
1065	proc ::mime::finalize {token args} {
1066	# FRINK: nocheck
1067	variable $token
1068	upvar 0 $token state
1069
1070	array set options [list -subordinates dynamic]
1071	array set options $args
1072
1073	switch -- $options(-subordinates) {
1074	all {
1075	if {![string compare $state(value) parts]} {
1076	foreach part $state(parts) {
1077	eval [linsert $args 0 mime::finalize $part]
1078	}
1079	}
1080	}
1081
1082	dynamic {
1083	for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
1084	eval [linsert $args 0 mime::finalize $token-$cid]
1085	}
1086	}
1087
1088	none {
1089	}
1090
1091	default {
1092	error "unknown value for -subordinates $options(-subordinates)"
1093	}
1094	}
1095
1096	foreach name [array names state] {
1097	unset state($name)
1098	}
1099	# FRINK: nocheck
1100	unset $token
1101	}
1102
1103	# ::mime::getproperty --
1104	#
1105	# mime::getproperty returns the properties of a MIME part.
1106	#
1107	# The properties are:
1108	#
1109	# property value
1110	# ======== =====
1111	# content the type/subtype describing the content
1112	# encoding the "Content-Transfer-Encoding"
1113	# params a list of "Content-Type" parameters
1114	# parts a list of tokens for the part's subordinates
1115	# size the approximate size of the content (unencoded)
1116	#
1117	# The "parts" property is present only if the MIME part has
1118	# subordinates.
1119	#
1120	# If mime::getproperty is invoked with the name of a specific
1121	# property, then the corresponding value is returned; instead, if
1122	# -names is specified, a list of all properties is returned;
1123	# otherwise, a serialized array of properties and values is returned.
1124	#
1125	# Arguments:
1126	# token The MIME token to parse.
1127	# property One of 'content', 'encoding', 'params', 'parts', and
1128	# 'size'. Defaults to returning a serialized array of
1129	# properties and values.
1130	#
1131	# Results:
1132	# Returns the properties of a MIME part
1133
1134	proc ::mime::getproperty {token {property ""}} {
1135	# FRINK: nocheck
1136	variable $token
1137	upvar 0 $token state
1138
1139	switch -- $property {
1140	"" {
1141	array set properties [list content $state(content) \
1142	encoding $state(encoding) \
1143	params $state(params) \
1144	size [getsize $token]]
1145	if {[info exists state(parts)]} {
1146	set properties(parts) $state(parts)
1147	}
1148
1149	return [array get properties]
1150	}
1151
1152	-names {
1153	set names [list content encoding params]
1154	if {[info exists state(parts)]} {
1155	lappend names parts
1156	}
1157
1158	return $names
1159	}
1160
1161	content
1162	-
1163	encoding
1164	-
1165	params {
1166	return $state($property)
1167	}
1168
1169	parts {
1170	if {![info exists state(parts)]} {
1171	error "MIME part is a leaf"
1172	}
1173
1174	return $state(parts)
1175	}
1176
1177	size {
1178	return [getsize $token]
1179	}
1180
1181	default {
1182	error "unknown property $property"
1183	}
1184	}
1185	}
1186
1187	# ::mime::getsize --
1188	#
1189	# Determine the size (in bytes) of a MIME part/token
1190	#
1191	# Arguments:
1192	# token The MIME token to parse.
1193	#
1194	# Results:
1195	# Returns the size in bytes of the MIME token.
1196
1197	proc ::mime::getsize {token} {
1198	# FRINK: nocheck
1199	variable $token
1200	upvar 0 $token state
1201
1202	switch -- $state(value)/$state(canonicalP) {
1203	file/0 {
1204	set size $state(count)
1205	}
1206
1207	file/1 {
1208	return [file size $state(file)]
1209	}
1210
1211	parts/0
1212	-
1213	parts/1 {
1214	set size 0
1215	foreach part $state(parts) {
1216	incr size [getsize $part]
1217	}
1218
1219	return $size
1220	}
1221
1222	string/0 {
1223	set size [string length $state(string)]
1224	}
1225
1226	string/1 {
1227	return [string length $state(string)]
1228	}
1229	default {
1230	error "Unknown combination \"$state(value)/$state(canonicalP)\""
1231	}
1232	}
1233
1234	if {![string compare $state(encoding) base64]} {
1235	set size [expr {($size*3+2)/4}]
1236	}
1237
1238	return $size
1239	}
1240
1241	# ::mime::getheader --
1242	#
1243	# mime::getheader returns the header of a MIME part.
1244	#
1245	# A header consists of zero or more key/value pairs. Each value is a
1246	# list containing one or more strings.
1247	#
1248	# If mime::getheader is invoked with the name of a specific key, then
1249	# a list containing the corresponding value(s) is returned; instead,
1250	# if -names is specified, a list of all keys is returned; otherwise, a
1251	# serialized array of keys and values is returned. Note that when a
1252	# key is specified (e.g., "Subject"), the list returned usually
1253	# contains exactly one string; however, some keys (e.g., "Received")
1254	# often occur more than once in the header, accordingly the list
1255	# returned usually contains more than one string.
1256	#
1257	# Arguments:
1258	# token The MIME token to parse.
1259	# key Either a key or '-names'. If it is '-names' a list
1260	# of all keys is returned.
1261	#
1262	# Results:
1263	# Returns the header of a MIME part.
1264
1265	proc ::mime::getheader {token {key ""}} {
1266	# FRINK: nocheck
1267	variable $token
1268	upvar 0 $token state
1269
1270	array set header $state(header)
1271	switch -- $key {
1272	"" {
1273	set result ""
1274	foreach lower $state(lowerL) mixed $state(mixedL) {
1275	lappend result $mixed $header($lower)
1276	}
1277	return $result
1278	}
1279
1280	-names {
1281	return $state(mixedL)
1282	}
1283
1284	default {
1285	set lower [string tolower [set mixed $key]]
1286
1287	if {![info exists header($lower)]} {
1288	error "key $mixed not in header"
1289	}
1290	return $header($lower)
1291	}
1292	}
1293	}
1294
1295	# ::mime::setheader --
1296	#
1297	# mime::setheader writes, appends to, or deletes the value associated
1298	# with a key in the header.
1299	#
1300	# The value for -mode is one of:
1301	#
1302	# write: the key/value is either created or overwritten (the
1303	# default);
1304	#
1305	# append: a new value is appended for the key (creating it as
1306	# necessary); or,
1307	#
1308	# delete: all values associated with the key are removed (the
1309	# "value" parameter is ignored).
1310	#
1311	# Regardless, mime::setheader returns the previous value associated
1312	# with the key.
1313	#
1314	# Arguments:
1315	# token The MIME token to parse.
1316	# key The name of the key whose value should be set.
1317	# value The value for the header key to be set to.
1318	# args An optional argument of the form:
1319	# ?-mode "write" \| "append" \| "delete"?
1320	#
1321	# Results:
1322	# Returns previous value associated with the specified key.
1323
1324	proc ::mime::setheader {token key value args} {
1325	# FRINK: nocheck
1326	variable $token
1327	upvar 0 $token state
1328
1329	array set options [list -mode write]
1330	array set options $args
1331
1332	switch -- [set lower [string tolower $key]] {
1333	content-md5
1334	-
1335	content-type
1336	-
1337	content-transfer-encoding
1338	-
1339	mime-version {
1340	error "key $key may not be set"
1341	}
1342	default {# Skip key}
1343	}
1344
1345	array set header $state(header)
1346	if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} {
1347	if {![string compare $options(-mode) delete]} {
1348	error "key $key not in header"
1349	}
1350
1351	lappend state(lowerL) $lower
1352	lappend state(mixedL) $key
1353
1354	set result ""
1355	} else {
1356	set result $header($lower)
1357	}
1358	switch -- $options(-mode) {
1359	append {
1360	lappend header($lower) $value
1361	}
1362
1363	delete {
1364	unset header($lower)
1365	set state(lowerL) [lreplace $state(lowerL) $x $x]
1366	set state(mixedL) [lreplace $state(mixedL) $x $x]
1367	}
1368
1369	write {
1370	set header($lower) [list $value]
1371	}
1372
1373	default {
1374	error "unknown value for -mode $options(-mode)"
1375	}
1376	}
1377
1378	set state(header) [array get header]
1379
1380	return $result
1381	}
1382
1383	# ::mime::getbody --
1384	#
1385	# mime::getbody returns the body of a leaf MIME part in canonical form.
1386	#
1387	# If the -command option is present, then it is repeatedly invoked
1388	# with a fragment of the body as this:
1389	#
1390	# uplevel #0 $callback [list "data" $fragment]
1391	#
1392	# (The -blocksize option, if present, specifies the maximum size of
1393	# each fragment passed to the callback.)
1394	# When the end of the body is reached, the callback is invoked as:
1395	#
1396	# uplevel #0 $callback "end"
1397	#
1398	# Alternatively, if an error occurs, the callback is invoked as:
1399	#
1400	# uplevel #0 $callback [list "error" reason]
1401	#
1402	# Regardless, the return value of the final invocation of the callback
1403	# is propagated upwards by mime::getbody.
1404	#
1405	# If the -command option is absent, then the return value of
1406	# mime::getbody is a string containing the MIME part's entire body.
1407	#
1408	# Arguments:
1409	# token The MIME token to parse.
1410	# args Optional arguments of the form:
1411	# ?-decode? ?-command callback ?-blocksize octets? ?
1412	#
1413	# Results:
1414	# Returns a string containing the MIME part's entire body, or
1415	# if '-command' is specified, the return value of the command
1416	# is returned.
1417
1418	proc ::mime::getbody {token args} {
1419	global errorCode errorInfo
1420	# FRINK: nocheck
1421	variable $token
1422	upvar 0 $token state
1423
1424	set decode 0
1425	if {[set pos [lsearch -exact $args -decode]] >= 0} {
1426	set decode 1
1427	set args [lreplace $args $pos $pos]
1428	}
1429
1430	array set options [list -command [list mime::getbodyaux $token] \
1431	-blocksize 4096]
1432	array set options $args
1433	if {$options(-blocksize) < 1} {
1434	error "-blocksize expects a positive integer, not $options(-blocksize)"
1435	}
1436
1437	set code 0
1438	set ecode ""
1439	set einfo ""
1440
1441	switch -- $state(value)/$state(canonicalP) {
1442	file/0 {
1443	set fd [open $state(file) { RDONLY }]
1444
1445	set code [catch {
1446	fconfigure $fd -translation binary
1447	seek $fd [set pos $state(offset)] start
1448	set last [expr {$state(offset)+$state(count)-1}]
1449
1450	set fragment ""
1451	while {$pos <= $last} {
1452	if {[set cc [expr {($last-$pos)+1}]] \
1453	> $options(-blocksize)} {
1454	set cc $options(-blocksize)
1455	}
1456	incr pos [set len \
1457	[string length [set chunk [read $fd $cc]]]]
1458	switch -exact -- $state(encoding) {
1459	base64
1460	-
1461	quoted-printable {
1462	if {([set x [string last "\n" $chunk]] > 0) \
1463	&& ($x+1 != $len)} {
1464	set chunk [string range $chunk 0 $x]
1465	seek $fd [incr pos [expr {($x+1)-$len}]] start
1466	}
1467	set chunk [$state(encoding) -mode decode \
1468	-- $chunk]
1469	}
1470	7bit - 8bit - binary - "" {
1471	# Bugfix for [#477088]
1472	# Go ahead, leave chunk alone
1473	}
1474	default {
1475	error "Can't handle content encoding \"$state(encoding)\""
1476	}
1477	}
1478	append fragment $chunk
1479
1480	set cc [expr {$options(-blocksize)-1}]
1481	while {[string length $fragment] > $options(-blocksize)} {
1482	uplevel #0 $options(-command) \
1483	[list data \
1484	[string range $fragment 0 $cc]]
1485
1486	set fragment [string range \
1487	$fragment $options(-blocksize) \
1488	end]
1489	}
1490	}
1491	if {[string length $fragment] > 0} {
1492	uplevel #0 $options(-command) [list data $fragment]
1493	}
1494	} result]
1495	set ecode $errorCode
1496	set einfo $errorInfo
1497
1498	catch { close $fd }
1499	}
1500
1501	file/1 {
1502	set fd [open $state(file) { RDONLY }]
1503
1504	set code [catch {
1505	fconfigure $fd -translation binary
1506
1507	while {[string length \
1508	[set fragment \
1509	[read $fd $options(-blocksize)]]] > 0} {
1510	uplevel #0 $options(-command) [list data $fragment]
1511	}
1512	} result]
1513	set ecode $errorCode
1514	set einfo $errorInfo
1515
1516	catch { close $fd }
1517	}
1518
1519	parts/0
1520	-
1521	parts/1 {
1522	error "MIME part isn't a leaf"
1523	}
1524
1525	string/0
1526	-
1527	string/1 {
1528	switch -- $state(encoding)/$state(canonicalP) {
1529	base64/0
1530	-
1531	quoted-printable/0 {
1532	set fragment [$state(encoding) -mode decode \
1533	-- $state(string)]
1534	}
1535
1536	default {
1537	# Not a bugfix for [#477088], but clarification
1538	# This handles no-encoding, 7bit, 8bit, and binary.
1539	set fragment $state(string)
1540	}
1541	}
1542
1543	set code [catch {
1544	set cc [expr {$options(-blocksize)-1}]
1545	while {[string length $fragment] > $options(-blocksize)} {
1546	uplevel #0 $options(-command) \
1547	[list data [string range $fragment 0 $cc]]
1548
1549	set fragment [string range $fragment \
1550	$options(-blocksize) end]
1551	}
1552	if {[string length $fragment] > 0} {
1553	uplevel #0 $options(-command) [list data $fragment]
1554	}
1555	} result]
1556	set ecode $errorCode
1557	set einfo $errorInfo
1558	}
1559	default {
1560	error "Unknown combination \"$state(value)/$state(canonicalP)\""
1561	}
1562	}
1563
1564	set code [catch {
1565	if {$code} {
1566	uplevel #0 $options(-command) [list error $result]
1567	} else {
1568	uplevel #0 $options(-command) [list end]
1569	}
1570	} result]
1571	set ecode $errorCode
1572	set einfo $errorInfo
1573
1574	if {$code} {
1575	return -code $code -errorinfo $einfo -errorcode $ecode $result
1576	}
1577
1578	if {$decode} {
1579	array set params [mime::getproperty $token params]
1580
1581	if {[info exists params(charset)]} {
1582	set charset $params(charset)
1583	} else {
1584	set charset US-ASCII
1585	}
1586
1587	set enc [reversemapencoding $charset]
1588	if {$enc != ""} {
1589	set result [::encoding convertfrom $enc $result]
1590	} else {
1591	return -code error "-decode failed: can't reversemap charset $charset"
1592	}
1593	}
1594
1595	return $result
1596	}
1597
1598	# ::mime::getbodyaux --
1599	#
1600	# Builds up the body of the message, fragment by fragment. When
1601	# the entire message has been retrieved, it is returned.
1602	#
1603	# Arguments:
1604	# token The MIME token to parse.
1605	# reason One of 'data', 'end', or 'error'.
1606	# fragment The section of data data fragment to extract a
1607	# string from.
1608	#
1609	# Results:
1610	# Returns nothing, except when called with the 'end' argument
1611	# in which case it returns a string that contains all of the
1612	# data that 'getbodyaux' has been called with. Will throw an
1613	# error if it is called with the reason of 'error'.
1614
1615	proc ::mime::getbodyaux {token reason {fragment ""}} {
1616	# FRINK: nocheck
1617	variable $token
1618	upvar 0 $token state
1619
1620	switch -- $reason {
1621	data {
1622	append state(getbody) $fragment
1623	return ""
1624	}
1625
1626	end {
1627	if {[info exists state(getbody)]} {
1628	set result $state(getbody)
1629	unset state(getbody)
1630	} else {
1631	set result ""
1632	}
1633
1634	return $result
1635	}
1636
1637	error {
1638	catch { unset state(getbody) }
1639	error $reason
1640	}
1641
1642	default {
1643	error "Unknown reason \"$reason\""
1644	}
1645	}
1646	}
1647
1648	# ::mime::copymessage --
1649	#
1650	# mime::copymessage copies the MIME part to the specified channel.
1651	#
1652	# mime::copymessage operates synchronously, and uses fileevent to
1653	# allow asynchronous operations to proceed independently.
1654	#
1655	# Arguments:
1656	# token The MIME token to parse.
1657	# channel The channel to copy the message to.
1658	#
1659	# Results:
1660	# Returns nothing unless an error is thrown while the message
1661	# is being written to the channel.
1662
1663	proc ::mime::copymessage {token channel} {
1664	global errorCode errorInfo
1665	# FRINK: nocheck
1666	variable $token
1667	upvar 0 $token state
1668
1669	set openP [info exists state(fd)]
1670
1671	set code [catch { mime::copymessageaux $token $channel } result]
1672	set ecode $errorCode
1673	set einfo $errorInfo
1674
1675	if {(!$openP) && ([info exists state(fd)])} {
1676	if {![info exists state(root)]} {
1677	catch { close $state(fd) }
1678	}
1679	unset state(fd)
1680	}
1681
1682	return -code $code -errorinfo $einfo -errorcode $ecode $result
1683	}
1684
1685	# ::mime::copymessageaux --
1686	#
1687	# mime::copymessageaux copies the MIME part to the specified channel.
1688	#
1689	# Arguments:
1690	# token The MIME token to parse.
1691	# channel The channel to copy the message to.
1692	#
1693	# Results:
1694	# Returns nothing unless an error is thrown while the message
1695	# is being written to the channel.
1696
1697	proc ::mime::copymessageaux {token channel} {
1698	# FRINK: nocheck
1699	variable $token
1700	upvar 0 $token state
1701
1702	array set header $state(header)
1703
1704	if {[string compare $state(version) ""]} {
1705	puts $channel "MIME-Version: $state(version)"
1706	}
1707	foreach lower $state(lowerL) mixed $state(mixedL) {
1708	foreach value $header($lower) {
1709	puts $channel "$mixed: $value"
1710	}
1711	}
1712	if {(!$state(canonicalP)) \
1713	&& ([string compare [set encoding $state(encoding)] ""])} {
1714	puts $channel "Content-Transfer-Encoding: $encoding"
1715	}
1716
1717	puts -nonewline $channel "Content-Type: $state(content)"
1718	set boundary ""
1719	foreach {k v} $state(params) {
1720	if {![string compare $k boundary]} {
1721	set boundary $v
1722	}
1723
1724	puts -nonewline $channel ";\n $k=\"$v\""
1725	}
1726
1727	set converter ""
1728	set encoding ""
1729	if {[string compare $state(value) parts]} {
1730	puts $channel ""
1731
1732	if {$state(canonicalP)} {
1733	if {![string compare [set encoding $state(encoding)] ""]} {
1734	set encoding [encoding $token]
1735	}
1736	if {[string compare $encoding ""]} {
1737	puts $channel "Content-Transfer-Encoding: $encoding"
1738	}
1739	switch -- $encoding {
1740	base64
1741	-
1742	quoted-printable {
1743	set converter $encoding
1744	}
1745	7bit - 8bit - binary - "" {
1746	# Bugfix for [#477088], also [#539952]
1747	# Go ahead
1748	}
1749	default {
1750	error "Can't handle content encoding \"$encoding\""
1751	}
1752	}
1753	}
1754	} elseif {([string match multipart/* $state(content)]) \
1755	&& (![string compare $boundary ""])} {
1756	# we're doing everything in one pass...
1757	set key [clock seconds]$token[info hostname][array get state]
1758	set seqno 8
1759	while {[incr seqno -1] >= 0} {
1760	set key [md5 -- $key]
1761	}
1762	set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
1763
1764	puts $channel ";\n boundary=\"$boundary\""
1765	} else {
1766	puts $channel ""
1767	}
1768
1769	if {[info exists state(error)]} {
1770	unset state(error)
1771	}
1772
1773	switch -- $state(value) {
1774	file {
1775	set closeP 1
1776	if {[info exists state(root)]} {
1777	# FRINK: nocheck
1778	variable $state(root)
1779	upvar 0 $state(root) root
1780
1781	if {[info exists root(fd)]} {
1782	set fd $root(fd)
1783	set closeP 0
1784	} else {
1785	set fd [set state(fd) \
1786	[open $state(file) { RDONLY }]]
1787	}
1788	set size $state(count)
1789	} else {
1790	set fd [set state(fd) [open $state(file) { RDONLY }]]
1791	# read until eof
1792	set size -1
1793	}
1794	seek $fd $state(offset) start
1795	if {$closeP} {
1796	fconfigure $fd -translation binary
1797	}
1798
1799	puts $channel ""
1800
1801	while {($size != 0) && (![eof $fd])} {
1802	if {$size < 0 \|\| $size > 32766} {
1803	set X [read $fd 32766]
1804	} else {
1805	set X [read $fd $size]
1806	}
1807	if {$size > 0} {
1808	set size [expr {$size - [string length $X]}]
1809	}
1810	if {[string compare $converter ""]} {
1811	puts -nonewline $channel [$converter -mode encode -- $X]
1812	} else {
1813	puts -nonewline $channel $X
1814	}
1815	}
1816
1817	if {$closeP} {
1818	catch { close $state(fd) }
1819	unset state(fd)
1820	}
1821	}
1822
1823	parts {
1824	if {(![info exists state(root)]) \
1825	&& ([info exists state(file)])} {
1826	set state(fd) [open $state(file) { RDONLY }]
1827	fconfigure $state(fd) -translation binary
1828	}
1829
1830	switch -glob -- $state(content) {
1831	message/* {
1832	puts $channel ""
1833	foreach part $state(parts) {
1834	mime::copymessage $part $channel
1835	break
1836	}
1837	}
1838
1839	default {
1840	# Note RFC 2046: See buildmessageaux for details.
1841
1842	foreach part $state(parts) {
1843	puts $channel "\n--$boundary"
1844	mime::copymessage $part $channel
1845	}
1846	puts $channel "\n--$boundary--"
1847	}
1848	}
1849
1850	if {[info exists state(fd)]} {
1851	catch { close $state(fd) }
1852	unset state(fd)
1853	}
1854	}
1855
1856	string {
1857	if {[catch { fconfigure $channel -buffersize } blocksize]} {
1858	set blocksize 4096
1859	} elseif {$blocksize < 512} {
1860	set blocksize 512
1861	}
1862	set blocksize [expr {($blocksize/4)*3}]
1863
1864	# [893516]
1865	fconfigure $channel -buffersize $blocksize
1866
1867	puts $channel ""
1868
1869	if {[string compare $converter ""]} {
1870	puts -nonewline $channel [$converter -mode encode -- $state(string)]
1871	} else {
1872	puts -nonewline $channel $state(string)
1873	}
1874	}
1875	default {
1876	error "Unknown value \"$state(value)\""
1877	}
1878	}
1879
1880	flush $channel
1881
1882	if {[info exists state(error)]} {
1883	error $state(error)
1884	}
1885	}
1886
1887	# ::mime::buildmessage --
1888	#
1889	# The following is a clone of the copymessage code to build up the
1890	# result in memory, and, unfortunately, without using a memory channel.
1891	# I considered parameterizing the "puts" calls in copy message, but
1892	# the need for this procedure may go away, so I'm living with it for
1893	# the moment.
1894	#
1895	# Arguments:
1896	# token The MIME token to parse.
1897	#
1898	# Results:
1899	# Returns the message that has been built up in memory.
1900
1901	proc ::mime::buildmessage {token} {
1902	global errorCode errorInfo
1903	# FRINK: nocheck
1904	variable $token
1905	upvar 0 $token state
1906
1907	set openP [info exists state(fd)]
1908
1909	set code [catch { mime::buildmessageaux $token } result]
1910	set ecode $errorCode
1911	set einfo $errorInfo
1912
1913	if {(!$openP) && ([info exists state(fd)])} {
1914	if {![info exists state(root)]} {
1915	catch { close $state(fd) }
1916	}
1917	unset state(fd)
1918	}
1919
1920	return -code $code -errorinfo $einfo -errorcode $ecode $result
1921	}
1922
1923	# ::mime::buildmessageaux --
1924	#
1925	# The following is a clone of the copymessageaux code to build up the
1926	# result in memory, and, unfortunately, without using a memory channel.
1927	# I considered parameterizing the "puts" calls in copy message, but
1928	# the need for this procedure may go away, so I'm living with it for
1929	# the moment.
1930	#
1931	# Arguments:
1932	# token The MIME token to parse.
1933	#
1934	# Results:
1935	# Returns the message that has been built up in memory.
1936
1937	proc ::mime::buildmessageaux {token} {
1938	# FRINK: nocheck
1939	variable $token
1940	upvar 0 $token state
1941
1942	array set header $state(header)
1943
1944	set result ""
1945	if {[string compare $state(version) ""]} {
1946	append result "MIME-Version: $state(version)\r\n"
1947	}
1948	foreach lower $state(lowerL) mixed $state(mixedL) {
1949	foreach value $header($lower) {
1950	append result "$mixed: $value\r\n"
1951	}
1952	}
1953	if {(!$state(canonicalP)) \
1954	&& ([string compare [set encoding $state(encoding)] ""])} {
1955	append result "Content-Transfer-Encoding: $encoding\r\n"
1956	}
1957
1958	append result "Content-Type: $state(content)"
1959	set boundary ""
1960	foreach {k v} $state(params) {
1961	if {![string compare $k boundary]} {
1962	set boundary $v
1963	}
1964
1965	append result ";\r\n $k=\"$v\""
1966	}
1967
1968	set converter ""
1969	set encoding ""
1970	if {[string compare $state(value) parts]} {
1971	append result \r\n
1972
1973	if {$state(canonicalP)} {
1974	if {![string compare [set encoding $state(encoding)] ""]} {
1975	set encoding [encoding $token]
1976	}
1977	if {[string compare $encoding ""]} {
1978	append result "Content-Transfer-Encoding: $encoding\r\n"
1979	}
1980	switch -- $encoding {
1981	base64
1982	-
1983	quoted-printable {
1984	set converter $encoding
1985	}
1986	7bit - 8bit - binary - "" {
1987	# Bugfix for [#477088]
1988	# Go ahead
1989	}
1990	default {
1991	error "Can't handle content encoding \"$encoding\""
1992	}
1993	}
1994	}
1995	} elseif {([string match multipart/* $state(content)]) \
1996	&& (![string compare $boundary ""])} {
1997	# we're doing everything in one pass...
1998	set key [clock seconds]$token[info hostname][array get state]
1999	set seqno 8
2000	while {[incr seqno -1] >= 0} {
2001	set key [md5 -- $key]
2002	}
2003	set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
2004
2005	append result ";\r\n boundary=\"$boundary\"\r\n"
2006	} else {
2007	append result "\r\n"
2008	}
2009
2010	if {[info exists state(error)]} {
2011	unset state(error)
2012	}
2013
2014	switch -- $state(value) {
2015	file {
2016	set closeP 1
2017	if {[info exists state(root)]} {
2018	# FRINK: nocheck
2019	variable $state(root)
2020	upvar 0 $state(root) root
2021
2022	if {[info exists root(fd)]} {
2023	set fd $root(fd)
2024	set closeP 0
2025	} else {
2026	set fd [set state(fd) \
2027	[open $state(file) { RDONLY }]]
2028	}
2029	set size $state(count)
2030	} else {
2031	set fd [set state(fd) [open $state(file) { RDONLY }]]
2032	set size -1 ;# Read until EOF
2033	}
2034	seek $fd $state(offset) start
2035	if {$closeP} {
2036	fconfigure $fd -translation binary
2037	}
2038
2039	append result "\r\n"
2040
2041	while {($size != 0) && (![eof $fd])} {
2042	if {$size < 0 \|\| $size > 32766} {
2043	set X [read $fd 32766]
2044	} else {
2045	set X [read $fd $size]
2046	}
2047	if {$size > 0} {
2048	set size [expr {$size - [string length $X]}]
2049	}
2050	if {[string compare $converter ""]} {
2051	append result [$converter -mode encode -- $X]
2052	} else {
2053	append result $X
2054	}
2055	}
2056
2057	if {$closeP} {
2058	catch { close $state(fd) }
2059	unset state(fd)
2060	}
2061	}
2062
2063	parts {
2064	if {(![info exists state(root)]) \
2065	&& ([info exists state(file)])} {
2066	set state(fd) [open $state(file) { RDONLY }]
2067	fconfigure $state(fd) -translation binary
2068	}
2069
2070	switch -glob -- $state(content) {
2071	message/* {
2072	append result "\r\n"
2073	foreach part $state(parts) {
2074	append result [buildmessage $part]
2075	break
2076	}
2077	}
2078
2079	default {
2080	# Note RFC 2046:
2081	#
2082	# The boundary delimiter MUST occur at the
2083	# beginning of a line, i.e., following a CRLF, and
2084	# the initial CRLF is considered to be attached to
2085	# the boundary delimiter line rather than part of
2086	# the preceding part.
2087	#
2088	# - The above means that the CRLF before $boundary
2089	# is needed per the RFC, and the parts must not
2090	# have a closing CRLF of their own. See Tcllib bug
2091	# 1213527, and patch 1254934 for the problems when
2092	# both file/string brnaches added CRLF after the
2093	# body parts.
2094
2095	foreach part $state(parts) {
2096	append result "\r\n--$boundary\r\n"
2097	append result [buildmessage $part]
2098	}
2099	append result "\r\n--$boundary--\r\n"
2100	}
2101	}
2102
2103	if {[info exists state(fd)]} {
2104	catch { close $state(fd) }
2105	unset state(fd)
2106	}
2107	}
2108
2109	string {
2110	append result "\r\n"
2111
2112	if {[string compare $converter ""]} {
2113	append result [$converter -mode encode -- $state(string)]
2114	} else {
2115	append result $state(string)
2116	}
2117	}
2118	default {
2119	error "Unknown value \"$state(value)\""
2120	}
2121	}
2122
2123	if {[info exists state(error)]} {
2124	error $state(error)
2125	}
2126	return $result
2127	}
2128
2129	# ::mime::encoding --
2130	#
2131	# Determines how a token is encoded.
2132	#
2133	# Arguments:
2134	# token The MIME token to parse.
2135	#
2136	# Results:
2137	# Returns the encoding of the message (the null string, base64,
2138	# or quoted-printable).
2139
2140	proc ::mime::encoding {token} {
2141	# FRINK: nocheck
2142	variable $token
2143	upvar 0 $token state
2144
2145	switch -glob -- $state(content) {
2146	audio/*
2147	-
2148	image/*
2149	-
2150	video/* {
2151	return base64
2152	}
2153
2154	message/*
2155	-
2156	multipart/* {
2157	return ""
2158	}
2159	default {# Skip}
2160	}
2161
2162	set asciiP 1
2163	set lineP 1
2164	switch -- $state(value) {
2165	file {
2166	set fd [open $state(file) { RDONLY }]
2167	fconfigure $fd -translation binary
2168
2169	while {[gets $fd line] >= 0} {
2170	if {$asciiP} {
2171	set asciiP [encodingasciiP $line]
2172	}
2173	if {$lineP} {
2174	set lineP [encodinglineP $line]
2175	}
2176	if {(!$asciiP) && (!$lineP)} {
2177	break
2178	}
2179	}
2180
2181	catch { close $fd }
2182	}
2183
2184	parts {
2185	return ""
2186	}
2187
2188	string {
2189	foreach line [split $state(string) "\n"] {
2190	if {$asciiP} {
2191	set asciiP [encodingasciiP $line]
2192	}
2193	if {$lineP} {
2194	set lineP [encodinglineP $line]
2195	}
2196	if {(!$asciiP) && (!$lineP)} {
2197	break
2198	}
2199	}
2200	}
2201	default {
2202	error "Unknown value \"$state(value)\""
2203	}
2204	}
2205
2206	switch -glob -- $state(content) {
2207	text/* {
2208	if {!$asciiP} {
2209	foreach {k v} $state(params) {
2210	if {![string compare $k charset]} {
2211	set v [string tolower $v]
2212	if {([string compare $v us-ascii]) \
2213	&& (![string match {iso-8859-[1-8]} $v])} {
2214	return base64
2215	}
2216
2217	break
2218	}
2219	}
2220	}
2221
2222	if {!$lineP} {
2223	return quoted-printable
2224	}
2225	}
2226
2227
2228	default {
2229	if {(!$asciiP) \|\| (!$lineP)} {
2230	return base64
2231	}
2232	}
2233	}
2234
2235	return ""
2236	}
2237
2238	# ::mime::encodingasciiP --
2239	#
2240	# Checks if a string is a pure ascii string, or if it has a non-standard
2241	# form.
2242	#
2243	# Arguments:
2244	# line The line to check.
2245	#
2246	# Results:
2247	# Returns 1 if \r only occurs at the end of lines, and if all
2248	# characters in the line are between the ASCII codes of 32 and 126.
2249
2250	proc ::mime::encodingasciiP {line} {
2251	foreach c [split $line ""] {
2252	switch -- $c {
2253	" " - "\t" - "\r" - "\n" {
2254	}
2255
2256	default {
2257	binary scan $c c c
2258	if {($c < 32) \|\| ($c > 126)} {
2259	return 0
2260	}
2261	}
2262	}
2263	}
2264	if {([set r [string first "\r" $line]] < 0) \
2265	\|\| ($r == [expr {[string length $line]-1}])} {
2266	return 1
2267	}
2268
2269	return 0
2270	}
2271
2272	# ::mime::encodinglineP --
2273	#
2274	# Checks if a string is a line is valid to be processed.
2275	#
2276	# Arguments:
2277	# line The line to check.
2278	#
2279	# Results:
2280	# Returns 1 the line is less than 76 characters long, the line
2281	# contains more characters than just whitespace, the line does
2282	# not start with a '.', and the line does not start with 'From '.
2283
2284	proc ::mime::encodinglineP {line} {
2285	if {([string length $line] > 76) \
2286	\|\| ([string compare $line [string trimright $line]]) \
2287	\|\| ([string first . $line] == 0) \
2288	\|\| ([string first "From " $line] == 0)} {
2289	return 0
2290	}
2291
2292	return 1
2293	}
2294
2295	# ::mime::fcopy --
2296	#
2297	# Appears to be unused.
2298	#
2299	# Arguments:
2300	#
2301	# Results:
2302	#
2303
2304	proc ::mime::fcopy {token count {error ""}} {
2305	# FRINK: nocheck
2306	variable $token
2307	upvar 0 $token state
2308
2309	if {[string compare $error ""]} {
2310	set state(error) $error
2311	}
2312	set state(doneP) 1
2313	}
2314
2315	# ::mime::scopy --
2316	#
2317	# Copy a portion of the contents of a mime token to a channel.
2318	#
2319	# Arguments:
2320	# token The token containing the data to copy.
2321	# channel The channel to write the data to.
2322	# offset The location in the string to start copying
2323	# from.
2324	# len The amount of data to write.
2325	# blocksize The block size for the write operation.
2326	#
2327	# Results:
2328	# The specified portion of the string in the mime token is
2329	# copied to the specified channel.
2330
2331	proc ::mime::scopy {token channel offset len blocksize} {
2332	# FRINK: nocheck
2333	variable $token
2334	upvar 0 $token state
2335
2336	if {$len <= 0} {
2337	set state(doneP) 1
2338	fileevent $channel writable ""
2339	return
2340	}
2341
2342	if {[set cc $len] > $blocksize} {
2343	set cc $blocksize
2344	}
2345
2346	if {[catch { puts -nonewline $channel \
2347	[string range $state(string) $offset \
2348	[expr {$offset+$cc-1}]]
2349	fileevent $channel writable \
2350	[list mime::scopy $token $channel \
2351	[incr offset $cc] \
2352	[incr len -$cc] \
2353	$blocksize]
2354	} result]} {
2355	set state(error) $result
2356	set state(doneP) 1
2357	fileevent $channel writable ""
2358	}
2359	return
2360	}
2361
2362	# ::mime::qp_encode --
2363	#
2364	# Tcl version of quote-printable encode
2365	#
2366	# Arguments:
2367	# string The string to quote.
2368	# encoded_word Boolean value to determine whether or not encoded words
2369	# (RFC 2047) should be handled or not. (optional)
2370	#
2371	# Results:
2372	# The properly quoted string is returned.
2373
2374	proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} {
2375	# 8.1+ improved string manipulation routines used.
2376	# Replace outlying characters, characters that would normally
2377	# be munged by EBCDIC gateways, and special Tcl characters "[\]{}
2378	# with =xx sequence
2379
2380	regsub -all -- \
2381	{[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \
2382	$string {[format =%02X [scan "\\&" %c]]} string
2383
2384	# Replace the format commands with their result
2385
2386	set string [subst -novariable $string]
2387
2388	# soft/hard newlines and other
2389	# Funky cases for SMTP compatibility
2390	set mapChars [list " \n" "=20\n" "\t\n" "=09\n" \
2391	"\n\.\n" "\n=2E\n" "\nFrom " "\n=46rom "]
2392	if {$encoded_word} {
2393	# Special processing for encoded words (RFC 2047)
2394	lappend mapChars " " "_"
2395	}
2396	set string [string map $mapChars $string]
2397
2398	# Break long lines - ugh
2399
2400	# Implementation of FR #503336
2401	if {$no_softbreak} {
2402	set result $string
2403	} else {
2404	set result ""
2405	foreach line [split $string \n] {
2406	while {[string length $line] > 72} {
2407	set chunk [string range $line 0 72]
2408	if {[regexp -- (=\|=.)$ $chunk dummy end]} {
2409
2410	# Don't break in the middle of a code
2411
2412	set len [expr {72 - [string length $end]}]
2413	set chunk [string range $line 0 $len]
2414	incr len
2415	set line [string range $line $len end]
2416	} else {
2417	set line [string range $line 73 end]
2418	}
2419	append result $chunk=\n
2420	}
2421	append result $line\n
2422	}
2423
2424	# Trim off last \n, since the above code has the side-effect
2425	# of adding an extra \n to the encoded string and return the
2426	# result.
2427	set result [string range $result 0 end-1]
2428	}
2429
2430	# If the string ends in space or tab, replace with =xx
2431
2432	set lastChar [string index $result end]
2433	if {$lastChar==" "} {
2434	set result [string replace $result end end "=20"]
2435	} elseif {$lastChar=="\t"} {
2436	set result [string replace $result end end "=09"]
2437	}
2438
2439	return $result
2440	}
2441
2442	# ::mime::qp_decode --
2443	#
2444	# Tcl version of quote-printable decode
2445	#
2446	# Arguments:
2447	# string The quoted-prinatble string to decode.
2448	# encoded_word Boolean value to determine whether or not encoded words
2449	# (RFC 2047) should be handled or not. (optional)
2450	#
2451	# Results:
2452	# The decoded string is returned.
2453
2454	proc ::mime::qp_decode {string {encoded_word 0}} {
2455	# 8.1+ improved string manipulation routines used.
2456	# Special processing for encoded words (RFC 2047)
2457
2458	if {$encoded_word} {
2459	# _ == \x20, even if SPACE occupies a different code position
2460	set string [string map [list _ \u0020] $string]
2461	}
2462
2463	# smash the white-space at the ends of lines since that must've been
2464	# generated by an MUA.
2465
2466	regsub -all -- {[ \t]+\n} $string "\n" string
2467	set string [string trimright $string " \t"]
2468
2469	# Protect the backslash for later subst and
2470	# smash soft newlines, has to occur after white-space smash
2471	# and any encoded word modification.
2472
2473	set string [string map [list "\\" "\\\\" "=\n" ""] $string]
2474
2475	# Decode specials
2476
2477	regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string
2478
2479	# process \u unicode mapped chars
2480
2481	return [subst -novar -nocommand $string]
2482	}
2483
2484	# ::mime::parseaddress --
2485	#
2486	# This was originally written circa 1982 in C. we're still using it
2487	# because it recognizes virtually every buggy address syntax ever
2488	# generated!
2489	#
2490	# mime::parseaddress takes a string containing one or more 822-style
2491	# address specifications and returns a list of serialized arrays, one
2492	# element for each address specified in the argument.
2493	#
2494	# Each serialized array contains these properties:
2495	#
2496	# property value
2497	# ======== =====
2498	# address local@domain
2499	# comment 822-style comment
2500	# domain the domain part (rhs)
2501	# error non-empty on a parse error
2502	# group this address begins a group
2503	# friendly user-friendly rendering
2504	# local the local part (lhs)
2505	# memberP this address belongs to a group
2506	# phrase the phrase part
2507	# proper 822-style address specification
2508	# route 822-style route specification (obsolete)
2509	#
2510	# Note that one or more of these properties may be empty.
2511	#
2512	# Arguments:
2513	# string The address string to parse
2514	#
2515	# Results:
2516	# Returns a list of serialized arrays, one element for each address
2517	# specified in the argument.
2518
2519	proc ::mime::parseaddress {string} {
2520	global errorCode errorInfo
2521
2522	variable mime
2523
2524	set token [namespace current]::[incr mime(uid)]
2525	# FRINK: nocheck
2526	variable $token
2527	upvar 0 $token state
2528
2529	set code [catch { mime::parseaddressaux $token $string } result]
2530	set ecode $errorCode
2531	set einfo $errorInfo
2532
2533	foreach name [array names state] {
2534	unset state($name)
2535	}
2536	# FRINK: nocheck
2537	catch { unset $token }
2538
2539	return -code $code -errorinfo $einfo -errorcode $ecode $result
2540	}
2541
2542	# ::mime::parseaddressaux --
2543	#
2544	# This was originally written circa 1982 in C. we're still using it
2545	# because it recognizes virtually every buggy address syntax ever
2546	# generated!
2547	#
2548	# mime::parseaddressaux does the actually parsing for mime::parseaddress
2549	#
2550	# Each serialized array contains these properties:
2551	#
2552	# property value
2553	# ======== =====
2554	# address local@domain
2555	# comment 822-style comment
2556	# domain the domain part (rhs)
2557	# error non-empty on a parse error
2558	# group this address begins a group
2559	# friendly user-friendly rendering
2560	# local the local part (lhs)
2561	# memberP this address belongs to a group
2562	# phrase the phrase part
2563	# proper 822-style address specification
2564	# route 822-style route specification (obsolete)
2565	#
2566	# Note that one or more of these properties may be empty.
2567	#
2568	# Arguments:
2569	# token The MIME token to work from.
2570	# string The address string to parse
2571	#
2572	# Results:
2573	# Returns a list of serialized arrays, one element for each address
2574	# specified in the argument.
2575
2576	proc ::mime::parseaddressaux {token string} {
2577	# FRINK: nocheck
2578	variable $token
2579	upvar 0 $token state
2580
2581	variable addrtokenL
2582	variable addrlexemeL
2583
2584	set state(input) $string
2585	set state(glevel) 0
2586	set state(buffer) ""
2587	set state(lastC) LX_END
2588	set state(tokenL) $addrtokenL
2589	set state(lexemeL) $addrlexemeL
2590
2591	set result ""
2592	while {[addr_next $token]} {
2593	if {[string compare [set tail $state(domain)] ""]} {
2594	set tail @$state(domain)
2595	} else {
2596	set tail @[info hostname]
2597	}
2598	if {[string compare [set address $state(local)] ""]} {
2599	append address $tail
2600	}
2601
2602	if {[string compare $state(phrase) ""]} {
2603	set state(phrase) [string trim $state(phrase) "\""]
2604	foreach t $state(tokenL) {
2605	if {[string first $t $state(phrase)] >= 0} {
2606	set state(phrase) \"$state(phrase)\"
2607	break
2608	}
2609	}
2610
2611	set proper "$state(phrase) <$address>"
2612	} else {
2613	set proper $address
2614	}
2615
2616	if {![string compare [set friendly $state(phrase)] ""]} {
2617	if {[string compare [set note $state(comment)] ""]} {
2618	if {[string first "(" $note] == 0} {
2619	set note [string trimleft [string range $note 1 end]]
2620	}
2621	if {[string last ")" $note] \
2622	== [set len [expr {[string length $note]-1}]]} {
2623	set note [string range $note 0 [expr {$len-1}]]
2624	}
2625	set friendly $note
2626	}
2627
2628	if {(![string compare $friendly ""]) \
2629	&& ([string compare [set mbox $state(local)] ""])} {
2630	set mbox [string trim $mbox "\""]
2631
2632	if {[string first "/" $mbox] != 0} {
2633	set friendly $mbox
2634	} elseif {[string compare \
2635	[set friendly [addr_x400 $mbox PN]] \
2636	""]} {
2637	} elseif {([string compare \
2638	[set friendly [addr_x400 $mbox S]] \
2639	""]) \
2640	&& ([string compare \
2641	[set g [addr_x400 $mbox G]] \
2642	""])} {
2643	set friendly "$g $friendly"
2644	}
2645
2646	if {![string compare $friendly ""]} {
2647	set friendly $mbox
2648	}
2649	}
2650	}
2651	set friendly [string trim $friendly "\""]
2652
2653	lappend result [list address $address \
2654	comment $state(comment) \
2655	domain $state(domain) \
2656	error $state(error) \
2657	friendly $friendly \
2658	group $state(group) \
2659	local $state(local) \
2660	memberP $state(memberP) \
2661	phrase $state(phrase) \
2662	proper $proper \
2663	route $state(route)]
2664
2665	}
2666
2667	unset state(input) \
2668	state(glevel) \
2669	state(buffer) \
2670	state(lastC) \
2671	state(tokenL) \
2672	state(lexemeL)
2673
2674	return $result
2675	}
2676
2677	# ::mime::addr_next --
2678	#
2679	# Locate the next address in a mime token.
2680	#
2681	# Arguments:
2682	# token The MIME token to work from.
2683	#
2684	# Results:
2685	# Returns 1 if there is another address, and 0 if there is not.
2686
2687	proc ::mime::addr_next {token} {
2688	global errorCode errorInfo
2689	# FRINK: nocheck
2690	variable $token
2691	upvar 0 $token state
2692
2693	foreach prop {comment domain error group local memberP phrase route} {
2694	catch { unset state($prop) }
2695	}
2696
2697	switch -- [set code [catch { mime::addr_specification $token } result]] {
2698	0 {
2699	if {!$result} {
2700	return 0
2701	}
2702
2703	switch -- $state(lastC) {
2704	LX_COMMA
2705	-
2706	LX_END {
2707	}
2708	default {
2709	# catch trailing comments...
2710	set lookahead $state(input)
2711	mime::parselexeme $token
2712	set state(input) $lookahead
2713	}
2714	}
2715	}
2716
2717	7 {
2718	set state(error) $result
2719
2720	while {1} {
2721	switch -- $state(lastC) {
2722	LX_COMMA
2723	-
2724	LX_END {
2725	break
2726	}
2727
2728	default {
2729	mime::parselexeme $token
2730	}
2731	}
2732	}
2733	}
2734
2735	default {
2736	set ecode $errorCode
2737	set einfo $errorInfo
2738
2739	return -code $code -errorinfo $einfo -errorcode $ecode $result
2740	}
2741	}
2742
2743	foreach prop {comment domain error group local memberP phrase route} {
2744	if {![info exists state($prop)]} {
2745	set state($prop) ""
2746	}
2747	}
2748
2749	return 1
2750	}
2751
2752	# ::mime::addr_specification --
2753	#
2754	# Uses lookahead parsing to determine whether there is another
2755	# valid e-mail address or not. Throws errors if unrecognized
2756	# or invalid e-mail address syntax is used.
2757	#
2758	# Arguments:
2759	# token The MIME token to work from.
2760	#
2761	# Results:
2762	# Returns 1 if there is another address, and 0 if there is not.
2763
2764	proc ::mime::addr_specification {token} {
2765	# FRINK: nocheck
2766	variable $token
2767	upvar 0 $token state
2768
2769	set lookahead $state(input)
2770	switch -- [parselexeme $token] {
2771	LX_ATOM
2772	-
2773	LX_QSTRING {
2774	set state(phrase) $state(buffer)
2775	}
2776
2777	LX_SEMICOLON {
2778	if {[incr state(glevel) -1] < 0} {
2779	return -code 7 "extraneous semi-colon"
2780	}
2781
2782	catch { unset state(comment) }
2783	return [addr_specification $token]
2784	}
2785
2786	LX_COMMA {
2787	catch { unset state(comment) }
2788	return [addr_specification $token]
2789	}
2790
2791	LX_END {
2792	return 0
2793	}
2794
2795	LX_LBRACKET {
2796	return [addr_routeaddr $token]
2797	}
2798
2799	LX_ATSIGN {
2800	set state(input) $lookahead
2801	return [addr_routeaddr $token 0]
2802	}
2803
2804	default {
2805	return -code 7 \
2806	[format "unexpected character at beginning (found %s)" \
2807	$state(buffer)]
2808	}
2809	}
2810
2811	switch -- [parselexeme $token] {
2812	LX_ATOM
2813	-
2814	LX_QSTRING {
2815	append state(phrase) " " $state(buffer)
2816
2817	return [addr_phrase $token]
2818	}
2819
2820	LX_LBRACKET {
2821	return [addr_routeaddr $token]
2822	}
2823
2824	LX_COLON {
2825	return [addr_group $token]
2826	}
2827
2828	LX_DOT {
2829	set state(local) "$state(phrase)$state(buffer)"
2830	unset state(phrase)
2831	mime::addr_routeaddr $token 0
2832	mime::addr_end $token
2833	}
2834
2835	LX_ATSIGN {
2836	set state(memberP) $state(glevel)
2837	set state(local) $state(phrase)
2838	unset state(phrase)
2839	mime::addr_domain $token
2840	mime::addr_end $token
2841	}
2842
2843	LX_SEMICOLON
2844	-
2845	LX_COMMA
2846	-
2847	LX_END {
2848	set state(memberP) $state(glevel)
2849	if {(![string compare $state(lastC) LX_SEMICOLON]) \
2850	&& ([incr state(glevel) -1] < 0)} {
2851	return -code 7 "extraneous semi-colon"
2852	}
2853
2854	set state(local) $state(phrase)
2855	unset state(phrase)
2856	}
2857
2858	default {
2859	return -code 7 [format "expecting mailbox (found %s)" \
2860	$state(buffer)]
2861	}
2862	}
2863
2864	return 1
2865	}
2866
2867	# ::mime::addr_routeaddr --
2868	#
2869	# Parses the domain portion of an e-mail address. Finds the '@'
2870	# sign and then calls mime::addr_route to verify the domain.
2871	#
2872	# Arguments:
2873	# token The MIME token to work from.
2874	#
2875	# Results:
2876	# Returns 1 if there is another address, and 0 if there is not.
2877
2878	proc ::mime::addr_routeaddr {token {checkP 1}} {
2879	# FRINK: nocheck
2880	variable $token
2881	upvar 0 $token state
2882
2883	set lookahead $state(input)
2884	if {![string compare [parselexeme $token] LX_ATSIGN]} {
2885	mime::addr_route $token
2886	} else {
2887	set state(input) $lookahead
2888	}
2889
2890	mime::addr_local $token
2891
2892	switch -- $state(lastC) {
2893	LX_ATSIGN {
2894	mime::addr_domain $token
2895	}
2896
2897	LX_SEMICOLON
2898	-
2899	LX_RBRACKET
2900	-
2901	LX_COMMA
2902	-
2903	LX_END {
2904	}
2905
2906	default {
2907	return -code 7 \
2908	[format "expecting at-sign after local-part (found %s)" \
2909	$state(buffer)]
2910	}
2911	}
2912
2913	if {($checkP) && ([string compare $state(lastC) LX_RBRACKET])} {
2914	return -code 7 [format "expecting right-bracket (found %s)" \
2915	$state(buffer)]
2916	}
2917
2918	return 1
2919	}
2920
2921	# ::mime::addr_route --
2922	#
2923	# Attempts to parse the portion of the e-mail address after the @.
2924	# Tries to verify that the domain definition has a valid form.
2925	#
2926	# Arguments:
2927	# token The MIME token to work from.
2928	#
2929	# Results:
2930	# Returns nothing if successful, and throws an error if invalid
2931	# syntax is found.
2932
2933	proc ::mime::addr_route {token} {
2934	# FRINK: nocheck
2935	variable $token
2936	upvar 0 $token state
2937
2938	set state(route) @
2939
2940	while {1} {
2941	switch -- [parselexeme $token] {
2942	LX_ATOM
2943	-
2944	LX_DLITERAL {
2945	append state(route) $state(buffer)
2946	}
2947
2948	default {
2949	return -code 7 \
2950	[format "expecting sub-route in route-part (found %s)" \
2951	$state(buffer)]
2952	}
2953	}
2954
2955	switch -- [parselexeme $token] {
2956	LX_COMMA {
2957	append state(route) $state(buffer)
2958	while {1} {
2959	switch -- [parselexeme $token] {
2960	LX_COMMA {
2961	}
2962
2963	LX_ATSIGN {
2964	append state(route) $state(buffer)
2965	break
2966	}
2967
2968	default {
2969	return -code 7 \
2970	[format "expecting at-sign in route (found %s)" \
2971	$state(buffer)]
2972	}
2973	}
2974	}
2975	}
2976
2977	LX_ATSIGN
2978	-
2979	LX_DOT {
2980	append state(route) $state(buffer)
2981	}
2982
2983	LX_COLON {
2984	append state(route) $state(buffer)
2985	return
2986	}
2987
2988	default {
2989	return -code 7 \
2990	[format "expecting colon to terminate route (found %s)" \
2991	$state(buffer)]
2992	}
2993	}
2994	}
2995	}
2996
2997	# ::mime::addr_domain --
2998	#
2999	# Attempts to parse the portion of the e-mail address after the @.
3000	# Tries to verify that the domain definition has a valid form.
3001	#
3002	# Arguments:
3003	# token The MIME token to work from.
3004	#
3005	# Results:
3006	# Returns nothing if successful, and throws an error if invalid
3007	# syntax is found.
3008
3009	proc ::mime::addr_domain {token} {
3010	# FRINK: nocheck
3011	variable $token
3012	upvar 0 $token state
3013
3014	while {1} {
3015	switch -- [parselexeme $token] {
3016	LX_ATOM
3017	-
3018	LX_DLITERAL {
3019	append state(domain) $state(buffer)
3020	}
3021
3022	default {
3023	return -code 7 \
3024	[format "expecting sub-domain in domain-part (found %s)" \
3025	$state(buffer)]
3026	}
3027	}
3028
3029	switch -- [parselexeme $token] {
3030	LX_DOT {
3031	append state(domain) $state(buffer)
3032	}
3033
3034	LX_ATSIGN {
3035	append state(local) % $state(domain)
3036	unset state(domain)
3037	}
3038
3039	default {
3040	return
3041	}
3042	}
3043	}
3044	}
3045
3046	# ::mime::addr_local --
3047	#
3048	#
3049	# Arguments:
3050	# token The MIME token to work from.
3051	#
3052	# Results:
3053	# Returns nothing if successful, and throws an error if invalid
3054	# syntax is found.
3055
3056	proc ::mime::addr_local {token} {
3057	# FRINK: nocheck
3058	variable $token
3059	upvar 0 $token state
3060
3061	set state(memberP) $state(glevel)
3062
3063	while {1} {
3064	switch -- [parselexeme $token] {
3065	LX_ATOM
3066	-
3067	LX_QSTRING {
3068	append state(local) $state(buffer)
3069	}
3070
3071	default {
3072	return -code 7 \
3073	[format "expecting mailbox in local-part (found %s)" \
3074	$state(buffer)]
3075	}
3076	}
3077
3078	switch -- [parselexeme $token] {
3079	LX_DOT {
3080	append state(local) $state(buffer)
3081	}
3082
3083	default {
3084	return
3085	}
3086	}
3087	}
3088	}
3089
3090	# ::mime::addr_phrase --
3091	#
3092	#
3093	# Arguments:
3094	# token The MIME token to work from.
3095	#
3096	# Results:
3097	# Returns nothing if successful, and throws an error if invalid
3098	# syntax is found.
3099
3100
3101	proc ::mime::addr_phrase {token} {
3102	# FRINK: nocheck
3103	variable $token
3104	upvar 0 $token state
3105
3106	while {1} {
3107	switch -- [parselexeme $token] {
3108	LX_ATOM
3109	-
3110	LX_QSTRING {
3111	append state(phrase) " " $state(buffer)
3112	}
3113
3114	default {
3115	break
3116	}
3117	}
3118	}
3119
3120	switch -- $state(lastC) {
3121	LX_LBRACKET {
3122	return [addr_routeaddr $token]
3123	}
3124
3125	LX_COLON {
3126	return [addr_group $token]
3127	}
3128
3129	LX_DOT {
3130	append state(phrase) $state(buffer)
3131	return [addr_phrase $token]
3132	}
3133
3134	default {
3135	return -code 7 \
3136	[format "found phrase instead of mailbox (%s%s)" \
3137	$state(phrase) $state(buffer)]
3138	}
3139	}
3140	}
3141
3142	# ::mime::addr_group --
3143	#
3144	#
3145	# Arguments:
3146	# token The MIME token to work from.
3147	#
3148	# Results:
3149	# Returns nothing if successful, and throws an error if invalid
3150	# syntax is found.
3151
3152	proc ::mime::addr_group {token} {
3153	# FRINK: nocheck
3154	variable $token
3155	upvar 0 $token state
3156
3157	if {[incr state(glevel)] > 1} {
3158	return -code 7 [format "nested groups not allowed (found %s)" \
3159	$state(phrase)]
3160	}
3161
3162	set state(group) $state(phrase)
3163	unset state(phrase)
3164
3165	set lookahead $state(input)
3166	while {1} {
3167	switch -- [parselexeme $token] {
3168	LX_SEMICOLON
3169	-
3170	LX_END {
3171	set state(glevel) 0
3172	return 1
3173	}
3174
3175	LX_COMMA {
3176	}
3177
3178	default {
3179	set state(input) $lookahead
3180	return [addr_specification $token]
3181	}
3182	}
3183	}
3184	}
3185
3186	# ::mime::addr_end --
3187	#
3188	#
3189	# Arguments:
3190	# token The MIME token to work from.
3191	#
3192	# Results:
3193	# Returns nothing if successful, and throws an error if invalid
3194	# syntax is found.
3195
3196	proc ::mime::addr_end {token} {
3197	# FRINK: nocheck
3198	variable $token
3199	upvar 0 $token state
3200
3201	switch -- $state(lastC) {
3202	LX_SEMICOLON {
3203	if {[incr state(glevel) -1] < 0} {
3204	return -code 7 "extraneous semi-colon"
3205	}
3206	}
3207
3208	LX_COMMA
3209	-
3210	LX_END {
3211	}
3212
3213	default {
3214	return -code 7 [format "junk after local@domain (found %s)" \
3215	$state(buffer)]
3216	}
3217	}
3218	}
3219
3220	# ::mime::addr_x400 --
3221	#
3222	#
3223	# Arguments:
3224	# token The MIME token to work from.
3225	#
3226	# Results:
3227	# Returns nothing if successful, and throws an error if invalid
3228	# syntax is found.
3229
3230	proc ::mime::addr_x400 {mbox key} {
3231	if {[set x [string first "/$key=" [string toupper $mbox]]] < 0} {
3232	return ""
3233	}
3234	set mbox [string range $mbox [expr {$x+[string length $key]+2}] end]
3235
3236	if {[set x [string first "/" $mbox]] > 0} {
3237	set mbox [string range $mbox 0 [expr {$x-1}]]
3238	}
3239
3240	return [string trim $mbox "\""]
3241	}
3242
3243	# ::mime::parsedatetime --
3244	#
3245	# Fortunately the clock command in the Tcl 8.x core does all the heavy
3246	# lifting for us (except for timezone calculations).
3247	#
3248	# mime::parsedatetime takes a string containing an 822-style date-time
3249	# specification and returns the specified property.
3250	#
3251	# The list of properties and their ranges are:
3252	#
3253	# property range
3254	# ======== =====
3255	# clock raw result of "clock scan"
3256	# hour 0 .. 23
3257	# lmonth January, February, ..., December
3258	# lweekday Sunday, Monday, ... Saturday
3259	# mday 1 .. 31
3260	# min 0 .. 59
3261	# mon 1 .. 12
3262	# month Jan, Feb, ..., Dec
3263	# proper 822-style date-time specification
3264	# rclock elapsed seconds between then and now
3265	# sec 0 .. 59
3266	# wday 0 .. 6 (Sun .. Mon)
3267	# weekday Sun, Mon, ..., Sat
3268	# yday 1 .. 366
3269	# year 1900 ...
3270	# zone -720 .. 720 (minutes east of GMT)
3271	#
3272	# Arguments:
3273	# value Either a 822-style date-time specification or '-now'
3274	# if the current date/time should be used.
3275	# property The property (from the list above) to return
3276	#
3277	# Results:
3278	# Returns the string value of the 'property' for the date/time that was
3279	# specified in 'value'.
3280
3281	namespace eval ::mime {
3282	variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat]
3283	variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \
3284	Friday Saturday]
3285
3286	# Counting months starts at 1, so just insert a dummy element
3287	# at index 0.
3288	variable MONTHS_SHORT [list "" \
3289	Jan Feb Mar Apr May Jun \
3290	Jul Aug Sep Oct Nov Dec]
3291	variable MONTHS_LONG [list "" \
3292	January February March April May June July \
3293	August Sepember October November December]
3294	}
3295	proc ::mime::parsedatetime {value property} {
3296	if {![string compare $value -now]} {
3297	set clock [clock seconds]
3298	} elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \
3299	-> value zone_sign zone_hour zone_min]} {
3300	set clock [clock scan $value -gmt 1]
3301	if {[info exists zone_min]} {
3302	set zone_min [scan $zone_min %d]
3303	set zone_hour [scan $zone_hour %d]
3304	set zone [expr {60($zone_min+60$zone_hour)}]
3305	if {[string equal $zone_sign "+"]} {
3306	set zone -$zone
3307	}
3308	incr clock $zone
3309	}
3310	} else {
3311	set clock [clock scan $value]
3312	}
3313
3314	switch -- $property {
3315	clock {
3316	return $clock
3317	}
3318
3319	hour {
3320	set value [clock format $clock -format %H]
3321	}
3322
3323	lmonth {
3324	variable MONTHS_LONG
3325	return [lindex $MONTHS_LONG \
3326	[scan [clock format $clock -format %m] %d]]
3327	}
3328
3329	lweekday {
3330	variable WDAYS_LONG
3331	return [lindex $WDAYS_LONG [clock format $clock -format %w]]
3332	}
3333
3334	mday {
3335	set value [clock format $clock -format %d]
3336	}
3337
3338	min {
3339	set value [clock format $clock -format %M]
3340	}
3341
3342	mon {
3343	set value [clock format $clock -format %m]
3344	}
3345
3346	month {
3347	variable MONTHS_SHORT
3348	return [lindex $MONTHS_SHORT \
3349	[scan [clock format $clock -format %m] %d]]
3350	}
3351
3352	proper {
3353	set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" \
3354	-gmt true]
3355	if {[set diff [expr {($clock-[clock scan $gmt])/60}]] < 0} {
3356	set s -
3357	set diff [expr {-($diff)}]
3358	} else {
3359	set s +
3360	}
3361	set zone [format %s%02d%02d $s [expr {$diff/60}] [expr {$diff%60}]]
3362
3363	variable WDAYS_SHORT
3364	set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]]
3365	variable MONTHS_SHORT
3366	set mon [lindex $MONTHS_SHORT \
3367	[scan [clock format $clock -format %m] %d]]
3368
3369	return [clock format $clock \
3370	-format "$wday, %d $mon %Y %H:%M:%S $zone"]
3371	}
3372
3373	rclock {
3374	if {![string compare $value -now]} {
3375	return 0
3376	} else {
3377	return [expr {[clock seconds]-$clock}]
3378	}
3379	}
3380
3381	sec {
3382	set value [clock format $clock -format %S]
3383	}
3384
3385	wday {
3386	return [clock format $clock -format %w]
3387	}
3388
3389	weekday {
3390	variable WDAYS_SHORT
3391	return [lindex $WDAYS_SHORT [clock format $clock -format %w]]
3392	}
3393
3394	yday {
3395	set value [clock format $clock -format %j]
3396	}
3397
3398	year {
3399	set value [clock format $clock -format %Y]
3400	}
3401
3402	zone {
3403	set value [string trim [string map [list "\t" " "] $value]]
3404	if {[set x [string last " " $value]] < 0} {
3405	return 0
3406	}
3407	set value [string range $value [expr {$x+1}] end]
3408	switch -- [set s [string index $value 0]] {
3409	+ - - {
3410	if {![string compare $s +]} {
3411	set s ""
3412	}
3413	set value [string trim [string range $value 1 end]]
3414	if {([string length $value] != 4) \
3415	\|\| ([scan $value %2d%2d h m] != 2) \
3416	\|\| ($h > 12) \
3417	\|\| ($m > 59) \
3418	\|\| (($h == 12) && ($m > 0))} {
3419	error "malformed timezone-specification: $value"
3420	}
3421	set value $s[expr {$h*60+$m}]
3422	}
3423
3424	default {
3425	set value [string toupper $value]
3426	set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT]
3427	set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7]
3428	if {[set x [lsearch -exact $z1 $value]] < 0} {
3429	error "unrecognized timezone-mnemonic: $value"
3430	}
3431	set value [expr {[lindex $z2 $x]*60}]
3432	}
3433	}
3434	}
3435
3436	date2gmt
3437	-
3438	date2local
3439	-
3440	dst
3441	-
3442	sday
3443	-
3444	szone
3445	-
3446	tzone
3447	-
3448	default {
3449	error "unknown property $property"
3450	}
3451	}
3452
3453	if {![string compare [set value [string trimleft $value 0]] ""]} {
3454	set value 0
3455	}
3456	return $value
3457	}
3458
3459	# ::mime::uniqueID --
3460	#
3461	# Used to generate a 'globally unique identifier' for the content-id.
3462	# The id is built from the pid, the current time, the hostname, and
3463	# a counter that is incremented each time a message is sent.
3464	#
3465	# Arguments:
3466	#
3467	# Results:
3468	# Returns the a string that contains the globally unique identifier
3469	# that should be used for the Content-ID of an e-mail message.
3470
3471	proc ::mime::uniqueID {} {
3472	variable mime
3473
3474	return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>"
3475	}
3476
3477	# ::mime::parselexeme --
3478	#
3479	# Used to implement a lookahead parser.
3480	#
3481	# Arguments:
3482	# token The MIME token to operate on.
3483	#
3484	# Results:
3485	# Returns the next token found by the parser.
3486
3487	proc ::mime::parselexeme {token} {
3488	# FRINK: nocheck
3489	variable $token
3490	upvar 0 $token state
3491
3492	set state(input) [string trimleft $state(input)]
3493
3494	set state(buffer) ""
3495	if {![string compare $state(input) ""]} {
3496	set state(buffer) end-of-input
3497	return [set state(lastC) LX_END]
3498	}
3499
3500	set c [string index $state(input) 0]
3501	set state(input) [string range $state(input) 1 end]
3502
3503	if {![string compare $c "("]} {
3504	set noteP 0
3505	set quoteP 0
3506
3507	while {1} {
3508	append state(buffer) $c
3509
3510	switch -- $c/$quoteP {
3511	"(/0" {
3512	incr noteP
3513	}
3514
3515	"\\/0" {
3516	set quoteP 1
3517	}
3518
3519	")/0" {
3520	if {[incr noteP -1] < 1} {
3521	if {[info exists state(comment)]} {
3522	append state(comment) " "
3523	}
3524	append state(comment) $state(buffer)
3525
3526	return [parselexeme $token]
3527	}
3528	}
3529
3530	default {
3531	set quoteP 0
3532	}
3533	}
3534
3535	if {![string compare [set c [string index $state(input) 0]] ""]} {
3536	set state(buffer) "end-of-input during comment"
3537	return [set state(lastC) LX_ERR]
3538	}
3539	set state(input) [string range $state(input) 1 end]
3540	}
3541	}
3542
3543	if {![string compare $c "\""]} {
3544	set firstP 1
3545	set quoteP 0
3546
3547	while {1} {
3548	append state(buffer) $c
3549
3550	switch -- $c/$quoteP {
3551	"\\/0" {
3552	set quoteP 1
3553	}
3554
3555	"\"/0" {
3556	if {!$firstP} {
3557	return [set state(lastC) LX_QSTRING]
3558	}
3559	set firstP 0
3560	}
3561
3562	default {
3563	set quoteP 0
3564	}
3565	}
3566
3567	if {![string compare [set c [string index $state(input) 0]] ""]} {
3568	set state(buffer) "end-of-input during quoted-string"
3569	return [set state(lastC) LX_ERR]
3570	}
3571	set state(input) [string range $state(input) 1 end]
3572	}
3573	}
3574
3575	if {![string compare $c "\["]} {
3576	set quoteP 0
3577
3578	while {1} {
3579	append state(buffer) $c
3580
3581	switch -- $c/$quoteP {
3582	"\\/0" {
3583	set quoteP 1
3584	}
3585
3586	"\]/0" {
3587	return [set state(lastC) LX_DLITERAL]
3588	}
3589
3590	default {
3591	set quoteP 0
3592	}
3593	}
3594
3595	if {![string compare [set c [string index $state(input) 0]] ""]} {
3596	set state(buffer) "end-of-input during domain-literal"
3597	return [set state(lastC) LX_ERR]
3598	}
3599	set state(input) [string range $state(input) 1 end]
3600	}
3601	}
3602
3603	if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} {
3604	append state(buffer) $c
3605
3606	return [set state(lastC) [lindex $state(lexemeL) $x]]
3607	}
3608
3609	while {1} {
3610	append state(buffer) $c
3611
3612	switch -- [set c [string index $state(input) 0]] {
3613	"" - " " - "\t" - "\n" {
3614	break
3615	}
3616
3617	default {
3618	if {[lsearch -exact $state(tokenL) $c] >= 0} {
3619	break
3620	}
3621	}
3622	}
3623
3624	set state(input) [string range $state(input) 1 end]
3625	}
3626
3627	return [set state(lastC) LX_ATOM]
3628	}
3629
3630	# ::mime::mapencoding --
3631	#
3632	# mime::mapencodings maps tcl encodings onto the proper names for their
3633	# MIME charset type. This is only done for encodings whose charset types
3634	# were known. The remaining encodings return "" for now.
3635	#
3636	# Arguments:
3637	# enc The tcl encoding to map.
3638	#
3639	# Results:
3640	# Returns the MIME charset type for the specified tcl encoding, or ""
3641	# if none is known.
3642
3643	proc ::mime::mapencoding {enc} {
3644
3645	variable encodings
3646
3647	if {[info exists encodings($enc)]} {
3648	return $encodings($enc)
3649	}
3650	return ""
3651	}
3652
3653	# ::mime::reversemapencoding --
3654	#
3655	# mime::reversemapencodings maps MIME charset types onto tcl encoding names.
3656	# Those that are unknown return "".
3657	#
3658	# Arguments:
3659	# mimeType The MIME charset to convert into a tcl encoding type.
3660	#
3661	# Results:
3662	# Returns the tcl encoding name for the specified mime charset, or ""
3663	# if none is known.
3664
3665	proc ::mime::reversemapencoding {mimeType} {
3666
3667	variable reversemap
3668
3669	set lmimeType [string tolower $mimeType]
3670	if {[info exists reversemap($lmimeType)]} {
3671	return $reversemap($lmimeType)
3672	}
3673	return ""
3674	}
3675
3676	# ::mime::word_encode --
3677	#
3678	# Word encodes strings as per RFC 2047.
3679	#
3680	# Arguments:
3681	# charset The character set to encode the message to.
3682	# method The encoding method (base64 or quoted-printable).
3683	# string The string to encode.
3684	# ?-charset_encoded 0 or 1 Whether the data is already encoded
3685	# in the specified charset (default 1)
3686	# ?-maxlength maxlength The maximum length of each encoded
3687	# word to return (default 66)
3688	#
3689	# Results:
3690	# Returns a word encoded string.
3691
3692	proc ::mime::word_encode {charset method string {args}} {
3693
3694	variable encodings
3695
3696	if {![info exists encodings($charset)]} {
3697	error "unknown charset '$charset'"
3698	}
3699
3700	if {$encodings($charset) == ""} {
3701	error "invalid charset '$charset'"
3702	}
3703
3704	if {$method != "base64" && $method != "quoted-printable"} {
3705	error "unknown method '$method', must be base64 or quoted-printable"
3706	}
3707
3708	# default to encoded and a length that won't make the Subject header to long
3709	array set options [list -charset_encoded 1 -maxlength 66]
3710	array set options $args
3711
3712	if { $options(-charset_encoded) } {
3713	set unencoded_string [::encoding convertfrom $charset $string]
3714	} else {
3715	set unencoded_string $string
3716	}
3717
3718	set string_length [string length $unencoded_string]
3719
3720	if {!$string_length} {
3721	return ""
3722	}
3723
3724	set string_bytelength [string bytelength $unencoded_string]
3725
3726	# the 7 is for =?, ?Q?, ?= delimiters of the encoded word
3727	set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}]
3728	switch -exact -- $method {
3729	base64 {
3730	if { $maxlength < 4 } {
3731	error "maxlength $options(-maxlength) too short for chosen\
3732	charset and encoding"
3733	}
3734	set count 0
3735	set maxlength [expr {($maxlength / 4) * 3}]
3736	while { $count < $string_length } {
3737	set length 0
3738	set enc_string ""
3739	while { ($length < $maxlength) && ($count < $string_length) } {
3740	set char [string range $unencoded_string $count $count]
3741	set enc_char [::encoding convertto $charset $char]
3742	if { ($length + [string length $enc_char]) > $maxlength } {
3743	set length $maxlength
3744	} else {
3745	append enc_string $enc_char
3746	incr count
3747	incr length [string length $enc_char]
3748	}
3749	}
3750	set encoded_word [string map [list \n {}] \
3751	[base64 -mode encode -- $enc_string]]
3752	append result "=?$encodings($charset)?B?$encoded_word?=\n "
3753	}
3754	# Trim off last "\n ", since the above code has the side-effect
3755	# of adding an extra "\n " to the encoded string.
3756
3757	set result [string range $result 0 end-2]
3758	}
3759	quoted-printable {
3760	if { $maxlength < 1 } {
3761	error "maxlength $options(-maxlength) too short for chosen\
3762	charset and encoding"
3763	}
3764	set count 0
3765	while { $count < $string_length } {
3766	set length 0
3767	set encoded_word ""
3768	while { ($length < $maxlength) && ($count < $string_length) } {
3769	set char [string range $unencoded_string $count $count]
3770	set enc_char [::encoding convertto $charset $char]
3771	set qp_enc_char [qp_encode $enc_char 1]
3772	set qp_enc_char_length [string length $qp_enc_char]
3773	if { $qp_enc_char_length > $maxlength } {
3774	error "maxlength $options(-maxlength) too short for chosen\
3775	charset and encoding"
3776	}
3777	if { ($length + [string length $qp_enc_char]) > $maxlength } {
3778	set length $maxlength
3779	} else {
3780	append encoded_word $qp_enc_char
3781	incr count
3782	incr length [string length $qp_enc_char]
3783	}
3784	}
3785	append result "=?$encodings($charset)?Q?$encoded_word?=\n "
3786	}
3787	# Trim off last "\n ", since the above code has the side-effect
3788	# of adding an extra "\n " to the encoded string.
3789
3790	set result [string range $result 0 end-2]
3791	}
3792	"" {
3793	# Go ahead
3794	}
3795	default {
3796	error "Can't handle content encoding \"$method\""
3797	}
3798	}
3799
3800	return $result
3801	}
3802
3803	# ::mime::word_decode --
3804	#
3805	# Word decodes strings that have been word encoded as per RFC 2047.
3806	#
3807	# Arguments:
3808	# encoded The word encoded string to decode.
3809	#
3810	# Results:
3811	# Returns the string that has been decoded from the encoded message.
3812
3813	proc ::mime::word_decode {encoded} {
3814
3815	variable reversemap
3816
3817	if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
3818	- charset method string] != 1} {
3819	error "malformed word-encoded expression '$encoded'"
3820	}
3821
3822	set enc [reversemapencoding $charset]
3823	if {[string equal "" $enc]} {
3824	error "unknown charset '$charset'"
3825	}
3826
3827	switch -exact -- $method {
3828	b -
3829	B {
3830	set method base64
3831	}
3832	q -
3833	Q {
3834	set method quoted-printable
3835	}
3836	default {
3837	error "unknown method '$method', must be B or Q"
3838	}
3839	}
3840
3841	switch -exact -- $method {
3842	base64 {
3843	set result [base64 -mode decode -- $string]
3844	}
3845	quoted-printable {
3846	set result [qp_decode $string 1]
3847	}
3848	"" {
3849	# Go ahead
3850	}
3851	default {
3852	error "Can't handle content encoding \"$method\""
3853	}
3854	}
3855
3856	return [list $enc $method $result]
3857	}
3858
3859	# ::mime::field_decode --
3860	#
3861	# Word decodes strings that have been word encoded as per RFC 2047
3862	# and converts the string from the original encoding/charset to UTF.
3863	#
3864	# Arguments:
3865	# field The string to decode
3866	#
3867	# Results:
3868	# Returns the decoded string in UTF.
3869
3870	proc ::mime::field_decode {field} {
3871	# ::mime::field_decode is broken. Here's a new version.
3872	# This code is in the public domain. Don Libes <don@libes.com>
3873
3874	# Step through a field for mime-encoded words, building a new
3875	# version with unencoded equivalents.
3876
3877	# Sorry about the grotesque regexp. Most of it is sensible. One
3878	# notable fudge: the final $ is needed because of an apparent bug
3879	# in the regexp engine where the preceding .* otherwise becomes
3880	# non-greedy - perhaps because of the earlier ".*?", sigh.
3881
3882	while {[regexp {(.?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?])\?=)(.*)$} $field ignore prefix encoded field]} {
3883	# don't allow whitespace between encoded words per RFC 2047
3884	if {"" != $prefix} {
3885	if {![string is space $prefix]} {
3886	append result $prefix
3887	}
3888	}
3889
3890	set decoded [word_decode $encoded]
3891	foreach {charset - string} $decoded break
3892
3893	append result [::encoding convertfrom $charset $string]
3894	}
3895
3896	append result $field
3897	return $result
3898	}
3899

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/mime/mime.tcl @ 8597867d

Download in other formats: