diff options
| author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
|---|---|---|
| committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
| commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
| tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/mime | |
| parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
| parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
| download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 | |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/mime')
| -rw-r--r-- | tcllib/modules/mime/ChangeLog | 796 | ||||
| -rw-r--r-- | tcllib/modules/mime/README.html | 880 | ||||
| -rw-r--r-- | tcllib/modules/mime/README.txt | 804 | ||||
| -rw-r--r-- | tcllib/modules/mime/README.xml | 660 | ||||
| -rw-r--r-- | tcllib/modules/mime/badmail1.txt | 10 | ||||
| -rw-r--r-- | tcllib/modules/mime/badmail2.txt | 31 | ||||
| -rw-r--r-- | tcllib/modules/mime/mime.bench | 59 | ||||
| -rw-r--r-- | tcllib/modules/mime/mime.man | 405 | ||||
| -rw-r--r-- | tcllib/modules/mime/mime.tcl | 4010 | ||||
| -rwxr-xr-x | tcllib/modules/mime/mime.test | 609 | ||||
| -rw-r--r-- | tcllib/modules/mime/pkgIndex.tcl | 4 | ||||
| -rw-r--r-- | tcllib/modules/mime/rfc2629.dtd | 209 | ||||
| -rw-r--r-- | tcllib/modules/mime/smtp.man | 190 | ||||
| -rw-r--r-- | tcllib/modules/mime/smtp.tcl | 1508 |
14 files changed, 10175 insertions, 0 deletions
diff --git a/tcllib/modules/mime/ChangeLog b/tcllib/modules/mime/ChangeLog new file mode 100644 index 0000000..85f13c6 --- /dev/null +++ b/tcllib/modules/mime/ChangeLog @@ -0,0 +1,796 @@ +2014-01-08 Andreas Kupries <andreask@activestate.com> + + * pkgIndex.tcl: Last commit forgot to update the package index, + causing a mismatch. Fixed, likewise the Tcl requirement. + +2013-11-22 Andreas Kupries <andreask@activestate.com> + + * mime.tcl: (PoorYorick): general cleanup. use expr operators like + * mime.test: eq instead of string commands. (AK Notes): Version + bumped to 1.6, requirement bumped to Tcl 8.5. (AK) Updated + testsuite and doc Tcl requirements. Fixed the creative writing + problem of the initialization code, present before PY cleanup. + +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2013-01-09 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (::mime::buildmessage): [Bug 3565267]: Handle + * mime.man: possibility of 'errorCode' not set. Version + * pkgIndex.tcl: bumped to 1.5.6. + +2012-08-02 Andreas Kupries <andreask@activestate.com> + + * mime.man: [Bug 3354014]: Fixed typo in option name. -parts is + correct. (Note the trailing 's'). + +2012-02-23 Andreas Kupries <andreask@activestate.com> + + * mime.test: [Bug 3483716]: Added testcase, supplied by Christian + Nassau. Thank you. + +2012-02-22 Andreas Kupries <andreask@activestate.com> + + * mime.tcl: [Bug 3483716]: Accepted patch by Christian Nassau + * pkgIndex.tcl: <cnassau@users.sourceforge.net> to handle (decode) + the content transfer encodings base64 and quoted-printable. Bumped + version to 1.5.5. + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2011-01-20 Andreas Kupries <andreask@activestate.com> + + * smtp.man: [ActiveState 89180]: Added documentation about the + soft-dependencies required for SMTP authentication, i.e. SASL. + +2010-07-06 Andreas Kupries <andreask@activestate.com> + + * smtp.man: [Bug 3011581]: Accepted tweak to the documentation of + the -header option proposed by <rich123@users.sf.net> to make + the syntax clearer. + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Bumped version to 1.5.4, for the change made on + * smtp.man: 2007-10-08 by Pat. Was a bugfix, should have bumped + * pkgInsdex.tcl: the version at that time. + +2008-05-23 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (::mime::parsepart): [SF Tcllib Bug 1961881]. Accepted + * mime.man: patch, and extended. Now handling malformed input + * mime.test: without having to throw an eror, and without going + * pkgIndex.tcl: into an infinite loop. See also [Bug 631314], and + Changelog entries 2003-06-06, 2003-06-25. The testcases + mime-3.{7,8} are not redundant, but significantly different. 3.7 + actually has a terminating boundary, but misses the starting + one, causing non-recognition of any terminating one. Bumped the + version to 1.5.4. + +2007-11-05 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (::mime::parsepart): Fixed [SF Tcllib Bug 1825092], + * mime.test: as reported by Max Strobel + * pkgIndex.tcl: <mstrhh@users.sourceforge.net>. The code parsing + * mime.man: multiparts assumed that eol sequences are always two + characters (cr+lf), this however may not be the case. This + caused the parser to miscount the last line in a part and + wrongly remove its last character from the part. Extended the + testsuite, and bumped the version to 1.5.3. + +2007-10-08 Pat Thoyts <patthoyts@users.sourceforge.net> + + * mime.tcl: bug #1658061: reset errorInfo after catches known + * smtp.tcl: to fail to avoid confusion. + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl (::mime::word_encode): Unbreak the unconditional + line-breaking performed by some of the base64 encoders we use. + +2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.man: Fixed all warnings due to use of now deprecated + * smtp.man: commands. Added a section about how to give feedback. + +2007-01-25 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Expose -client option to enable user to supply the + * smtp.man: string used for the HELO/EHLO challenge. + Closes FR #1614860. + +2007-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl (word_encode): Ensured the return of the empty string + when given the empty string. + +2006-11-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: bug #827436 - ensure data section is terminated with + CRLF.CRLF on the non Trf code path. + +2006-10-25 Andreas Kupries <andreask@activestate.com> + + * mime.tcl: Applied patch for [SF Tcllib Bug 763731], fixing + * mime.man: word_encode's problem with creating words which are + * pkgIndex.tcl: too long. Version now is 1.5.2 + +2006-10-24 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (::mime::qp_encode): Moved the code for chopping off a + superfluous newline into the branch actually adding it. The + unconditional chop caused it to lose the last character if the + branch was not taken. This bug was apparently introduced by the + patch for [SF Tcllib RFE 503336], added 2002-01-16, by + myself. Reported by Gustaf Neumann <neumann@wu-wien.ac.at>, with + a patch. + +2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Rewritten to use new features for handling the + environment. + +2006-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Updated the three tests affected by the bugfix (see + 2006-10-02 entry). + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-10-02 Andreas Kupries <andreask@activestate.com> + + * mime.tcl: Fixed both ::mime::copymessageaux and + * mime.man: ::mime::buildmessageaux to not generate too many + * pkgIndex.tcl: CRLF's at the end of bodies. + See [SF Tcllib Bug 1213527, and [SF Tcllib Patch 1254934]. + Bumped version to 1.5.1. + +2006-09-19 Andreas Kupries <andreask@activestate.com> + + * mime.man: Bumped version to 1.5 + * mime.tcl: + * pkgIndex.tcl: + +2006-01-30 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Fixed handling of "env". + +2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Fixed use of duplicate test names. + +2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: More boilerplate simplified via use of test support. + +2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Hooked into the new common test support code. + +2006-01-10 Andreas Kupries <andreask@activestate.com> + + * performance.tcl: Removed the unstructured benchmarks. + * mime.bench: New file, contains structured benchmarks for the + module. This fixes [SF Tcllib Bug 1373935]. + +2006-01-10 Andreas Kupries <andreask@activestate.com> + + * mime.tcl: Ensured that all accesses to the variable 'major' + operate on a global variable. Fix for [SF Tcllib Bug 1394840], + reported by George Orwell <orwellian@users.sourceforge.net>. + +2005-11-06 Benjamin Riefenstahl <b.riefenstahl@turtle-trading.net> + + * mime.tcl (parsedatetime): Add support for timezones with format + +NNNN or -NNNN. Add support for property "clock". + * mime.test (mime-9.x): Add testing of parsedatetime.=20 + +2005-11-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Applied patch by Benjamin Riefenstahl fixing bugs in + his patch for [SF Tcllib Bug 1276561], see 2005-10-04 entry. + + * (MONTHS_SHORT, MONTHS_LONG): Add a dummy entry at index 0. + * (parsedatetime): For month index, use "%m" + scan instead of + wrong "%e". + +2005-10-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-10-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Synchronized version numbers to the + * smtp.man: implementation. + +2005-10-07 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Use the SASL module for authentication. Checked this + against sendmail+cyrussasl and Microsoft SMTPd (for NTLM). + +2005-10-04 Andreas Kupries <andreask@activestate.com> + + * mime.tcl: Applied patch for [SF Tcllib Bug 1276561] by Benjamin + Riefenstahl. Fixes the handling of date/times, removing + dependencies on the current locale. + +2005-09-05 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl (::smtp::auth_CRAM-MD5): Fix for bug #1242629 - qmail + doesn't like a multi-line response. + +2005-03-08 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (::mime::copymessageaux): Removed usage of the command + 'unstack'. Its presence is a bug ever since revision 1.3 (March + 9, 2000) of mime.tcl, when the converters (base64, + quoted-printable) started to be used in immediate mode instead + of attaching them to the output channel. This also means that we + do not need the fallback implementation anymore either. + + Many thanks to Roy Terry <royterry@earthlink.net> for keeping up + the nagging about [SF Tcllib Bug 754920] which demonstrated the + problem. + + What happened is that the unpaired 'unstack' removes the outer + .-transformation and a second call may close the channel. If + that happens any further access to the channel errors out, and + the mail server gets and transfers an incomplete mail message. + It is a 'may' and not a 'will' because it seems that sometimes + the channel has a refcount > 0 and then 'unstack' does + nothing. This part made the reproduction difficult. It was + originally suspected to be a problem in Trf itself, but is + actually a problem in how it is used by mime. + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-08-04 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Do not try to authenticate if no username is + supplied. + +2004-07-08 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.man: Added mention of DIGEST-MD5 support and put some + RFC references in. + +2004-07-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Cleaned up some hardcoded settings left from + development. (oops). + +2004-07-02 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Added SASL mechanism DIGEST-MD5 authentication + support. Also redid md5 package version abstraction. + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Updated smtp to version 1.4, to reflect the + * smtp.man: extensions made to it (Authentication). This + * pkgIndex.tcl: also distinguishes the main line version from the + one in the 1.6 branch. + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Downgraded mime to version 1.3.6, and removed the + * mime.man: -decode extension from the API. This branch is for + * pkgIndex.tcl: bugfixes only. + +2004-05-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Fixed [SF Tcllib Bug 954328]. Same bug in different + guise. This package exclusively required md5 v2. This clashed + with mime's requirement of v1. Now package smtp also adapts at + runtime to whatever version of package md5 has been loaded. + + * mime.test: + * mime.tcl: Fixed [SF Tcllib Bug 954328]. The package mime now + adapts at runtime to whatever version of package md5 has been + loaded. + +2004-05-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl (::smtp::wdata): Fixed [SF Tcllib Bug 951568]. Added + handlers for the query/* commands from Trf. Also changed the + default to sliently pass all unknowns in the future. + +2004-05-10 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (copymessageaux): Applied the patch for [SF Tcllib Bug + 893516] on behalf of Marshall Rose. The problem was found by + Todd Copeland <todd.copeland@pervasive.com>, he provided the + patch as well. + +2004-05-04 Andreas Kupries <andreask@activestate.com> + + * mime.man: + * mime.test: + * mime.tcl: Applied [SF Tcllib Patch 763712]. This extends the + functionality of mime::getbody with decoding of the mime part + based on the specified charset into the regular utf8 + form. Testsuite was updated and extended as well. Thanks to + Matthew Walker <gunzel@users.sourceforge.net> for the + work. Updated the documentation for mime on my own. Bumped + version to 1.4. + + * mime:test: + * mime.tcl: Applied [SF Tcllib Patch 758742], adding many more + MIME types for encodings to the knowledge-base of the + package. Thanks to Matthew Walker <gunzel@users.sourceforge.net> + for the work, and Mikhail Teterin <kot@users.sourceforge.net> + for prodding. Bumped version to 1.3.5. + + * mime.test: + * mime.tcl (copymessageaux): Fixed [SF Tcllib Bug 620852]. Added + '-nonewline' to the puts statements which wrote out the chunks + read from the file associated with the mime part, converted or + not. As the data was [read] we had no business of adding eol's + during writing as well. Thanks to Jasper Taylor + <jaspert@users.sourceforge.net> for the report, and his + patience. Added a test for this as well, using files of similar + size as originally provided. + +2004-03-18 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Added support for RFC 2554 - SMTP Authentication. This + included support for the SASL mechanisms CRAM-MD5 and PLAIN and + the Microsoft LOGIN mechanism. This has been tested against + Microsoft Exchange servers and Sendmail 8.12. + Added support for RFC 1870, the SIZE extension. + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2004-02-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Fixed access to files, was not done with + tcltest::testDirectory, causing them to be inaccessible + for 8.4+. The result in mime-2.2 was also dependent on the exact + order of keys retrieved from the array of parameters. Rewritten + to take this into account. + +2004-01-30 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Better handling of failure in TLS setup. Added a + policy command to control TLS policy on failure. + +2004-01-29 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtp.tcl: Added support for the STARTTLS extension (RFC 3207). + This may also support old versions that report a TLS option in + reply to EHLO, but these are not tested. + +2003-11-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl (word_decode): Fixed [SF Tcllib Bug 764702], accepted + the patch coming with the bugreport (both by Reinhard Speyerer + <rspsf@users.sourceforge.net>). Command is now able to decode + data in encoded utf-8. + + * mime.test: Added test for the bug above. + +2003-11-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl (smtp::hear): Integrated fix for [Bug 836442]. Limiting + seconds to 600 to prevent integer wraparound when setting up a + timer event. Bug reported (and fix provided) by Andreas Otto, + and accepted by Marshall Rose. + +2003-06-25 David N. Welton <davidw@dedasys.com> + + * mime.tcl (::mime::parsedatetime): Use string map instead of + regsub - it's faster. + + * mime.test: Added tests which operate on the bad files below. + + * badmail2.txt: Added second piece of mail for testing. If they + turn out to be redundant, we can erase one. + + * badmail1.txt: Added mail for testing that triggers bug 631314. + +2003-06-06 Andreas Kupries <andreask@activestate.com> + + * mime.tcl (::mime::word_decode): Accept lower-case encoding + specifiers. [Bug 732512]. Reported by Matthew Walker + <gunzel@users.sourceforge.net>, plus patch. Patch accepted by + Marshall Rose. + + * mime.test: Two more tests checking the acceptance of lower-case + encoding specifiers. + + * mime.tcl (::mime::parsepart): Reactivated error command, revert + to error on malformed mime input, instead of infinite + looping. [Bug 631314] reported by David Welton. + +2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-05-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Applied patch for SF Tcllib bug #731759, as submitted + * mime.test: by Matthew Walker <gunzel@users.sourceforge.net> and + accepted by Marshall Rose <mrose@users.sourceforge.net>. + Update of the testsuite on my own. + +2003-04-25 Andreas Kupries <andreask@activestate.com> + + * mime.man: Added a section for known bugs, and recorded 447037 as + such. + +2003-04-10 Andreas Kupries <andreask@activestate.com> + + * smtp.tcl: + * mime.tcl: + * mime.man: + * csmtp.man: + * pkgIndex.tcl: Fixed bug #614591. Set version of the package to + to 1.3.3. Fixed equivalent of bug #648679. + +2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.man: More semantic markup, less visual one. + * smtp.man: + +2003-01-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * mime.tcl (md5): Fix for bug # 630381. Use tcllib md5 to handle + Trf transparency. + +2002-10-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.man: Changed -parse to -part in description of + "::mime::initialize". Thanks to "Gerald W. Lester" + <gerald.lester@cox.net> for finding this. + +2002-09-16 David N. Welton <davidw@dedasys.com> + + * smtp.man: Added example from http://mini.net/tcl/1256. + +2002-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.test: Extended field_decode tests with the examples from + RFC 2047. + + * mime.tcl: Integrated new implementation of 'field_decode' + provided by Don Libes <don@libes.com>. This rewrite correctly + decodes all seven examples of RFC 2047. The old version decoded + only one correctly. + +2002-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Accepted patch in SF FR #595240, provided by Marshall + T. Rose <mrose@users.sourceforge.net>. The patch makes the code + more robust with respect to a common mime encoding error. + + * tcllib/examples/mime: Added an example application making use of + mime and smtp packages. Mbot is a highly-specialized filter for + personal messages. Again this is code provided to us by Marshall + T. Rose. + + * smtp.tcl: Followup patch to patch SF #557520/2. A line of code + initializing the options from the state was missing in one + command, causing problems with the usage of -maxsecs. This was + noted on c.l.t., by Acacio Cruz. The followup patch was provided + by Todd Coram. + +2002-07-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Applied patch SF #557520/2 (== SF #558132) supplied by + Todd Coram <tcoram@users.sourceforge.net>on behalf of Marshall + Rose <mrose@users.sourceforge.net>. This patch dispenses with + the automatic calculation of a timeout value and goes with a + user-supplied value (new option -maxsecs) instead. Default for + this option is 120 secs. This fixes bug SF #557040. + + * performance.tcl: New file. Script supplied by Pascal Scheffers + (see below) to test the performance of the mime package. + + * mime.tcl: Applied patch SF #585455 supplied by Pascal Scheffers + <pascalscheffers@users.sourceforge.net> on behalf of Marshall + Rose <mrose@users.sourceforge.net>. This patch speeds up MIME + processing by using [split \n] and list ops to iterate over the + lines in the mail instead of using [string range] for doing it + incrementally, copying unprocessed data down again and again. + +2002-06-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Fixed bug SF #548832. Report and patch by Michael + A. Cleverly <cleverly@users.sourceforge.net>. + +2002-05-29 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl (smtp::initialize): Fixed SF bug #561416. The reporter + is unknown and provided the fix too. Fix approved by Marshall + Rose <mrose@users.sourceforge.net>. + +2002-05-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Accepted patch for SF bug #553784, by Don Porter + <dgp@users.sourceforge.net>. + + * smtp.tcl: Applied patch for SF bug #539952, on behalf of + Marshall Rose <mrose@users.sourceforge.net>. The part of the + patch regarding "mime.tcl" was already in the CVS, as part of + the fix for SF #477088, see 2001-11-01. + +2002-04-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Applied patch for SF bug #547336 on behalf of Marshall + Rose <mrose@users.sourceforge.net>. Bug was reported by Don + Porter <dgp@users.sourceforge.net>. This removes the duplicate + [package require Trf] we had before. + +2002-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.man: Added doctools manpage. + * smtp.man: Added doctools manpage. + +2002-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Accepted patch by Simon Scott + <sjscott@users.sourceforge.net>, with slight modification. Fixes + bug #533025. + +2002-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl: Accepted patch for bug #519623 by Rolf Ade + <rolf@pointsman.de>. + +2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Version set to 1.3.2 to differentiate the development code from + the 1.2 release containing 1.3.1. + + * mime.n: Applied patch 511692 provided by Larry Virden + <lvirden@users.sourceforge.net> fixing a formatting problem. + +2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Bumped version to 1.3.1 + +2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Fixed bug #499242. Extended the non-trf branch of + smtp::wtextaux to detect and transform bare LF's into proper + CR/LF sequences. + +2002-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.tcl (qp_encode): Implemented FR #503336, added + 'no_softbreak' flag to qp_encode. Default value is false, giving + the original behaviour. If set the encoded data is not broken + into multiple lines, even if longer than 72 characters. + +2001-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.n: Clarified documentation for 'parseaddress' in the wake + of bug #479174 as this is the command which actually handles the + value of option -recipients mentionend below. + + * smtp.n: Fixed bug #479144, clarified contents of value for + -recipients. Bug reported by Darren New + <dnew@users.sourceforge.net>. + +2001-11-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: Fixed bug #472009. Changes in the handling of + script-level transformations cause the system to try to + initialize the read side of the 'smtp::wdata' + transformation. This fails. Added a dummy create/read branch to + the switch. Reported by 'nobody/anonymous', but possibly Andreas + Otto (deduced from the specified example). + + * mime.tcl: Added informaton about 7bit, 8bit, and binary encoding + to the places where it is missing. This fixes SF item + #477088. Bug was reported by Oliver Bienert + <obienert@users.sourceforge.net>. + +2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * mime.n: + * mime.tcl: + * smtp.n: + * smtp.tcl: + * pkgIndex.tcl: Version up to 1.3 + +2001-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Added manpages for smtp and mime packages. + +2001-08-01 Jeff Hobbs <jeffh@ActiveState.com> + + * mime.tcl: made package require 8.3 and sped up qp_encode and + qp_decode. + +2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: + * mime.tcl: Frink 2.2 run, fixed dubious code. + +2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtp.tcl: + * mime.tcl: Fixed dubious code reported by frink and procheck. + +2001-01-30 Eric Melski <ericm@interwoven.com> + + * mime.tcl: Applied patch from Peter MacDonald to correct problem + with mime::initialize failing when mailers neglect to include + the trailing boundary marker. + +2000-09-20 Dan Kuchler <kuchler@ajubasolutions.com> + + * smtp.tcl + * mime.tcl: namespaced the procs that are created to replace + the Trf functions when Trf isn't available. This way they + are not created in the global namespace, and there isn't any + risk that they will collide with other global functions. + +2000-09-04 Dan Kuchler <kuchler@ajubasolutions.com> + + * README.xml + * README.txt + * README.html + * mime.tcl: Added proc header comment blocks to all procedures. + Some are better than others, and they were written based on a + quick analysis of the code and the documentation in the README + file. They should be updated as they change or are found to be + inaccurate. + +2000-09-01 Dan Kuchler <kuchler@ajubasolutions.com> + + * mime.tcl + * mime.test: Integrated a patch from Laurent Riesterer + (riesterer@celar.fr). This patch added three new procedures + (mime::word_encode, mime::word_decode, and mime::field_decode) + The patch also adds support for word encoded items as defined + in RFC 2047. Fixed a bug in the quoted printable encode function + mime::qp_encode + +2000-08-15 Dan Kuchler <kuchler@ajubasolutions.com> + + * mime.tcl + * smtp.tcl: Made fixes so that smtp::sendmessage and + mime::buildmessage work properly. Fixed a bug where + the "." at the start of a line was not being replaced + by a ".." This was fine in base64 or in the default + quoted printable, but was clearly broken in 8-bit or + 7-bit encodings. + +2000-08-11 Eric Melski <ericm@ajubasolutions.com> + + * README.xml: + * README.html: + * README.txtl: Clarified information about soft-dependancy on Trf. + +2000-08-03 Dan Kuchler <kuchler@ajubasolutions.com> + + * README.txt + * README.xml + * README.html + * mime/smtp.tcl: Added a '-ports' option to smtp::sendmessage. + The '-ports' option takes a list that should mirror the list of + SMTP servers specified with the '-servers' flag. Documented the + mime::reversemapencodings, mime::mapencodings, and + smtp::buildmessage functions + + * mime/mime.tcl: Added mime::mapencoding and + mime::reversemapencoding functions to map tcl encodings + to their charset types, and back again. + + * mime/pkgIndex.tcl: Bumped the revision number from 1.1 to 1.2 + +2000-06-21 Sandeep Tamhankar <sandeep@scriptics.com> + + * mime/smtp.tcl: Undid the #5693 fix. It turns out there are + situations where this is the desired behavior. The basic idea is + that the -recipients value is used in the SMTP envelope, and + should not be mixed with message headers. Basically, they're two + totally different things. I commented all the code and cleaned up + some of the areas where side effects were being used unnecessarily + and making the code hard to read. + +2000-05-24 Sandeep Tamhankar <sandeep@scriptics.com> + + * mime/smtp.tcl: Fixed bug 5693, where the "To:" header wasn't + being sent with an e-mail when using the -recipients flag of + smtp::sendmessage. Also, if -recipients was combined with -header + "To ..." or -header "Cc ...", it would send the message only to + -recipients (which is documented) but it would leave the Cc and To + headers, which are wrong. This is also fixed. + +2000-05-23 Sandeep Tamhankar <sandeep@scriptics.com> + + * mime/mime.tcl + * mime/mime.test: Fixed bugs 5521 and 5659, where qp_encode and + qp_decode had numerous bugs. See #5659 for details. + +2000-05-22 Sandeep Tamhankar <sandeep@scriptics.com> + + * mime/smtp.tcl: Fixed a bug where if the requested mail server + didn't exist (i.e. the host didn't have an SMTP server running), + smtp::sendmessage would continue executing until a horrific crash + at a later point. I added the check and proper error reporting. + +2000-05-06 Sandeep Tamhankar <sandeep@scriptics.com> + + * mime/smtp.tcl: Fixed bug 5383, where smtp wouldn't work because + it had a dependency on Trf. I've patched the code, and it seems + to work fine now. + +2000-04-25 Sandeep Tamhankar <sandeep@scriptics.com> + + * modules/mime/mime.test: Added a somewhat rudimentary test suite + for TclMIME. Found what I believe is a minor bug in the package, + but decided not to fix it (and just let the relevant test fail) + until I can discuss it with Brent. + +2000-03-07 Brent Welch <welch@scriptics.com> + + * modules/mime/mime.tcl: Modified this to have a soft dependency on + the Trf package. If it is available then the encoding and decoding + of MIME base64 and quoted-printable will run faster. + Also added mime::buildmessage that creates the structured MIME message + in a string and returns that - much like mime::copymessage that + copies the message to a channel. diff --git a/tcllib/modules/mime/README.html b/tcllib/modules/mime/README.html new file mode 100644 index 0000000..16aa020 --- /dev/null +++ b/tcllib/modules/mime/README.html @@ -0,0 +1,880 @@ +<html><head><title>The README file: Tcl MIME</title> +<meta http-equiv="Expires" content="Wed, 23 Feb 2000 04:36:30 +0000"> +<STYLE type='text/css'> + .title { color: #990000; font-size: 22px; line-height: 22px; font-weight: bold; text-align: right; + font-family: helvetica, arial, sans-serif } + .filename { color: #666666; font-size: 18px; line-height: 28px; font-weight: bold; text-align: right; + font-family: helvetica, arial, sans-serif } + p.copyright { color: #000000; font-size: 10px; + font-family: verdana, charcoal, helvetica, arial, sans-serif } + p { margin-left: 2em; margin-right: 2em; } + ol { margin-left: 2em; margin-right: 2em; } + ul.text { margin-left: 2em; margin-right: 2em; } + pre { margin-left: 3em; color: #333333 } + ul.toc { color: #000000; line-height: 16px; + font-family: verdana, charcoal, helvetica, arial, sans-serif } + H3 { color: #333333; font-size: 16px; line-height: 16px; font-family: helvetica, arial, sans-serif } + H4 { color: #000000; font-size: 14px; font-family: helvetica, arial, sans-serif } + TD.header { color: #ffffff; font-size: 10px; font-family: arial, helvetica, san-serif; valign: top } + TD.author-text { color: #000000; font-size: 10px; + font-family: verdana, charcoal, helvetica, arial, sans-serif } + TD.author { color: #000000; font-weight: bold; margin-left: 4em; font-size: 10px; font-family: verdana, charcoal, helvetica, arial, sans-serif } + A:link { color: #990000; font-size: 10px; text-transform: uppercase; font-weight: bold; + font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif } + A:visited { color: #333333; font-weight: bold; font-size: 10px; text-transform: uppercase; + font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif } + A:name { color: #333333; font-weight: bold; font-size: 10px; text-transform: uppercase; + font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif } + .link2 { color:#ffffff; font-weight: bold; text-decoration: none; + font-family: monaco, charcoal, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif; + font-size: 9px } + .RFC { color:#666666; font-weight: bold; text-decoration: none; + font-family: monaco, charcoal, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif; + font-size: 9px } + .hotText { color:#ffffff; font-weight: normal; text-decoration: none; + font-family: charcoal, monaco, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif; + font-size: 9px } +</style> +</head> +<body bgcolor="#ffffff"alink="#000000" vlink="#666666" link="#990000"> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<table width="66%" border="0" cellpadding="0" cellspacing="0"><tr><td><table width="100%" border="0" cellpadding="2" cellspacing="1"> +<tr valign="top"><td width="33%" bgcolor="#666666" class="header">The README file</td><td width="33%" bgcolor="#666666" class="header">M.T. Rose</td></tr> +<tr valign="top"><td width="33%" bgcolor="#666666" class="header"> </td><td width="33%" bgcolor="#666666" class="header">Dover Beach Consulting, Inc.</td></tr> +<tr valign="top"><td width="33%" bgcolor="#666666" class="header"> </td><td width="33%" bgcolor="#666666" class="header">February 22, 2000</td></tr> +</table></td></tr></table> +<div align="right"><font face="monaco, MS Sans Serif" color="#990000" size="+3"><b><br><span class="title">Tcl MIME</span></b></font></div> +<font face="verdana, helvetica, arial, sans-serif" size="2"> + +<h3>Abstract</h3> + +<p> +Tcl MIME generates and parses MIME body parts. +</p> +<a name="toc"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>Table of Contents</h3> +<ul compact class="toc"> +<b><a href="#anchor1">1.</a> +SYNOPSIS<br></b> +<b><a href="#anchor2">1.1</a> +Requirements<br></b> +<b><a href="#anchor3">1.2</a> +Copyrights<br></b> +<b><a href="#anchor4">2.</a> +SYNTAX<br></b> +<b><a href="#anchor5">3.</a> +SEMANTICS<br></b> +<b><a href="#mime_initialize">3.1</a> +mime::initialize<br></b> +<b><a href="#mime_finalize">3.2</a> +mime::finalize<br></b> +<b><a href="#mime_getproperty">3.3</a> +mime::getproperty<br></b> +<b><a href="#mime_getheader">3.4</a> +mime::getheader<br></b> +<b><a href="#mime_setheader">3.5</a> +mime::setheader<br></b> +<b><a href="#mime_getbody">3.6</a> +mime::getbody<br></b> +<b><a href="#mime_copymessage">3.7</a> +mime::copymessage<br></b> +<b><a href="#mime_buildmessage">3.7</a> +mime::buildmessage<br></b> +<b><a href="#smtp_sendmessage">3.8</a> +smtp::sendmessage<br></b> +<b><a href="#mime_parseaddress">3.9</a> +mime::parseaddress<br></b> +<b><a href="#mime_parsedatetime">3.10</a> +mime::parsedatetime<br></b> +<b><a href="#mime_mapencoding">3.10</a> +mime::mapencoding<br></b> +<b><a href="#mime_reversemapencoding">3.10</a> +mime::reversemapencoding<br></b> + +<b><a href="#anchor6">4.</a> +EXAMPLES<br></b> +<b><a href="#rfc.references">§</a> +References<br></b> +<b><a href="#rfc.authors">§</a> +Author's Address<br></b> +<b><a href="#anchor7">A.</a> +TODO List<br></b> +<b><a href="#anchor8">B.</a> +Acknowledgements<br></b> +</ul> +<br clear="all"> + +<a name="anchor1"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>1. SYNOPSIS</h3> +</font><pre> + package provide mime 1.2 + package provide smtp 1.2 +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +Tcl MIME is an implementation of a Tcl package that generates and +parses <a href="#RFC2045">MIME</a>[1] body parts. +</p> + +<p> +Each MIME part consists of a header +(zero or more key/value pairs), +an empty line, +and a structured body. +A MIME part is either a "leaf" or has (zero or more) subordinates. +</p> + +<p> +MIME defines four keys that may appear in the headers: + +<blockquote class="text"><dl> + +<dt> Content-Type:</dt> +<dd> +describes the data contained in the body +("the content"); +</dd> + +<dt> Content-Transfer-Encoding:</dt> +<dd> +describes how the content is +encoded for transmission in an ASCII stream; +</dd> + +<dt> Content-Description:</dt> +<dd> +a textual description of the +content; and, +</dd> + +<dt> Content-ID:</dt> +<dd> +a globally-unique identifier for the +content. +</dd> + +</dl></blockquote> + +</p> + +<p> +Consult <a href="#RFC2046">[2]</a> for a list of standard content types. +Further, +consult <a href="#RFC822">[3]</a> for a list of several other header keys +(e.g., "To", "cc", etc.) +</p> + +<p> +A simple example might be: +</p> +</font><pre> + Date: Sun, 04 July 1999 10:38:25 -0600 + From: Marshall Rose <mrose@dbc.mtview.ca.us> + To: Andreas Kupries <a.kupries@westend.com> + cc: dnew@messagemedia.com (Darren New) + MIME-Version: 1.0 + Content-Type: text/plain; charset="us-ascii" + Content-Description: a simple example + Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us> + + Here is the body. In this case, simply plain text. +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +In addition to an implementation of the mime package, +Tcl MIME includes an implementation of the smtp package. +</p> + +<h4><a name="anchor2">1.1</a> Requirements</h4> + +<p> +This package requires: + +<ul class="text"> + +<li> +<a href="http://www.scriptics.com/software/8.1.html">Tcl/Tk version 8.0.3</a> +or later +</li> +</ul> +</p> +<p> +In addition, this package requires one of the following: + +<ul class="text"> +<li> +<a href="http://www.oche.de/~akupries/soft/trf/">Trf version 2.0p5</a> or later +</li> +<li> +<a href="http://dev.ajubasolutions.com/software/tcllib/">base 64 +version 2.0</a> or later (included with tcllib) +</li> +</ul> +</p> +<p> +If it is available, Trf will be used to provide better performance; +if not, Tcl-only equivalent functions, based on the base64 package, are used. +</p> + +<h4><a name="anchor3">1.2</a> Copyrights</h4> + +<p> +(c) 1999-2000 Marshall T. Rose +</p> + +<p> +Hold harmless the author, and any lawful use is allowed. +</p> + +<a name="anchor4"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>2. SYNTAX</h3> + +<p> +<a href="#mime_initialize">mime::initialize</a> +returns a token. +Parameters: +</p> +</font><pre> ?-canonical type/subtype + ?-param {key value}?... + ?-encoding value? + ?-header {key value}?... ? + (-file name | -string value | -parts {token1 ... tokenN}) +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_finalize">mime::finalize</a> returns +an empty string. +Parameters: +</p> +</font><pre> token ?-subordinates "all" | "dynamic" | "none"? +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_getproperty">mime::getproperty</a> +returns a string or a list of strings. +Parameters: +</p> +</font><pre> token ?property | -names? +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_getheader">mime::getheader</a> returns +a list of strings. +Parameters: +</p> +</font><pre> token ?key | -names? +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_setheader">mime::setheader</a> returns +a list of strings. +Parameters: +</p> +</font><pre> token key value ?-mode "write" | "append" | "delete"? +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_getbody">mime::getbody</a> returns a string. +Parameters: +</p> +</font><pre> ?-command callback ?-blocksize octets? ? +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_copymessage">mime::copymessage</a> +returns an empty string. +Parameters: +</p> +</font><pre> token channel +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_buildmessage">mime::buildmessage</a> +returns a string. +Parameters: +</p> +</font><pre> token +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#smtp_sendmessage">smtp::sendmessage</a> +returns a list. +Parameters: +</p> +</font><pre> token ?-servers list? ?-ports list? + ?-queue boolean? ?-atleastone boolean? + ?-originator string? ?-recipients string? + ?-header {key value}?... +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_parseaddress">mime::parseaddress</a> +returns a list of serialized arrays. +Parameters: +</p> +</font><pre> string +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_parsedatetime">mime::parsedatetime</a> +returns a string. +Parameters: +</p> +</font><pre> [string | -now] property +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_mapencoding">mime::mapencoding</a> +returns a string. +Parameters: +</p> +</font><pre> encoding_name +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +<a href="#mime_reversemapencoding">mime::reversemapencoding</a> +returns a string. +Parameters: +</p> +</font><pre> mime_charset +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<a name="anchor5"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>3. SEMANTICS</h3> + +<h4><a name="mime_initialize">3.1</a> mime::initialize</h4> + +<p> +mime::initialize creates a MIME part: + +<ul class="text"> + +<li> +If the -canonical option is present, +then the body is in canonical (raw) form and is found by consulting +either the -file, -string, or -part option. +<br> +<br> + +In addition, +both the -param and -header options may occur zero or more times to +specify "Content-Type" parameters (e.g., "charset") +and header keyword/values (e.g., "Content-Disposition"), +respectively. +<br> +<br> + +Also, -encoding, if present, +specifies the "Content-Transfer-Encoding" when copying the body. +</li> + +<li> +If the -canonical option is not present, +then the MIME part contained in either the -file or the -string option +is parsed, +dynamically generating subordinates as appropriate. +</li> + +</ul> + +</p> + +<h4><a name="mime_finalize">3.2</a> mime::finalize</h4> + +<p> +mime::finalize destroys a MIME part. +</p> + +<p> +If the -subordinates option is present, +it specifies which subordinates should also be destroyed. +The default value is "dynamic". +</p> + +<h4><a name="mime_getproperty">3.3</a> mime::getproperty</h4> + +<p> +mime::getproperty returns the properties of a MIME part. +</p> + +<p> +The properties are: +</p> +</font><pre> + property value + ======== ===== + content the type/subtype describing the content + encoding the "Content-Transfer-Encoding" + params a list of "Content-Type" parameters + parts a list of tokens for the part's subordinates + size the approximate size of the content (unencoded) +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +The "parts" property is present only if the MIME part has +subordinates. +</p> + +<p> +If mime::getproperty is invoked with the name of a specific property, +then the corresponding value is returned; +instead, +if -names is specified, +a list of all properties is returned; +otherwise, +a serialized array of properties and values is returned. +</p> + +<h4><a name="mime_getheader">3.4</a> mime::getheader</h4> + +<p> +mime::getheader returns the header of a MIME part. +</p> + +<p> +A header consists of zero or more key/value pairs. +Each value is a list containing one or more strings. +</p> + +<p> +If mime::getheader is invoked with the name of a specific key, +then a list containing the corresponding value(s) is returned; +instead, +if -names is specified, +a list of all keys is returned; +otherwise, +a serialized array of keys and values is returned. +Note that when a key is specified (e.g., "Subject"), +the list returned usually contains exactly one string; +however, +some keys (e.g., "Received") often occur more than once in the header, +accordingly the list returned usually contains more than one string. +</p> + +<h4><a name="mime_setheader">3.5</a> mime::setheader</h4> + +<p> +mime::setheader writes, appends to, or deletes the value associated +with a key in the header. +</p> + +<p> +The value for -mode is one of: + +<blockquote class="text"><dl> + +<dt> write:</dt> +<dd> + the key/value is either created or +overwritten (the default); +</dd> + +<dt> append:</dt> +<dd> + a new value is appended for the key +(creating it as necessary); or, +</dd> + +<dt> delete:</dt> +<dd> + all values associated with the key are removed +(the "value" parameter is ignored). +</dd> + +</dl></blockquote> + +</p> + +<p> +Regardless, +mime::setheader returns the previous value associated with the key. +</p> + +<h4><a name="mime_getbody">3.6</a> mime::getbody</h4> + +<p> +mime::getbody returns the body of a leaf MIME part in canonical form. +</p> + +<p> +If the -command option is present, +then it is repeatedly invoked with a fragment of the body as this: +</p> +</font><pre> + uplevel #0 $callback [list "data" $fragment] +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +(The -blocksize option, +if present, +specifies the maximum size of each fragment passed to the +callback.) +</p> + +<p> +When the end of the body is reached, +the callback is invoked as: +</p> +</font><pre> + uplevel #0 $callback "end" +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +Alternatively, +if an error occurs, +the callback is invoked as: +</p> +</font><pre> + uplevel #0 $callback [list "error" reason] +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +Regardless, +the return value of the final invocation of the callback is propagated +upwards by mime::getbody. +</p> + +<p> +If the -command option is absent, +then the return value of mime::getbody is a string containing the MIME +part's entire body. +</p> + +<h4><a name="mime_copymessage">3.7</a> mime::copymessage</h4> + +<p> +mime::copymessage copies the MIME part to the specified channel. +</p> + +<p> +mime::copymessage operates synchronously, +and uses fileevent to allow asynchronous operations to proceed +independently. +</p> + +<h4><a name="mime_buildmessage">3.7</a> mime::buildmessage</h4> + +<p> +mime::buildmessage returns the MIME part as a string. It is similar +to mime::copymessage, only it returns the data as a return string +instead of writing to a channel. +</p> + + +<h4><a name="smtp_sendmessage">3.8</a> smtp::sendmessage</h4> + +<p> +smtp::sendmessage sends a MIME part to an SMTP server. +(Note that this procedure is in the "smtp" package, +not the "mime" package.) +</p> + +<p> +The options are: + +<blockquote class="text"><dl> + +<dt> -servers:</dt> +<dd> +a list of SMTP servers +(the default is "localhost"); +</dd> + +<dt> -ports:</dt> +<dd> +a list of SMTP ports +(the default is 25); +</dd> + +<dt> -queue:</dt> +<dd> +indicates that the SMTP server should be +asked to queue the message for later processing; +</dd> + +<dt> -atleastone:</dt> +<dd> +indicates that the SMTP server must find +at least one recipient acceptable for the message to be sent; +</dd> + +<dt> -originator:</dt> +<dd> +a string containing an 822-style address +specification +(if present the header isn't examined for an originator address); +</dd> + +<dt> -recipients:</dt> +<dd> +a string containing one or more 822-style +address specifications +(if present the header isn't examined for recipient addresses); and, +</dd> + +<dt> -header:</dt> +<dd> +a keyword/value pairing +(may occur zero or more times). +</dd> + +</dl></blockquote> + +</p> + +<p> +If the -originator option is not present, +the originator address is taken from "From" (or "Resent-From"); +similarly, +if the -recipients option is not present, +recipient addresses are taken from "To", "cc", and "Bcc" (or +"Resent-To", and so on). +Note that the header key/values supplied by the "-header" option +(not those present in the MIME part) +are consulted. +Regardless, +header key/values are added to the outgoing message as necessary to +ensure that a valid 822-style message is sent. +</p> + +<p> +smtp::sendmessage returns a list indicating which recipients were +unacceptable to the SMTP server. +Each element of the list is another list, +containing the address, an SMTP error code, and a textual diagnostic. +Depending on the -atleastone option and the intended recipients,, +a non-empty list may still indicate that the message was accepted by +the server. +</p> + +<h4><a name="mime_parseaddress">3.9</a> mime::parseaddress</h4> + +<p> +mime::parseaddr takes a string containing one or more 822-style +address specifications and returns a list of serialized arrays, +one element for each address specified in the argument. +</p> + +<p> +Each serialized array contains these properties: +</p> +</font><pre> + property value + ======== ===== + address local@domain + comment 822-style comment + domain the domain part (rhs) + error non-empty on a parse error + group this address begins a group + friendly user-friendly rendering + local the local part (lhs) + memberP this address belongs to a group + phrase the phrase part + proper 822-style address specification + route 822-style route specification (obsolete) +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<p> +Note that one or more of these properties may be empty. +</p> + +<h4><a name="mime_parsedatetime">3.10</a> mime::parsedatetime</h4> + +<p> +mime::parsedatetime takes a string containing an 822-style +date-time specification and returns the specified property. +</p> + +<p> +The list of properties and their ranges are: +</p> +</font><pre> + property range + ======== ===== + hour 0 .. 23 + lmonth January, February, ..., December + lweekday Sunday, Monday, ... Saturday + mday 1 .. 31 + min 0 .. 59 + mon 1 .. 12 + month Jan, Feb, ..., Dec + proper 822-style date-time specification + rclock elapsed seconds between then and now + sec 0 .. 59 + wday 0 .. 6 (Sun .. Mon) + weekday Sun, Mon, ..., Sat + yday 1 .. 366 + year 1900 ... + zone -720 .. 720 (minutes east of GMT) +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> + +<h4><a name="mime_mapencoding">3.10</a> mime::mapencoding</h4> + +<p> +mime::mapencoding takes a string containing the name of a +tcl encoding (see [encoding names]) and returns the MIME +charset name for that encoding (or "" if the charset name +is unknown). +</p> + +<h4><a name="mime_reversemapencoding">3.10</a> mime::reversemapencoding</h4> + +<p> +mime::reversemapencoding takes a string containing the name of a +MIME charset tcl encoding (see [encoding names]) and returns the MIME +charset name for that encoding (or "" if no known tcl encoding maps to +the mime charset type). +</p> + +<a name="anchor6"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>4. EXAMPLES</h3> +</font><pre> +package require mime 1.0 +package require smtp 1.0 + + +# create an image + +set imageT [mime::initialize -canonical image/gif \ + -file logo.gif] + + +# parse a message + +set messageT [mime::initialize -file example.msg] + + +# recursively traverse a message looking for primary recipients + +proc traverse {token} { + set result "" + +# depth-first search + if {![catch { mime::getproperty $token parts } parts]} { + foreach part $parts { + set result [concat $result [traverse $part]] + } + } + +# one value for each line occuring in the header + foreach value [mime::getheader $token To] { + foreach addr [mime::parseaddress $value] { + catch { unset aprops } + array set aprops $addr + lappend result $aprops(address) + } + } + + return $result +} + + +# create a multipart containing both, and a timestamp + +set multiT [mime::initialize -canonical multipart/mixed + -parts [list $imageT $messageT]] + + + + +# send it to some friends + +smtp::sendmessage $multiT \ + -header [list From "Marshall Rose <mrose@dbc.mtview.ca.us>"] \ + -header [list To "Andreas Kupries <a.kupries@westend.com>"] \ + -header [list cc "dnew@messagemedia.com (Darren New)"] \ + -header [list Subject "test message..."] + + +# clean everything up + +mime::finalize $multiT -subordinates all +</pre><font face="verdana, helvetica, arial, sans-serif" size="2"> +<a name="rfc.references"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3> +References</h3> +<table width="99%" border="0"> +<tr><td class="author-text" valign="top"><b><a name="RFC2045">[1]</a></b></td> +<td class="author-text"><a href="mailto:ned@innosoft.com">Freed, N.</a> and <a href="mailto:nsb@messagemedia.com">N.S. Borenstein</a>, "<a href="http://info.internet.isi.edu/in-notes/rfc/files/rfc2045.txt">Multipurpose Internet Mail Extensions (MIME) +Part One: Format of Internet Message Bodies</a>", RFC 2045, November 1996.</td></tr> +<tr><td class="author-text" valign="top"><b><a name="RFC2046">[2]</a></b></td> +<td class="author-text"><a href="mailto:ned@innosoft.com">Freed, N.</a> and <a href="mailto:nsb@messagemedia.com">N.S. Borenstein</a>, "<a href="http://info.internet.isi.edu/in-notes/rfc/files/rfc2046.txt">Multipurpose Internet Mail Extensions (MIME) +Part Two: Media Types</a>", RFC 2046, November 1995.</td></tr> +<tr><td class="author-text" valign="top"><b><a name="RFC822">[3]</a></b></td> +<td class="author-text"><a href="mailto:DCrocker@UDel-Relay">Crocker, D.</a>, "<a href="http://info.internet.isi.edu/in-notes/rfc/files/rfc822.txt">Standard for the format of ARPA Internet Text Messages</a>", RFC 822, STD 11, August 1982.</td></tr> +</table> + +<a name="rfc.authors"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>Author's Address</h3> +<table width="99%" border="0" cellpadding="0" cellspacing="0"> +<tr><td class="author-text"> </td> +<td class="author-text">Marshall T. Rose</td></tr> +<tr><td class="author-text"> </td> +<td class="author-text">Dover Beach Consulting, Inc.</td></tr> +<tr><td class="author-text"> </td> +<td class="author-text">POB 255268</td></tr> +<tr><td class="author-text"> </td> +<td class="author-text">Sacramento, CA 95865-5268</td></tr> +<tr><td class="author-text"> </td> +<td class="author-text">US</td></tr> +<tr><td class="author" align="right">Phone: </td> +<td class="author-text">+1 916 483 8878</td></tr> +<tr><td class="author" align="right">Fax: </td> +<td class="author-text">+1 916 483 8848</td></tr> +<tr><td class="author" align="right">EMail: </td> +<td class="author-text"><a href="mailto:mrose@dbc.mtview.ca.us">mrose@dbc.mtview.ca.us</a></td></tr> +</table> + +<a name="anchor7"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>Appendix A. TODO List</h3> + +<p> + +<blockquote class="text"><dl> + +<dt>mime::initialize</dt> +<dd> + +<ul class="text"> + +<li> +well-defined errorCode values +</li> + +<li> +catch nested errors when processing a multipart +</li> + +</ul> + +</dd> + +</dl></blockquote> + +</p> + +<a name="anchor8"><br><hr size="1" shade="0"></a> +<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b> TOC </b></font></a><br></td></tr></table> +<h3>Appendix B. Acknowledgements</h3> + +<p> +This package is influenced by the safe-tcl package +(Borenstein and Rose, circa 1993), +and also by <a href="mailto:dnew@messagemedia.com">Darren New</a>'s +unpublished package of 1999. +</p> + +<p> +This package makes use of +<a href="mailto:a.kupries@westend.com">Andreas Kupries</a>'s +excellent Trf package. +</p> +</font></body></html> diff --git a/tcllib/modules/mime/README.txt b/tcllib/modules/mime/README.txt new file mode 100644 index 0000000..25d2694 --- /dev/null +++ b/tcllib/modules/mime/README.txt @@ -0,0 +1,804 @@ + + +The README file M.T. Rose + Dover Beach Consulting, Inc. + February 22, 2000 + + + Tcl MIME + + +Abstract + + Tcl MIME generates and parses MIME body parts. + +Table of Contents + + 1. SYNOPSIS . . . . . . . . . . . . . . . . . . . . . . . . . . 2 + 1.1 Requirements . . . . . . . . . . . . . . . . . . . . . . . . 3 + 1.2 Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . 3 + 2. SYNTAX . . . . . . . . . . . . . . . . . . . . . . . . . . . 4 + 3. SEMANTICS . . . . . . . . . . . . . . . . . . . . . . . . . 5 + 3.1 mime::initialize . . . . . . . . . . . . . . . . . . . . . . 5 + 3.2 mime::finalize . . . . . . . . . . . . . . . . . . . . . . . 5 + 3.3 mime::getproperty . . . . . . . . . . . . . . . . . . . . . 5 + 3.4 mime::getheader . . . . . . . . . . . . . . . . . . . . . . 6 + 3.5 mime::setheader . . . . . . . . . . . . . . . . . . . . . . 6 + 3.6 mime::getbody . . . . . . . . . . . . . . . . . . . . . . . 6 + 3.7 mime::copymessage . . . . . . . . . . . . . . . . . . . . . 7 + 3.8 mime::buildmessage . . . . . . . . . . . . . . . . . . . . . 7 + 3.9 smtp::sendmessage . . . . . . . . . . . . . . . . . . . . . 7 + 3.10 mime::parseaddress . . . . . . . . . . . . . . . . . . . . . 8 + 3.11 mime::parsedatetime . . . . . . . . . . . . . . . . . . . . 9 + 3.12 mime::mapencoding . . . . . . . . . . . . . . . . . . . . . 9 + 3.13 mime::reversemapencoding . . . . . . . . . . . . . . . . . . 9 + + 4. EXAMPLES . . . . . . . . . . . . . . . . . . . . . . . . . . 10 + References . . . . . . . . . . . . . . . . . . . . . . . . . 12 + Author's Address . . . . . . . . . . . . . . . . . . . . . . 12 + A. TODO List . . . . . . . . . . . . . . . . . . . . . . . . . 13 + B. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 14 + + + + + + + + + + + + + + + + + + +Rose [Page 1] + +README Tcl MIME February 2000 + + +1. SYNOPSIS + + package provide mime 1.2 + package provide smtp 1.2 + + Tcl MIME is an implementation of a Tcl package that generates and + parses MIME[1] body parts. + + Each MIME part consists of a header (zero or more key/value pairs), + an empty line, and a structured body. A MIME part is either a "leaf" + or has (zero or more) subordinates. + + MIME defines four keys that may appear in the headers: + + Content-Type: describes the data contained in the body ("the + content"); + + Content-Transfer-Encoding: describes how the content is encoded + for transmission in an ASCII stream; + + Content-Description: a textual description of the content; and, + + Content-ID: a globally-unique identifier for the content. + + Consult [2] for a list of standard content types. Further, consult + [3] for a list of several other header keys (e.g., "To", "cc", etc.) + + A simple example might be: + + Date: Sun, 04 July 1999 10:38:25 -0600 + From: Marshall Rose <mrose@dbc.mtview.ca.us> + To: Andreas Kupries <a.kupries@westend.com> + cc: dnew@messagemedia.com (Darren New) + MIME-Version: 1.0 + Content-Type: text/plain; charset="us-ascii" + Content-Description: a simple example + Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us> + + Here is the body. In this case, simply plain text. + + In addition to an implementation of the mime package, Tcl MIME + includes an implementation of the smtp package. + + + + + + + + + +Rose [Page 2] + +README Tcl MIME February 2000 + + +1.1 Requirements + + This package requires: + + o Tcl/Tk version 8.0.3[4] or later + + In addition, this package requires one of the following: + + o Trf version 2.0p5[5] or later + + o base64 version 2.0 or later (included with tcllib) + + If it is available, Trf will be used to provide better performance; + if not, Tcl-only equivalent functions, based on the base64 package, + are used. + +1.2 Copyrights + + (c) 1999-2000 Marshall T. Rose + + Hold harmless the author, and any lawful use is allowed. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Rose [Page 3] + +README Tcl MIME February 2000 + + +2. SYNTAX + + mime::initialize (Section 3.1) returns a token. Parameters: + ?-canonical type/subtype + ?-param {key value}?... + ?-encoding value? + ?-header {key value}?... ? + (-file name | -string value | -parts {token1 ... tokenN}) + + mime::finalize (Section 3.2) returns an empty string. Parameters: + token ?-subordinates "all" | "dynamic" | "none"? + + mime::getproperty (Section 3.3) returns a string or a list of + strings. Parameters: + token ?property | -names? + + mime::getheader (Section 3.4) returns a list of strings. Parameters: + token ?key | -names? + + mime::setheader (Section 3.5) returns a list of strings. Parameters: + token key value ?-mode "write" | "append" | "delete"? + + mime::getbody (Section 3.6) returns a string. Parameters: + ?-command callback ?-blocksize octets? ? + + mime::copymessage (Section 3.7) returns an empty string. Parameters: + token channel + + mime::buildmessage (Section 3.7) returns a string. Parameters: + token + + smtp::sendmessage (Section 3.8) returns a list. Parameters: + token ?-servers list? ?-ports list? + ?-queue boolean? ?-atleastone boolean? + ?-originator string? ?-recipients string? + ?-header {key value}?... + + mime::parseaddress (Section 3.9) returns a list of serialized + arrays. Parameters: + string + + mime::parsedatetime (Section 3.10) returns a string. Parameters: + [string | -now] property + + mime::mapencoding (Section 3.10) returns a string. Parameters: + encoding_name + + mime::reversemapencoding (Section 3.10) returns a string. Parameters: + charset_type + + + +Rose [Page 4] + +README Tcl MIME February 2000 + + +3. SEMANTICS + +3.1 mime::initialize + + mime::initialize creates a MIME part: + + o If the -canonical option is present, then the body is in + canonical (raw) form and is found by consulting either the -file, + -string, or -part option. + + In addition, both the -param and -header options may occur zero + or more times to specify "Content-Type" parameters (e.g., + "charset") and header keyword/values (e.g., + "Content-Disposition"), respectively. + + Also, -encoding, if present, specifies the + "Content-Transfer-Encoding" when copying the body. + + o If the -canonical option is not present, then the MIME part + contained in either the -file or the -string option is parsed, + dynamically generating subordinates as appropriate. + +3.2 mime::finalize + + mime::finalize destroys a MIME part. + + If the -subordinates option is present, it specifies which + subordinates should also be destroyed. The default value is + "dynamic". + +3.3 mime::getproperty + + mime::getproperty returns the properties of a MIME part. + + The properties are: + + property value + ======== ===== + content the type/subtype describing the content + encoding the "Content-Transfer-Encoding" + params a list of "Content-Type" parameters + parts a list of tokens for the part's subordinates + size the approximate size of the content (unencoded) + + The "parts" property is present only if the MIME part has + subordinates. + + If mime::getproperty is invoked with the name of a specific + property, then the corresponding value is returned; instead, if + + +Rose [Page 5] + +README Tcl MIME February 2000 + + + -names is specified, a list of all properties is returned; + otherwise, a serialized array of properties and values is returned. + +3.4 mime::getheader + + mime::getheader returns the header of a MIME part. + + A header consists of zero or more key/value pairs. Each value is a + list containing one or more strings. + + If mime::getheader is invoked with the name of a specific key, then + a list containing the corresponding value(s) is returned; instead, + if -names is specified, a list of all keys is returned; otherwise, a + serialized array of keys and values is returned. Note that when a + key is specified (e.g., "Subject"), the list returned usually + contains exactly one string; however, some keys (e.g., "Received") + often occur more than once in the header, accordingly the list + returned usually contains more than one string. + +3.5 mime::setheader + + mime::setheader writes, appends to, or deletes the value associated + with a key in the header. + + The value for -mode is one of: + + write: the key/value is either created or overwritten (the + default); + + append: a new value is appended for the key (creating it as + necessary); or, + + delete: all values associated with the key are removed (the + "value" parameter is ignored). + + Regardless, mime::setheader returns the previous value associated + with the key. + +3.6 mime::getbody + + mime::getbody returns the body of a leaf MIME part in canonical form. + + If the -command option is present, then it is repeatedly invoked + with a fragment of the body as this: + + uplevel #0 $callback [list "data" $fragment] + + (The -blocksize option, if present, specifies the maximum size of + each fragment passed to the callback.) + + +Rose [Page 6] + +README Tcl MIME February 2000 + + + When the end of the body is reached, the callback is invoked as: + + uplevel #0 $callback "end" + + Alternatively, if an error occurs, the callback is invoked as: + + uplevel #0 $callback [list "error" reason] + + Regardless, the return value of the final invocation of the callback + is propagated upwards by mime::getbody. + + If the -command option is absent, then the return value of + mime::getbody is a string containing the MIME part's entire body. + +3.7 mime::copymessage + + mime::copymessage copies the MIME part to the specified channel. + + mime::copymessage operates synchronously, and uses fileevent to + allow asynchronous operations to proceed independently. + +3.7 mime::buildmessage + + mime::buildmessage returns the MIME part as a string. It is similar + to mime::copymessage, only it returns the data as a return string + instead of writing to a channel. + +3.8 smtp::sendmessage + + smtp::sendmessage sends a MIME part to an SMTP server. (Note that + this procedure is in the "smtp" package, not the "mime" package.) + + The options are: + + -servers: a list of SMTP servers (the default is "localhost"); + + -ports: a list of SMTP ports (the default is 25) + + -queue: indicates that the SMTP server should be asked to queue + the message for later processing; + + -atleastone: indicates that the SMTP server must find at least + one recipient acceptable for the message to be sent; + + -originator: a string containing an 822-style address + specification (if present the header isn't examined for an + originator address); + + -recipients: a string containing one or more 822-style address + specifications (if present the header isn't examined for + recipient addresses); and, + + -header: a keyword/value pairing (may occur zero or more times). + + If the -originator option is not present, the originator address is + taken from "From" (or "Resent-From"); similarly, if the -recipients + option is not present, recipient addresses are taken from "To", + + +Rose [Page 7] + +README Tcl MIME February 2000 + + + "cc", and "Bcc" (or "Resent-To", and so on). Note that the header + key/values supplied by the "-header" option (not those present in + the MIME part) are consulted. Regardless, header key/values are + added to the outgoing message as necessary to ensure that a valid + 822-style message is sent. + + smtp::sendmessage returns a list indicating which recipients were + unacceptable to the SMTP server. Each element of the list is another + list, containing the address, an SMTP error code, and a textual + diagnostic. Depending on the -atleastone option and the intended + recipients,, a non-empty list may still indicate that the message + was accepted by the server. + +3.9 mime::parseaddress + + mime::parseaddr takes a string containing one or more 822-style + address specifications and returns a list of serialized arrays, one + element for each address specified in the argument. + + Each serialized array contains these properties: + + property value + ======== ===== + address local@domain + comment 822-style comment + domain the domain part (rhs) + error non-empty on a parse error + group this address begins a group + friendly user-friendly rendering + local the local part (lhs) + memberP this address belongs to a group + phrase the phrase part + proper 822-style address specification + route 822-style route specification (obsolete) + + Note that one or more of these properties may be empty. + + + + + + + + + + + + + + +Rose [Page 8] + +README Tcl MIME February 2000 + + +3.10 mime::parsedatetime + + mime::parsedatetime takes a string containing an 822-style date-time + specification and returns the specified property. + + The list of properties and their ranges are: + + property range + ======== ===== + hour 0 .. 23 + lmonth January, February, ..., December + lweekday Sunday, Monday, ... Saturday + mday 1 .. 31 + min 0 .. 59 + mon 1 .. 12 + month Jan, Feb, ..., Dec + proper 822-style date-time specification + rclock elapsed seconds between then and now + sec 0 .. 59 + wday 0 .. 6 (Sun .. Mon) + weekday Sun, Mon, ..., Sat + yday 1 .. 366 + year 1900 ... + zone -720 .. 720 (minutes east of GMT) + +3.10 mime::mapencoding + + mime::mapencodings maps tcl encodings onto the proper names for their + MIME charset type. This is only done for encodings whose charset types + were known. The remaining encodings return "" for now. + +3.10 mime::reversemapencoding + + mime::reversemapencoding maps MIME charset types onto tcl encoding names. + Those that are unknown return "". + + + + + + + + + + + + + + + + +Rose [Page 9] + +README Tcl MIME February 2000 + + +4. EXAMPLES + + package require mime 1.0 + package require smtp 1.0 + + + # create an image + + set imageT [mime::initialize -canonical image/gif \ + -file logo.gif] + + + # parse a message + + set messageT [mime::initialize -file example.msg] + + + # recursively traverse a message looking for primary recipients + + proc traverse {token} { + set result "" + + # depth-first search + if {![catch { mime::getproperty $token parts } parts]} { + foreach part $parts { + set result [concat $result [traverse $part]] + } + } + + # one value for each line occuring in the header + foreach value [mime::getheader $token To] { + foreach addr [mime::parseaddress $value] { + catch { unset aprops } + array set aprops $addr + lappend result $aprops(address) + } + } + + return $result + } + + + # create a multipart containing both, and a timestamp + + set multiT [mime::initialize -canonical multipart/mixed + -parts [list $imageT $messageT]] + + + + + +Rose [Page 10] + +README Tcl MIME February 2000 + + + # send it to some friends + + smtp::sendmessage $multiT \ + -header [list From "Marshall Rose <mrose@dbc.mtview.ca.us>"] \ + -header [list To "Andreas Kupries <a.kupries@westend.com>"] \ + -header [list cc "dnew@messagemedia.com (Darren New)"] \ + -header [list Subject "test message..."] + + + # clean everything up + + mime::finalize $multiT -subordinates all + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Rose [Page 11] + +README Tcl MIME February 2000 + + +References + + [1] Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail + Extensions (MIME) Part One: Format of Internet Message Bodies", + RFC 2045, November 1996. + + [2] Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail + Extensions (MIME) Part Two: Media Types", RFC 2046, November + 1995. + + [3] Crocker, D., "Standard for the format of ARPA Internet Text + Messages", RFC 822, STD 11, August 1982. + + [4] http://www.scriptics.com/software/8.1.html + + [5] http://www.oche.de/~akupries/soft/trf/ + + [6] mailto:dnew@messagemedia.com + + [7] mailto:a.kupries@westend.com + + +Author's Address + + Marshall T. Rose + Dover Beach Consulting, Inc. + POB 255268 + Sacramento, CA 95865-5268 + US + + Phone: +1 916 483 8878 + Fax: +1 916 483 8848 + EMail: mrose@dbc.mtview.ca.us + + + + + + + + + + + + + + + + + + +Rose [Page 12] + +README Tcl MIME February 2000 + + +Appendix A. TODO List + + mime::initialize + + * well-defined errorCode values + + * catch nested errors when processing a multipart + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Rose [Page 13] + +README Tcl MIME February 2000 + + +Appendix B. Acknowledgements + + This package is influenced by the safe-tcl package (Borenstein and + Rose, circa 1993), and also by Darren New[6]'s unpublished package + of 1999. + + This package makes use of Andreas Kupries[7]'s excellent Trf package. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Rose [Page 14] + diff --git a/tcllib/modules/mime/README.xml b/tcllib/modules/mime/README.xml new file mode 100644 index 0000000..ed30a89 --- /dev/null +++ b/tcllib/modules/mime/README.xml @@ -0,0 +1,660 @@ +<?xml version="1.0"?> +<!DOCTYPE rfc SYSTEM "rfc2629.dtd"> + +<?rfc compact="no"?> +<?rfc toc="yes"?> +<?rfc private="The README file"?> +<?rfc header="README"?> + +<rfc> +<front> +<title>Tcl MIME</title> + +<author initials="M.T." surname="Rose" fullname="Marshall T. Rose"> +<organization>Dover Beach Consulting, Inc.</organization> +<address> +<postal> +<street>POB 255268</street> +<city>Sacramento</city> <region>CA</region> <code>95865-5268</code> +<country>US</country> +</postal> +<phone>+1 916 483 8878</phone> +<facsimile>+1 916 483 8848</facsimile> +<email>mrose@dbc.mtview.ca.us</email> +</address> +</author> + +<date month="February" year="2000" /> + +<abstract><t>Tcl MIME generates and parses MIME body parts.</t></abstract> +</front> + +<middle> + +<section title="SYNOPSIS"> +<figure><artwork><![CDATA[ + package provide mime 1.2 + package provide smtp 1.2 +]]></artwork></figure> + +<t>Tcl MIME is an implementation of a Tcl package that generates and +parses <xref target="RFC2045">MIME</xref> body parts.</t> + +<t>Each MIME part consists of a header +(zero or more key/value pairs), +an empty line, +and a structured body. +A MIME part is either a "leaf" or has (zero or more) subordinates.</t> + +<t>MIME defines four keys that may appear in the headers: +<list style="hanging"> +<t hangText=" Content-Type:">describes the data contained in the body +("the content");</t> + +<t hangText=" Content-Transfer-Encoding:">describes how the content is +encoded for transmission in an ASCII stream;</t> + +<t hangText=" Content-Description:">a textual description of the +content; and,</t> + +<t hangText=" Content-ID:">a globally-unique identifier for the +content.</t> +</list></t> + +<t>Consult <xref target="RFC2046" /> for a list of standard content types. +Further, +consult <xref target="RFC822" /> for a list of several other header keys +(e.g., "To", "cc", etc.)</t> + +<figure> +<preamble>A simple example might be:</preamble> +<artwork><![CDATA[ + Date: Sun, 04 July 1999 10:38:25 -0600 + From: Marshall Rose <mrose@dbc.mtview.ca.us> + To: Andreas Kupries <a.kupries@westend.com> + cc: dnew@messagemedia.com (Darren New) + MIME-Version: 1.0 + Content-Type: text/plain; charset="us-ascii" + Content-Description: a simple example + Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us> + + Here is the body. In this case, simply plain text. +]]></artwork> +</figure> + +<t>In addition to an implementation of the mime package, +Tcl MIME includes an implementation of the smtp package.</t> + +<vspace blankLines="1000" /> + +<section title="Requirements"> +<t>This package requires: +<list style="symbols"> +<t><eref target="http://www.scriptics.com/software/8.1.html">Tcl/Tk version 8.0.3</eref> +</list> +or later</t> +<t>In addition, this package requires one of the following:</t> +<list style="symbols"> +<t><eref target="http://www.oche.de/~akupries/soft/trf/">Trf version 2.0p5</eref> +or later</t> +<t><eref target="http://dev.ajubasolutions.com/software/tcllib/">base 64 version 2.0</eref> or later (included with tcllib)</t> +</list></t> +<t>If it is available, Trf will be used to provide better performance; +if not, Tcl-only equivalent functions, based on the base64 package, +are used.</t> +</section> + +<section title="Copyrights"> +<t>(c) 1999-2000 Marshall T. Rose</t> + +<t>Hold harmless the author, and any lawful use is allowed.</t> +</section> +</section> + +<section title="SYNTAX"> +<figure> +<preamble><xref target="mime_initialize">mime::initialize</xref> +returns a token. +Parameters:</preamble> +<artwork><![CDATA[ ?-canonical type/subtype + ?-param {key value}?... + ?-encoding value? + ?-header {key value}?... ? + (-file name | -string value | -parts {token1 ... tokenN}) +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_finalize">mime::finalize</xref> returns +an empty string. +Parameters:</preamble> +<artwork><![CDATA[ token ?-subordinates "all" | "dynamic" | "none"? +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_getproperty">mime::getproperty</xref> +returns a string or a list of strings. +Parameters:</preamble> +<artwork><![CDATA[ token ?property | -names? +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_getheader">mime::getheader</xref> returns +a list of strings. +Parameters:</preamble> +<artwork><![CDATA[ token ?key | -names? +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_setheader">mime::setheader</xref> returns +a list of strings. +Parameters:</preamble> +<artwork><![CDATA[ token key value ?-mode "write" | "append" | "delete"? +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_getbody">mime::getbody</xref> returns a string. +Parameters:</preamble> +<artwork><![CDATA[ ?-command callback ?-blocksize octets? ? +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_copymessage">mime::copymessage</xref> +returns an empty string. +Parameters:</preamble> +<artwork><![CDATA[ token channel +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_buildmessage">mime::buildmessage</xref> +returns an empty string. +Parameters:</preamble> +<artwork><![CDATA[ token +]]></artwork> +</figure> + +<figure> +<preamble><xref target="smtp_sendmessage">smtp::sendmessage</xref> +returns a list. +Parameters:</preamble> +<artwork><![CDATA[ token ?-servers list? ?-ports list? + ?-queue boolean? ?-atleastone boolean? + ?-originator string? ?-recipients string? + ?-header {key value}?... +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_parseaddress">mime::parseaddress</xref> +returns a list of serialized arrays. +Parameters:</preamble> +<artwork><![CDATA[ string +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_parsedatetime">mime::parsedatetime</xref> +returns a string. +Parameters:</preamble> +<artwork><![CDATA[ [string | -now] property +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_mapencoding">mime::mapencoding</xref> +returns a string. +Parameters:</preamble> +<artwork><![CDATA[ encoding_name +]]></artwork> +</figure> + +<figure> +<preamble><xref target="mime_reversemapencoding">mime::reversemapencoding</xref> +returns a string. +Parameters:</preamble> +<artwork><![CDATA[ content_type +]]></artwork> +</figure> + +</section> + +<section title="SEMANTICS"> + +<section anchor="mime_initialize" title="mime::initialize"> +<t>mime::initialize creates a MIME part: +<list style="symbols"> +<t>If the -canonical option is present, +then the body is in canonical (raw) form and is found by consulting +either the -file, -string, or -part option. +<vspace blankLines="1" /> +In addition, +both the -param and -header options may occur zero or more times to +specify "Content-Type" parameters (e.g., "charset") +and header keyword/values (e.g., "Content-Disposition"), +respectively. +<vspace blankLines="1" /> +Also, -encoding, if present, +specifies the "Content-Transfer-Encoding" when copying the body.</t> + +<t>If the -canonical option is not present, +then the MIME part contained in either the -file or the -string option +is parsed, +dynamically generating subordinates as appropriate.</t> +</list></t> +</section> + +<section anchor="mime_finalize" title="mime::finalize"> +<t>mime::finalize destroys a MIME part.</t> + +<t>If the -subordinates option is present, +it specifies which subordinates should also be destroyed. +The default value is "dynamic".</t> +</section> + +<section anchor="mime_getproperty" title="mime::getproperty"> +<t>mime::getproperty returns the properties of a MIME part.</t> + +<figure> +<preamble>The properties are:</preamble> +<artwork><![CDATA[ + property value + ======== ===== + content the type/subtype describing the content + encoding the "Content-Transfer-Encoding" + params a list of "Content-Type" parameters + parts a list of tokens for the part's subordinates + size the approximate size of the content (unencoded) +]]></artwork> +<postamble>The "parts" property is present only if the MIME part has +subordinates.</postamble> +</figure> + +<t>If mime::getproperty is invoked with the name of a specific property, +then the corresponding value is returned; +instead, +if -names is specified, +a list of all properties is returned; +otherwise, +a serialized array of properties and values is returned.</t> +</section> + +<section anchor="mime_getheader" title="mime::getheader"> +<t>mime::getheader returns the header of a MIME part.</t> + +<t>A header consists of zero or more key/value pairs. +Each value is a list containing one or more strings.</t> + +<t>If mime::getheader is invoked with the name of a specific key, +then a list containing the corresponding value(s) is returned; +instead, +if -names is specified, +a list of all keys is returned; +otherwise, +a serialized array of keys and values is returned. +Note that when a key is specified (e.g., "Subject"), +the list returned usually contains exactly one string; +however, +some keys (e.g., "Received") often occur more than once in the header, +accordingly the list returned usually contains more than one string.</t> +</section> + +<section anchor="mime_setheader" title="mime::setheader"> +<t>mime::setheader writes, appends to, or deletes the value associated +with a key in the header.</t> + +<t>The value for -mode is one of: +<list style="hanging"> +<t hangText=" write:"> the key/value is either created or +overwritten (the default);</t> + +<t hangText=" append:"> a new value is appended for the key +(creating it as necessary); or,</t> + +<t hangText=" delete:"> all values associated with the key are removed +(the "value" parameter is ignored).</t> +</list></t> + +<t>Regardless, +mime::setheader returns the previous value associated with the key.</t> +</section> + +<section anchor="mime_getbody" title="mime::getbody"> +<t>mime::getbody returns the body of a leaf MIME part in canonical form.</t> + +<figure> +<preamble>If the -command option is present, +then it is repeatedly invoked with a fragment of the body as this:</preamble> +<artwork><![CDATA[ + uplevel #0 $callback [list "data" $fragment] +]]></artwork> +<postamble>(The -blocksize option, +if present, +specifies the maximum size of each fragment passed to the +callback.)</postamble> +</figure> + +<figure> +<preamble>When the end of the body is reached, +the callback is invoked as:</preamble> +<artwork><![CDATA[ + uplevel #0 $callback "end" +]]></artwork> +</figure> + +<figure> +<preamble>Alternatively, +if an error occurs, +the callback is invoked as:</preamble> +<artwork><![CDATA[ + uplevel #0 $callback [list "error" reason] +]]></artwork> +</figure> + +<t>Regardless, +the return value of the final invocation of the callback is propagated +upwards by mime::getbody.</t> + +<t>If the -command option is absent, +then the return value of mime::getbody is a string containing the MIME +part's entire body.</t> +</section> + +<section anchor="mime_copymessage" title="mime::copymessage"> +<t>mime::copymessage copies the MIME part to the specified channel.</t> + +<t>mime::copymessage operates synchronously, +and uses fileevent to allow asynchronous operations to proceed +independently.</t> +</section> + +<section anchor="mime_buildmessage" title="mime::buildmessage"> +<t>mime::buildmessage returns the MIME part as a string. It is similar +to mime::copymessage, only it returns the data as a return string +instead of writing to a channel.</t> +</section> + +<section anchor="smtp_sendmessage" title="smtp::sendmessage"> +<t>smtp::sendmessage sends a MIME part to an SMTP server. +(Note that this procedure is in the "smtp" package, +not the "mime" package.)</t> + +<t>The options are: +<list style="hanging"> +<t hangText=" -servers:">a list of SMTP servers +(the default is "localhost");</t> + +<t hangText=" -ports:">a list of SMTP ports +(the default is 25);</t> + +<t hangText=" -queue:">indicates that the SMTP server should be +asked to queue the message for later processing;</t> + +<t hangText=" -atleastone:">indicates that the SMTP server must find +at least one recipient acceptable for the message to be sent;</t> + +<t hangText=" -originator:">a string containing an 822-style address +specification +(if present the header isn't examined for an originator address);</t> + +<t hangText=" -recipients:">a string containing one or more 822-style +address specifications +(if present the header isn't examined for recipient addresses); and,</t> + +<t hangText=" -header:">a keyword/value pairing +(may occur zero or more times).</t> +</list></t> + +<t>If the -originator option is not present, +the originator address is taken from "From" (or "Resent-From"); +similarly, +if the -recipients option is not present, +recipient addresses are taken from "To", "cc", and "Bcc" (or +"Resent-To", and so on). +Note that the header key/values supplied by the "-header" option +(not those present in the MIME part) +are consulted. +Regardless, +header key/values are added to the outgoing message as necessary to +ensure that a valid 822-style message is sent.</t> + +<t>smtp::sendmessage returns a list indicating which recipients were +unacceptable to the SMTP server. +Each element of the list is another list, +containing the address, an SMTP error code, and a textual diagnostic. +Depending on the -atleastone option and the intended recipients,, +a non-empty list may still indicate that the message was accepted by +the server.</t> +</section> + +<section anchor="mime_parseaddress" title="mime::parseaddress"> +<t>mime::parseaddr takes a string containing one or more 822-style +address specifications and returns a list of serialized arrays, +one element for each address specified in the argument.</t> + +<figure> +<preamble>Each serialized array contains these properties:</preamble> +<artwork><![CDATA[ + property value + ======== ===== + address local@domain + comment 822-style comment + domain the domain part (rhs) + error non-empty on a parse error + group this address begins a group + friendly user-friendly rendering + local the local part (lhs) + memberP this address belongs to a group + phrase the phrase part + proper 822-style address specification + route 822-style route specification (obsolete) +]]></artwork> +<postamble>Note that one or more of these properties may be empty.</postamble> +</figure> +</section> + +<vspace blankLines="10000" /> + +<section anchor="mime_parsedatetime" title="mime::parsedatetime"> +<t>mime::parsedatetime takes a string containing an 822-style +date-time specification and returns the specified property.</t> + +<figure> +<preamble>The list of properties and their ranges are:</preamble> +<artwork><![CDATA[ + property range + ======== ===== + hour 0 .. 23 + lmonth January, February, ..., December + lweekday Sunday, Monday, ... Saturday + mday 1 .. 31 + min 0 .. 59 + mon 1 .. 12 + month Jan, Feb, ..., Dec + proper 822-style date-time specification + rclock elapsed seconds between then and now + sec 0 .. 59 + wday 0 .. 6 (Sun .. Mon) + weekday Sun, Mon, ..., Sat + yday 1 .. 366 + year 1900 ... + zone -720 .. 720 (minutes east of GMT) +]]></artwork> +</figure> +</section> + +<section anchor="mime_mapencoding" title="mime::mapencoding"> +<t>mime::mapencoding maps tcl encodings onto the proper names for their +MIME charset type. This is only done for encodings whose charset types +were known. The remaining encodings return "" for now.</t> +</section> + +<section anchor="mime_reversemapencoding" title="mime::reversemapencoding"> +<t>mime::reversemapencoding maps MIME charset types onto tcl encoding names. +Those that are unknown return "".</t> +</section> + +</section> + +<section title="EXAMPLES"> +<figure> +<artwork><![CDATA[ +package require mime 1.0 +package require smtp 1.0 + + +# create an image + +set imageT [mime::initialize -canonical image/gif \ + -file logo.gif] + + +# parse a message + +set messageT [mime::initialize -file example.msg] + + +# recursively traverse a message looking for primary recipients + +proc traverse {token} { + set result "" + +# depth-first search + if {![catch { mime::getproperty $token parts } parts]} { + foreach part $parts { + set result [concat $result [traverse $part]] + } + } + +# one value for each line occuring in the header + foreach value [mime::getheader $token To] { + foreach addr [mime::parseaddress $value] { + catch { unset aprops } + array set aprops $addr + lappend result $aprops(address) + } + } + + return $result +} + + +# create a multipart containing both, and a timestamp + +set multiT [mime::initialize -canonical multipart/mixed + -parts [list $imageT $messageT]] + + + + +# send it to some friends + +smtp::sendmessage $multiT \ + -header [list From "Marshall Rose <mrose@dbc.mtview.ca.us>"] \ + -header [list To "Andreas Kupries <a.kupries@westend.com>"] \ + -header [list cc "dnew@messagemedia.com (Darren New)"] \ + -header [list Subject "test message..."] + + +# clean everything up + +mime::finalize $multiT -subordinates all +]]></artwork> +</figure> +</section> + +</middle> + +<back> +<references> +<reference anchor="RFC2045"> +<front> +<title>Multipurpose Internet Mail Extensions (MIME) +Part One: Format of Internet Message Bodies</title> +<author initials="N." surname="Freed" fullname="Ned Freed"> +<organization>Innosoft International, Inc.</organization> +<address> +<email>ned@innosoft.com</email> +</address> +</author> +<author initials="N.S." surname="Borenstein" + fullname="Nathaniel S. Borenstein"> +<organization>First Virtual Holdings, Incorporated</organization> +<address> +<email>nsb@messagemedia.com</email> +</address> +</author> +<date month="November" year="1996"/> +</front> +<seriesInfo name="RFC" value="2045" /> +</reference> + +<reference anchor="RFC2046"> +<front> +<title>Multipurpose Internet Mail Extensions (MIME) +Part Two: Media Types</title> +<author initials="N." surname="Freed" fullname="Ned Freed"> +<organization>Innosoft International, Inc.</organization> +<address> +<email>ned@innosoft.com</email> +</address> +</author> +<author initials="N.S." surname="Borenstein" + fullname="Nathaniel S. Borenstein"> +<organization>First Virtual Holdings, Incorporated</organization> +<address> +<email>nsb@messagemedia.com</email> +</address> +</author> +<date month="November" year="1995"/> +</front> +<seriesInfo name="RFC" value="2046" /> +</reference> + +<reference anchor="RFC822"> +<front> +<title>Standard for the format of ARPA Internet Text Messages</title> +<author initials="D." surname="Crocker" fullname="Dave Crocker"> +<organization abbrev="UDEL">University of Delaware</organization> +<address> +<email>DCrocker@UDel-Relay</email> +</address> +</author> +<date month="August" year="1982"/> +</front> +<seriesInfo name="RFC" value="822" /> +<seriesInfo name="STD" value="11" /> +</reference> + +</references> + +<section title="TODO List"> +<t><list style="hanging"> +<t hangText="mime::initialize"> +<list style="symbols"> +<t>well-defined errorCode values</t> + +<t>catch nested errors when processing a multipart</t> +</list></t> + +</list></t> +</section> + +<section title="Acknowledgements"> +<t>This package is influenced by the safe-tcl package +(Borenstein and Rose, circa 1993), +and also by <eref target="mailto:dnew@messagemedia.com">Darren New</eref>'s +unpublished package of 1999.</t> + +<t>This package makes use of +<eref target="mailto:a.kupries@westend.com">Andreas Kupries</eref>'s +excellent Trf package.</t> +</section> + +</back> +</rfc> diff --git a/tcllib/modules/mime/badmail1.txt b/tcllib/modules/mime/badmail1.txt new file mode 100644 index 0000000..6713acb --- /dev/null +++ b/tcllib/modules/mime/badmail1.txt @@ -0,0 +1,10 @@ +Date: Tue, 10 Jun 2003 10:32:05 +0200 +Message-Id: <200306100832.h5A8W5S16670@hmif.hellmann.pol.pl> +From: Magnus Fisch <magnus.fisch@giant-polska.com.pl> +Subject: Meeting tomorrow +MIME-Version: 1.0 +Content-Type: multipart/mixed; boundary="----------CSFNU9QKPGZL79" +Bcc: + +------------CSFNU9QKPGZL79-- + diff --git a/tcllib/modules/mime/badmail2.txt b/tcllib/modules/mime/badmail2.txt new file mode 100644 index 0000000..7bd863e --- /dev/null +++ b/tcllib/modules/mime/badmail2.txt @@ -0,0 +1,31 @@ +From: "Kelsey " <irnmh5828ooem@yahoo.com> +To: "gdylgzCsurvd1lw" <davidw@dedasys.com> +Date: Fri, 28 Feb 2003 03:12:35 -0500 +Subject: no subject gdylgzCsurvd1lw +MIME-Version: 1.0 +Content-Type: multipart/related; + boundary="----=_NextPart_000_0000_2CBA2CBA.150C56D2" +X-Spam-Rating: daedalus.apache.org 1.6.2 0/1000/N +X-Spam-Rating: icarus.apache.org 1.6.2 0/1000/N +Lines: 19 +Xref: localhost private-mail:14167 + +------=_NextPart_000_0000_2CBA2CBA.150C56D2 +Content-Type: text/html; +Content-Transfer-Encoding: base64 + +PCEtLTE1MTQ3LS0+PGJvZHk+DQpJdCdzIG1lIEplPCEtLTI5MDY0LS0+bm5pZmVyLDxicj4g +SSBqdXN0IHdhbjwhLS0xOTE0OS0tPnRlZCB0byBzZW5kIHlvdSB0aGF0IHBpYyB5b3UgYXNr +ZTwhLS0xNTAxMC0tPmQgZm9yIHRoZSBvdDwhLS0yNjUxMi0tPmhlcg0KZGF5LiA8YnI+IDxh +IGhyZWY9Imh0dHA6Ly93d3cuaG90aG9zdC5iei9hYmMvamVubmlmZXIvP1JJRD1jaW5nd2Yi +PkNsaTwhLS0yNzE1My0tPmNrDQpIPCEtLTI2NjcwLS0+ZXJlIHRvIGNhdDwhLS03NDg5LS0+ +Y2ggbWUgb24gbXkgd2ViPCEtLTI0ODExLS0+Y2FtICYgc2VlIG1vcmUgcGljcyBvZiBtZS48 +L2E+IDxicj48YnI+DQo8YSBocmVmPSJodHRwOi8vd3d3LmhvdGhvc3QuYnovYWJjL2plbm5p +ZmVyLz9SSUQ9Y2luZ3dmIj48aW1nIHNyYz0iaHR0cDovLzIwNy40NC4xODMuMjU0L2FiYy9q +ZW5uaWZlci93b29ob28uanBnIiBib3JkZXI9IjAiPjwvYT4NCjxicj48YnI+PGk+LSB4bzwh +LS0yMzQwMi0tPnhvIEplbm5pZmVyPC9pPjwvcD48YnI+PGJyPjxicj48YnI+PGJyPjxicj48 +YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJy +Pjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+DQo8L2JvZHk+ + + + diff --git a/tcllib/modules/mime/mime.bench b/tcllib/modules/mime/mime.bench new file mode 100644 index 0000000..99c204e --- /dev/null +++ b/tcllib/modules/mime/mime.bench @@ -0,0 +1,59 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'mime' module. +# This allow developers to monitor/gauge/track package performance. +# +# (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# We need at least version 8.2 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.2]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package forget mime +catch {namespace delete ::mime} +source [file join [file dirname [info script]] mime.tcl] + +proc construct_item_with_attachment size { + set message_token [mime::initialize -canonical text/plain \ + -string "This is a first part."] + set attachment_body [string repeat abcd\n [expr {$size / 5}]] + set attachment_token [mime::initialize \ + -canonical application/octet-stream \ + -string $attachment_body] + set multi_token [mime::initialize -canonical multipart/mixed \ + -parts [list $message_token $attachment_token]] + + set packaged [mime::buildmessage $multi_token] + mime::finalize $multi_token + return $packaged +} + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +foreach sz { + 1000 + 10000 + 50000 + 100000 + 200000 + 400000 + 800000 + 1000000 + 1500000 + 2500000 + 5000000 +} { + bench -desc "MIME initialize/finalize $sz" -pre { + set item [construct_item_with_attachment $sz] + } -body { + mime::finalize [mime::initialize -string $item] + } -iter 1 +} diff --git a/tcllib/modules/mime/mime.man b/tcllib/modules/mime/mime.man new file mode 100644 index 0000000..fc3755b --- /dev/null +++ b/tcllib/modules/mime/mime.man @@ -0,0 +1,405 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin mime n 1.6] +[see_also ftp] +[see_also http] +[see_also pop3] +[see_also smtp] +[keywords email] +[keywords internet] +[keywords mail] +[keywords mime] +[keywords net] +[keywords {rfc 821}] +[keywords {rfc 822}] +[keywords {rfc 2045}] +[keywords {rfc 2046}] +[keywords {rfc 2049}] +[keywords smtp] +[copyright {1999-2000 Marshall T. Rose}] +[moddesc {Mime}] +[titledesc {Manipulation of MIME body parts}] +[category {Text processing}] +[require Tcl 8.5] +[require mime [opt 1.6]] +[description] +[para] + +The [package mime] library package provides the commands to create and +manipulate MIME body parts. + +[list_begin definitions] + +[call [cmd ::mime::initialize] [opt "[option -canonical] [arg type/subtype] [opt "[option -param] \{[arg {key value}]\}..."] [opt "[option -encoding] [arg value]"] [opt "[option -header] \{[arg {key value}]\}..."]"] "([option -file] [arg name] | [option -string] [arg value] | [option -parts] \{[arg token1] ... [arg tokenN]\})"] + +This command creates a MIME part and returns a token representing it. + +[list_begin itemized] + +[item] + +If the [option -canonical] option is present, then the body is in +canonical (raw) form and is found by consulting either the + +[option -file], [option -string], or [option -parts] option. + +[para] + +In addition, both the [option -param] and [option -header] options may +occur zero or more times to specify [const Content-Type] parameters +(e.g., [const charset]) and header keyword/values (e.g., + +[const Content-Disposition]), respectively. + +[para] + +Also, [option -encoding], if present, specifies the + +[const Content-Transfer-Encoding] when copying the body. + +[item] + +If the [option -canonical] option is not present, then the MIME part +contained in either the [option -file] or the [option -string] option +is parsed, dynamically generating subordinates as appropriate. + +[list_end] + +[call [cmd ::mime::finalize] [arg token] [opt "[option -subordinates] [const all] | [const dynamic] | [const none]"]] + +This command destroys the MIME part represented by [arg token]. It +returns an empty string. + +[para] + +If the [option -subordinates] option is present, it specifies which +subordinates should also be destroyed. The default value is + +[const dynamic], destroying all subordinates which were created by +[cmd ::mime::initialize] together with the containing body part. + +[call [cmd ::mime::getproperty] [arg token] [opt "[arg property] | [option -names]"]] + +This command returns a string or a list of strings containing the +properties of a MIME part. If the command is invoked with the name of +a specific property, then the corresponding value is returned; +instead, if [option -names] is specified, a list of all properties is +returned; otherwise, a serialized array of properties and values is +returned. + +[para] +The possible properties are: + +[list_begin definitions] + +[def [const content]] + +The type/subtype describing the content + +[def [const encoding]] + +The "Content-Transfer-Encoding" + +[def [const params]] + +A list of "Content-Type" parameters + +[def [const parts]] + +A list of tokens for the part's subordinates. This property is +present only if the MIME part has subordinates. + +[def [const size]] + +The approximate size of the content (unencoded) + +[list_end] + +[call [cmd ::mime::getheader] [arg token] [opt "[arg key] | [option -names]"]] + +This command returns the header of a MIME part, as a list of strings. + +[para] + +A header consists of zero or more key/value pairs. Each value is a +list containing one or more strings. + +[para] + +If this command is invoked with the name of a specific [arg key], then +a list containing the corresponding value(s) is returned; instead, if +-names is specified, a list of all keys is returned; otherwise, a +serialized array of keys and values is returned. Note that when a key +is specified (e.g., "Subject"), the list returned usually contains +exactly one string; however, some keys (e.g., "Received") often occur +more than once in the header, accordingly the list returned usually +contains more than one string. + +[call [cmd ::mime::setheader] [arg token] [arg {key value}] [opt "[option -mode] [const write] | [const append] | [const delete]"]] + +This command writes, appends to, or deletes the [arg value] associated +with a [arg key] in the header. It returns a list of strings +containing the previous value associated with the key. + +[para] + +The value for [option -mode] is one of: + +[list_begin definitions] + +[def [const write]] + +The [arg key]/[arg value] is either created or overwritten (the default). + +[def [const append]] + +A new [arg value] is appended for the [arg key] (creating it as necessary). + +[def [const delete]] + +All values associated with the key are removed (the [arg value] +parameter is ignored). + +[list_end] + +[call [cmd ::mime::getbody] [arg token] [opt [option -decode]] [opt "[option -command] [arg callback] [opt "[option -blocksize] [arg octets]"]"]] + +This command returns a string containing the body of the leaf MIME +part represented by [arg token] in canonical form. + +[para] + +If the [option -command] option is present, then it is repeatedly +invoked with a fragment of the body as this: + +[example { + uplevel #0 $callback [list "data" $fragment] +}] + +[para] + +(The [option -blocksize] option, if present, specifies the maximum +size of each fragment passed to the callback.) + +[para] + +When the end of the body is reached, the callback is invoked as: + +[example { + uplevel #0 $callback "end" +}] + +[para] + +Alternatively, if an error occurs, the callback is invoked as: + +[example { + uplevel #0 $callback [list "error" reason] +}] + +[para] + +Regardless, the return value of the final invocation of the callback +is propagated upwards by [cmd ::mime::getbody]. + +[para] + +If the [option -command] option is absent, then the return value of +[cmd ::mime::getbody] is a string containing the MIME part's entire +body. + +[para] + +If the option [option -decode] is absent the return value computed +above is returned as is. This means that it will be in the charset +specified for the token and not the usual utf-8. + +If the option [option -decode] is present however the command will use +the charset information associated with the token to convert the +string from its encoding into utf-8 before returning it. + +[call [cmd ::mime::copymessage] [arg token] [arg channel]] + +This command copies the MIME represented by [arg token] part to the +specified [arg channel]. The command operates synchronously, and uses +fileevent to allow asynchronous operations to proceed +independently. It returns an empty string. + +[call [cmd ::mime::buildmessage] [arg token]] + +This command returns the MIME part represented by [arg token] as a +string. It is similar to [cmd ::mime::copymessage], only it returns +the data as a return string instead of writing to a channel. + +[call [cmd ::mime::parseaddress] [arg string]] + +This command takes a string containing one or more 822-style address +specifications and returns a list of serialized arrays, one element +for each address specified in the argument. If the string contains +more than one address they will be separated by commas. + +[para] + +Each serialized array contains the properties below. Note that one or +more of these properties may be empty. + +[list_begin definitions] + +[def [const address]] + +local@domain + +[def [const comment]] + +822-style comment + +[def [const domain]] + +the domain part (rhs) + +[def [const error]] + +non-empty on a parse error + +[def [const group]] + +this address begins a group + +[def [const friendly]] + +user-friendly rendering + +[def [const local]] + +the local part (lhs) + +[def [const memberP]] + +this address belongs to a group + +[def [const phrase]] + +the phrase part + +[def [const proper]] + +822-style address specification + +[def [const route]] + +822-style route specification (obsolete) + +[list_end] + +[call [cmd ::mime::parsedatetime] ([arg string] | [option -now]) [arg property]] + +This command takes a string containing an 822-style date-time +specification and returns the specified property as a serialized +array. + +[para] + +The list of properties and their ranges are: + +[list_begin definitions] + +[def [const hour]] + +0 .. 23 + +[def [const lmonth]] + +January, February, ..., December + +[def [const lweekday]] + +Sunday, Monday, ... Saturday + +[def [const mday]] + +1 .. 31 + +[def [const min]] + +0 .. 59 + +[def [const mon]] + +1 .. 12 + +[def [const month]] + +Jan, Feb, ..., Dec + +[def [const proper]] + +822-style date-time specification + +[def [const rclock]] + +elapsed seconds between then and now + +[def [const sec]] + +0 .. 59 + +[def [const wday]] + +0 .. 6 (Sun .. Mon) + +[def [const weekday]] + +Sun, Mon, ..., Sat + +[def [const yday]] + +1 .. 366 + +[def [const year]] + +1900 ... + +[def [const zone]] + +-720 .. 720 (minutes east of GMT) + +[list_end] + +[call [cmd ::mime::mapencoding] [arg encoding_name]] + +This commansd maps tcl encodings onto the proper names for their MIME +charset type. This is only done for encodings whose charset types +were known. The remaining encodings return "" for now. + +[call [cmd ::mime::reversemapencoding] [arg charset_type]] + +This command maps MIME charset types onto tcl encoding names. Those +that are unknown return "". + +[list_end] + +[section {KNOWN BUGS}] + +[list_begin definitions] +[def {Tcllib Bug #447037}] + +This problem affects only people which are using Tcl and Mime on a +64-bit system. The currently recommended fix for this problem is to +upgrade to Tcl version 8.4. This version has extended 64 bit support +and the bug does not appear anymore. + +[para] + +The problem could have been generally solved by requiring the use of +Tcl 8.4 for this package. We decided against this solution as it would +force a large number of unaffected users to upgrade their Tcl +interpreter for no reason. + +[para] + +See [uri {/tktview?name=447037} {Ticket 447037}] for additional information. + +[list_end] + +[vset CATEGORY mime] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/mime/mime.tcl b/tcllib/modules/mime/mime.tcl new file mode 100644 index 0000000..35423fd --- /dev/null +++ b/tcllib/modules/mime/mime.tcl @@ -0,0 +1,4010 @@ +# mime.tcl - MIME body parts +# +# (c) 1999-2000 Marshall T. Rose +# (c) 2000 Brent Welch +# (c) 2000 Sandeep Tamhankar +# (c) 2000 Dan Kuchler +# (c) 2000-2001 Eric Melski +# (c) 2001 Jeff Hobbs +# (c) 2001-2008 Andreas Kupries +# (c) 2002-2003 David Welton +# (c) 2003-2008 Pat Thoyts +# (c) 2005 Benjamin Riefenstahl +# (c) 2013 PoorYorick +# +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's +# unpublished package of 1999. +# + +# new string features and inline scan are used, requiring 8.3. +package require Tcl 8.5 + +package provide mime 1.6 + +if {[catch {package require Trf 2.0}]} { + + # Fall-back to tcl-based procedures of base64 and quoted-printable encoders + # Warning! + # These are a fragile emulations of the more general calling sequence + # that appears to work with this code here. + + package require base64 2.0 + set ::major [lindex [split [package require md5] .] 0] + + # Create these commands in the mime namespace so that they + # won't collide with things at the global namespace level + + namespace eval ::mime { + proc base64 {-mode what -- chunk} { + return [base64::$what $chunk] + } + proc quoted-printable {-mode what -- chunk} { + return [mime::qp_$what $chunk] + } + + if {$::major < 2} { + # md5 v1, result is hex string ready for use. + proc md5 {-- string} { + return [md5::md5 $string] + } + } else { + # md5 v2, need option to get hex string + proc md5 {-- string} { + return [md5::md5 -hex $string] + } + } + } + + unset ::major +} + +# +# state variables: +# +# canonicalP: input is in its canonical form +# content: type/subtype +# params: seralized array of key/value pairs (keys are lower-case) +# encoding: transfer encoding +# version: MIME-version +# header: serialized array of key/value pairs (keys are lower-case) +# lowerL: list of header keys, lower-case +# mixedL: list of header keys, mixed-case +# value: either "file", "parts", or "string" +# +# file: input file +# fd: cached file-descriptor, typically for root +# root: token for top-level part, for (distant) subordinates +# offset: number of octets from beginning of file/string +# count: length in octets of (encoded) content +# +# parts: list of bodies (tokens) +# +# string: input string +# +# cid: last child-id assigned +# + + +namespace eval ::mime { + variable mime + array set mime {uid 0 cid 0} + + # RFC 822 lexemes + variable addrtokenL + lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\ + variable addrlexemeL { + LX_SEMICOLON LX_COMMA + LX_LBRACKET LX_RBRACKET + LX_COLON LX_DOT + LX_LPAREN LX_RPAREN + LX_ATSIGN LX_QUOTE + LX_LSQUARE LX_RSQUARE + LX_QUOTE + } + + # RFC 2045 lexemes + variable typetokenL + lappend typetokenL \; , < > : ? ( ) @ \" \[ \] = / \\ + variable typelexemeL { + LX_SEMICOLON LX_COMMA + LX_LBRACKET LX_RBRACKET + LX_COLON LX_QUESTION + LX_LPAREN LX_RPAREN + LX_ATSIGN LX_QUOTE + LX_LSQUARE LX_RSQUARE + LX_EQUALS LX_SOLIDUS + LX_QUOTE + } + + variable encList { + ascii US-ASCII + big5 Big5 + cp1250 Windows-1250 + cp1251 Windows-1251 + cp1252 Windows-1252 + cp1253 Windows-1253 + cp1254 Windows-1254 + cp1255 Windows-1255 + cp1256 Windows-1256 + cp1257 Windows-1257 + cp1258 Windows-1258 + cp437 IBM437 + cp737 {} + cp775 IBM775 + cp850 IBM850 + cp852 IBM852 + cp855 IBM855 + cp857 IBM857 + cp860 IBM860 + cp861 IBM861 + cp862 IBM862 + cp863 IBM863 + cp864 IBM864 + cp865 IBM865 + cp866 IBM866 + cp869 IBM869 + cp874 {} + cp932 {} + cp936 GBK + cp949 {} + cp950 {} + dingbats {} + ebcdic {} + euc-cn EUC-CN + euc-jp EUC-JP + euc-kr EUC-KR + gb12345 GB12345 + gb1988 GB1988 + gb2312 GB2312 + iso2022 ISO-2022 + iso2022-jp ISO-2022-JP + iso2022-kr ISO-2022-KR + iso8859-1 ISO-8859-1 + iso8859-2 ISO-8859-2 + iso8859-3 ISO-8859-3 + iso8859-4 ISO-8859-4 + iso8859-5 ISO-8859-5 + iso8859-6 ISO-8859-6 + iso8859-7 ISO-8859-7 + iso8859-8 ISO-8859-8 + iso8859-9 ISO-8859-9 + iso8859-10 ISO-8859-10 + iso8859-13 ISO-8859-13 + iso8859-14 ISO-8859-14 + iso8859-15 ISO-8859-15 + iso8859-16 ISO-8859-16 + jis0201 JIS_X0201 + jis0208 JIS_C6226-1983 + jis0212 JIS_X0212-1990 + koi8-r KOI8-R + koi8-u KOI8-U + ksc5601 KS_C_5601-1987 + macCentEuro {} + macCroatian {} + macCyrillic {} + macDingbats {} + macGreek {} + macIceland {} + macJapan {} + macRoman {} + macRomania {} + macThai {} + macTurkish {} + macUkraine {} + shiftjis Shift_JIS + symbol {} + tis-620 TIS-620 + unicode {} + utf-8 UTF-8 + } + + variable encodings + array set encodings $encList + variable reversemap + # Initialized at the bottom of the file + + variable encAliasList { + ascii ANSI_X3.4-1968 + ascii iso-ir-6 + ascii ANSI_X3.4-1986 + ascii ISO_646.irv:1991 + ascii ASCII + ascii ISO646-US + ascii us + ascii IBM367 + ascii cp367 + cp437 cp437 + cp437 437 + cp775 cp775 + cp850 cp850 + cp850 850 + cp852 cp852 + cp852 852 + cp855 cp855 + cp855 855 + cp857 cp857 + cp857 857 + cp860 cp860 + cp860 860 + cp861 cp861 + cp861 861 + cp861 cp-is + cp862 cp862 + cp862 862 + cp863 cp863 + cp863 863 + cp864 cp864 + cp865 cp865 + cp865 865 + cp866 cp866 + cp866 866 + cp869 cp869 + cp869 869 + cp869 cp-gr + cp936 CP936 + cp936 MS936 + cp936 Windows-936 + iso8859-1 ISO_8859-1:1987 + iso8859-1 iso-ir-100 + iso8859-1 ISO_8859-1 + iso8859-1 latin1 + iso8859-1 l1 + iso8859-1 IBM819 + iso8859-1 CP819 + iso8859-2 ISO_8859-2:1987 + iso8859-2 iso-ir-101 + iso8859-2 ISO_8859-2 + iso8859-2 latin2 + iso8859-2 l2 + iso8859-3 ISO_8859-3:1988 + iso8859-3 iso-ir-109 + iso8859-3 ISO_8859-3 + iso8859-3 latin3 + iso8859-3 l3 + iso8859-4 ISO_8859-4:1988 + iso8859-4 iso-ir-110 + iso8859-4 ISO_8859-4 + iso8859-4 latin4 + iso8859-4 l4 + iso8859-5 ISO_8859-5:1988 + iso8859-5 iso-ir-144 + iso8859-5 ISO_8859-5 + iso8859-5 cyrillic + iso8859-6 ISO_8859-6:1987 + iso8859-6 iso-ir-127 + iso8859-6 ISO_8859-6 + iso8859-6 ECMA-114 + iso8859-6 ASMO-708 + iso8859-6 arabic + iso8859-7 ISO_8859-7:1987 + iso8859-7 iso-ir-126 + iso8859-7 ISO_8859-7 + iso8859-7 ELOT_928 + iso8859-7 ECMA-118 + iso8859-7 greek + iso8859-7 greek8 + iso8859-8 ISO_8859-8:1988 + iso8859-8 iso-ir-138 + iso8859-8 ISO_8859-8 + iso8859-8 hebrew + iso8859-9 ISO_8859-9:1989 + iso8859-9 iso-ir-148 + iso8859-9 ISO_8859-9 + iso8859-9 latin5 + iso8859-9 l5 + iso8859-10 iso-ir-157 + iso8859-10 l6 + iso8859-10 ISO_8859-10:1992 + iso8859-10 latin6 + iso8859-14 iso-ir-199 + iso8859-14 ISO_8859-14:1998 + iso8859-14 ISO_8859-14 + iso8859-14 latin8 + iso8859-14 iso-celtic + iso8859-14 l8 + iso8859-15 ISO_8859-15 + iso8859-15 Latin-9 + iso8859-16 iso-ir-226 + iso8859-16 ISO_8859-16:2001 + iso8859-16 ISO_8859-16 + iso8859-16 latin10 + iso8859-16 l10 + jis0201 X0201 + jis0208 iso-ir-87 + jis0208 x0208 + jis0208 JIS_X0208-1983 + jis0212 x0212 + jis0212 iso-ir-159 + ksc5601 iso-ir-149 + ksc5601 KS_C_5601-1989 + ksc5601 KSC5601 + ksc5601 korean + shiftjis MS_Kanji + utf-8 UTF8 + } + + namespace export initialize finalize getproperty \ + getheader setheader \ + getbody \ + copymessage \ + mapencoding \ + reversemapencoding \ + parseaddress \ + parsedatetime \ + uniqueID +} + +# ::mime::initialize -- +# +# Creates a MIME part, and returnes the MIME token for that part. +# +# Arguments: +# args Args can be any one of the following: +# ?-canonical type/subtype +# ?-param {key value}?... +# ?-encoding value? +# ?-header {key value}?... ? +# (-file name | -string value | -parts {token1 ... tokenN}) +# +# If the -canonical option is present, then the body is in +# canonical (raw) form and is found by consulting either the -file, +# -string, or -parts option. +# +# In addition, both the -param and -header options may occur zero +# or more times to specify "Content-Type" parameters (e.g., +# "charset") and header keyword/values (e.g., +# "Content-Disposition"), respectively. +# +# Also, -encoding, if present, specifies the +# "Content-Transfer-Encoding" when copying the body. +# +# If the -canonical option is not present, then the MIME part +# contained in either the -file or the -string option is parsed, +# dynamically generating subordinates as appropriate. +# +# Results: +# An initialized mime token. + +proc ::mime::initialize args { + global errorCode errorInfo + + variable mime + + set token [namespace current]::[incr mime(uid)] + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {[catch {{*}[list mime::initializeaux $token {*}$args]} result eopts]} { + catch {mime::finalize $token -subordinates dynamic} + return -options $eopts $result + } + return $token +} + +# ::mime::initializeaux -- +# +# Configures the MIME token created in mime::initialize based on +# the arguments that mime::initialize supports. +# +# Arguments: +# token The MIME token to configure. +# args Args can be any one of the following: +# ?-canonical type/subtype +# ?-param {key value}?... +# ?-encoding value? +# ?-header {key value}?... ? +# (-file name | -string value | -parts {token1 ... tokenN}) +# +# Results: +# Either configures the mime token, or throws an error. + +proc ::mime::initializeaux {token args} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set params [set state(params) {}] + set state(encoding) {} + set state(version) 1.0 + + set state(header) {} + set state(lowerL) {} + set state(mixedL) {} + + set state(cid) 0 + + set argc [llength $args] + for {set argx 0} {$argx < $argc} {incr argx} { + set option [lindex $args $argx] + if {[incr argx] >= $argc} { + error "missing argument to $option" + } + set value [lindex $args $argx] + + switch -- $option { + -canonical { + set state(content) [string tolower $value] + } + + -param { + if {[llength $value] != 2} { + error "-param expects a key and a value, not $value" + } + set lower [string tolower [set mixed [lindex $value 0]]] + if {[info exists params($lower)]} { + error "the $mixed parameter may be specified at most once" + } + + set params($lower) [lindex $value 1] + set state(params) [array get params] + } + + -encoding { + switch -- [set state(encoding) [string tolower $value]] { + 7bit - 8bit - binary - quoted-printable - base64 { + } + + default { + error "unknown value for -encoding $state(encoding)" + } + } + } + + -header { + if {[llength $value] != 2} { + error "-header expects a key and a value, not $value" + } + set lower [string tolower [set mixed [lindex $value 0]]] + if {$lower eq "content-type"} { + error "use -canonical instead of -header $value" + } + if {$lower eq "content-transfer-encoding"} { + error "use -encoding instead of -header $value" + } + if {$lower in {content-md5 mime-version}} { + error "don't go there..." + } + if {$lower ni $state(lowerL)} { + lappend state(lowerL) $lower + lappend state(mixedL) $mixed + } + + array set header $state(header) + lappend header($lower) [lindex $value 1] + set state(header) [array get header] + } + + -file { + set state(file) $value + } + + -parts { + set state(parts) $value + } + + -string { + set state(string) $value + + set state(lines) [split $value \n] + set state(lines.count) [llength $state(lines)] + set state(lines.current) 0 + } + + -root { + # the following are internal options + + set state(root) $value + } + + -offset { + set state(offset) $value + } + + -count { + set state(count) $value + } + + -lineslist { + set state(lines) $value + set state(lines.count) [llength $state(lines)] + set state(lines.current) 0 + #state(string) is needed, but will be built when required + set state(string) {} + } + + default { + error "unknown option $option" + } + } + } + + #We only want one of -file, -parts or -string: + set valueN 0 + foreach value {file parts string} { + if {[info exists state($value)]} { + set state(value) $value + incr valueN + } + } + if {$valueN != 1 && ![info exists state(lines)]} { + error "specify exactly one of -file, -parts, or -string" + } + + if {[set state(canonicalP) [info exists state(content)]]} { + switch -- $state(value) { + file { + set state(offset) 0 + } + + parts { + switch -glob -- $state(content) { + text/* + - + image/* + - + audio/* + - + video/* { + error "-canonical $state(content) and -parts do not mix" + } + + default { + if {$state(encoding) ne {}} { + error "-encoding and -parts do not mix" + } + } + } + } + default {# Go ahead} + } + + if {[lsearch -exact $state(lowerL) content-id] < 0} { + lappend state(lowerL) content-id + lappend state(mixedL) Content-ID + + array set header $state(header) + lappend header(content-id) [uniqueID] + set state(header) [array get header] + } + + set state(version) 1.0 + + return + } + + if {$state(params) ne {}} { + error "-param requires -canonical" + } + if {$state(encoding) ne {}} { + error "-encoding requires -canonical" + } + if {$state(header) ne {}} { + error "-header requires -canonical" + } + if {[info exists state(parts)]} { + error "-parts requires -canonical" + } + + if {[set fileP [info exists state(file)]]} { + if {[set openP [info exists state(root)]]} { + # FRINK: nocheck + variable $state(root) + upvar 0 $state(root) root + + set state(fd) $root(fd) + } else { + set state(root) $token + set state(fd) [open $state(file) RDONLY] + set state(offset) 0 + seek $state(fd) 0 end + set state(count) [tell $state(fd)] + + fconfigure $state(fd) -translation binary + } + } + + set code [catch {mime::parsepart $token} result] + set ecode $errorCode + set einfo $errorInfo + + if {$fileP} { + if {!$openP} { + unset state(root) + catch {close $state(fd)} + } + unset state(fd) + } + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::mime::parsepart -- +# +# Parses the MIME headers and attempts to break up the message +# into its various parts, creating a MIME token for each part. +# +# Arguments: +# token The MIME token to parse. +# +# Results: +# Throws an error if it has problems parsing the MIME token, +# otherwise it just sets up the appropriate variables. + +proc ::mime::parsepart {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {[set fileP [info exists state(file)]]} { + seek $state(fd) [set pos $state(offset)] start + set last [expr {$state(offset) + $state(count) - 1}] + } else { + set string $state(string) + } + + set vline {} + while 1 { + set blankP 0 + if {$fileP} { + if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} { + set blankP 1 + } else { + incr pos [expr {$x + 1}] + } + } else { + + if {$state(lines.current) >= $state(lines.count)} { + set blankP 1 + set line {} + } else { + set line [lindex $state(lines) $state(lines.current)] + incr state(lines.current) + set x [string length $line] + if {$x == 0} {set blankP 1} + } + + } + + if {(!$blankP) && ([string last \r $line] == {$x - 1})} { + set line [string range $line 0 [expr {$x - 2}]] + if {$x == 1} { + set blankP 1 + } + } + + if {(!$blankP) && (([ + string first { } $line] == 0) || ([ + string first \t $line] == 0))} { + append vline \n $line + continue + } + + if {$vline eq {}} { + if {$blankP} { + break + } + + set vline $line + continue + } + + if {([set x [string first : $vline]] <= 0) \ + || ([set mixed [ string trimright [ + string range $vline 0 [expr {$x - 1}]] + ]] eq {}) + } { + error "improper line in header: $vline" + } + set value [string trim [string range $vline [expr {$x + 1}] end]] + switch -- [set lower [string tolower $mixed]] { + content-type { + if {[info exists state(content)]} { + error "multiple Content-Type fields starting with $vline" + } + + if {![catch {set x [parsetype $token $value]}]} { + set state(content) [lindex $x 0] + set state(params) [lindex $x 1] + } + } + + content-md5 { + } + + content-transfer-encoding { + if {($state(encoding) ne {}) \ + && ($state(encoding) ne [ + string tolower $value])} { + error "multiple Content-Transfer-Encoding fields starting with $vline" + } + + set state(encoding) [string tolower $value] + } + + mime-version { + set state(version) $value + } + + default { + if {[lsearch -exact $state(lowerL) $lower] < 0} { + lappend state(lowerL) $lower + lappend state(mixedL) $mixed + } + + array set header $state(header) + lappend header($lower) $value + set state(header) [array get header] + } + } + + if {$blankP} { + break + } + set vline $line + } + + if {![info exists state(content)]} { + set state(content) text/plain + set state(params) [list charset us-ascii] + } + + if {![string match multipart/* $state(content)]} { + if {$fileP} { + set x [tell $state(fd)] + incr state(count) [expr {$state(offset) - $x}] + set state(offset) $x + } else { + # rebuild string, this is cheap and needed by other functions + set state(string) [join [ + lrange $state(lines) $state(lines.current) end] \n] + } + + if {[string match message/* $state(content)]} { + # FRINK: nocheck + variable [set child $token-[incr state(cid)]] + + set state(value) parts + set state(parts) $child + if {$fileP} { + mime::initializeaux $child \ + -file $state(file) -root $state(root) \ + -offset $state(offset) -count $state(count) + } else { + if {[info exists state(encoding)]} { + set strng [join [ + lrange $state(lines) $state(lines.current) end] \n] + switch -- $state(encoding) { + base64 - + quoted-printable { + set strng [$state(encoding) -mode decode -- $strng] + } + default {} + } + mime::initializeaux $child -string $strng + } else { + mime::initializeaux $child -lineslist [ + lrange $state(lines) $state(lines.current) end] + } + } + } + + return + } + + set state(value) parts + + set boundary {} + foreach {k v} $state(params) { + if {$k eq "boundary"} { + set boundary $v + break + } + } + if {$boundary eq {}} { + error "boundary parameter is missing in $state(content)" + } + if {[string trim $boundary] eq {}} { + error "boundary parameter is empty in $state(content)" + } + + if {$fileP} { + set pos [tell $state(fd)] + # This variable is like 'start', for the reasons laid out + # below, in the other branch of this conditional. + set initialpos $pos + } else { + # This variable is like 'start', a list of lines in the + # part. This record is made even before we find a starting + # boundary and used if we run into the terminating boundary + # before a starting boundary was found. In that case the lines + # before the terminator as recorded by tracelines are seen as + # the part, or at least we attempt to parse them as a + # part. See the forceoctet and nochild flags later. We cannot + # use 'start' as that records lines only after the starting + # boundary was found. + set tracelines [list] + } + + set inP 0 + set moreP 1 + set forceoctet 0 + while {$moreP} { + if {$fileP} { + if {$pos > $last} { + # We have run over the end of the part per the outer + # information without finding a terminating boundary. + # We now fake the boundary and force the parser to + # give any new part coming of this a mime-type of + # application/octet-stream regardless of header + # information. + set line "--$boundary--" + set x [string length $line] + set forceoctet 1 + } else { + if {[set x [gets $state(fd) line]] < 0} { + error "end-of-file encountered while parsing $state(content)" + } + } + incr pos [expr {$x + 1}] + } else { + if {$state(lines.current) >= $state(lines.count)} { + error "end-of-string encountered while parsing $state(content)" + } else { + set line [lindex $state(lines) $state(lines.current)] + incr state(lines.current) + set x [string length $line] + } + set x [string length $line] + } + if {[string last \r $line] == $x - 1} { + set line [string range $line 0 [expr {$x - 2}]] + set crlf 2 + } else { + set crlf 1 + } + + if {[string first --$boundary $line] != 0} { + if {$inP && !$fileP} { + lappend start $line + } + continue + } else { + lappend tracelines $line + } + + if {!$inP} { + # Haven't seen the starting boundary yet. Check if the + # current line contains this starting boundary. + + if {$line eq "--$boundary"} { + # Yes. Switch parser state to now search for the + # terminating boundary of the part and record where + # the part begins (or initialize the recorder for the + # lines in the part). + set inP 1 + if {$fileP} { + set start $pos + } else { + set start [list] + } + continue + } elseif {$line eq "--$boundary--"} { + # We just saw a terminating boundary before we ever + # saw the starting boundary of a part. This forces us + # to stop parsing, we do this by forcing the parser + # into an accepting state. We will try to create a + # child part based on faked start position or recorded + # lines, or, if that fails, let the current part have + # no children. + + # As an example note the test case mime-3.7 and the + # referenced file "badmail1.txt". + + set inP 1 + if {$fileP} { + set start $initialpos + } else { + set start $tracelines + } + set forceoctet 1 + # Fall through. This brings to the creation of the new + # part instead of searching further and possible + # running over the end. + } else { + continue + } + } + + # Looking for the end of the current part. We accept both a + # terminating boundary and the starting boundary of the next + # part as the end of the current part. + + if {[set moreP [string compare $line --$boundary--]] \ + && $line ne "--$boundary"} { + # The current part has not ended, so we record the line + # if we are inside a part and doing string parsing. + if {$inP && !$fileP} { + lappend start $line + } + continue + } + + # The current part has ended. We now determine the exact + # boundaries, create a mime part object for it and recursively + # parse it deeper as part of that action. + + # FRINK: nocheck + variable [set child $token-[incr state(cid)]] + + lappend state(parts) $child + + set nochild 0 + if {$fileP} { + if {[set count [expr {$pos - ($start + $x + $crlf + 1)}]] < 0} { + set count 0 + } + if {$forceoctet} { + set ::errorInfo {} + if {[catch { + mime::initializeaux $child \ + -file $state(file) -root $state(root) \ + -offset $start -count $count + }]} { + set nochild 1 + set state(parts) [lrange $state(parts) 0 end-1] + } } else { + mime::initializeaux $child \ + -file $state(file) -root $state(root) \ + -offset $start -count $count + } + seek $state(fd) [set start $pos] start + } else { + if {$forceoctet} { + if {[catch { + mime::initializeaux $child -lineslist $start + }]} { + set nochild 1 + set state(parts) [lrange $state(parts) 0 end-1] + } + } else { + mime::initializeaux $child -lineslist $start + } + set start {} + } + if {$forceoctet && !$nochild} { + variable $child + upvar 0 $child childstate + set childstate(content) application/octet-stream + } + set forceoctet 0 + } +} + +# ::mime::parsetype -- +# +# Parses the string passed in and identifies the content-type and +# params strings. +# +# Arguments: +# token The MIME token to parse. +# string The content-type string that should be parsed. +# +# Results: +# Returns the content and params for the string as a two element +# tcl list. + +proc ::mime::parsetype {token string} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + + variable typetokenL + variable typelexemeL + + set state(input) $string + set state(buffer) {} + set state(lastC) LX_END + set state(comment) {} + set state(tokenL) $typetokenL + set state(lexemeL) $typelexemeL + + set code [catch {mime::parsetypeaux $token $string} result] + set ecode $errorCode + set einfo $errorInfo + + unset state(input) \ + state(buffer) \ + state(lastC) \ + state(comment) \ + state(tokenL) \ + state(lexemeL) + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::mime::parsetypeaux -- +# +# A helper function for mime::parsetype. Parses the specified +# string looking for the content type and params. +# +# Arguments: +# token The MIME token to parse. +# string The content-type string that should be parsed. +# +# Results: +# Returns the content and params for the string as a two element +# tcl list. + +proc ::mime::parsetypeaux {token string} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {[parselexeme $token] ne "LX_ATOM"} { + error [format "expecting type (found %s)" $state(buffer)] + } + set type [string tolower $state(buffer)] + + switch -- [parselexeme $token] { + LX_SOLIDUS { + } + + LX_END { + if {$type ne "message"} { + error "expecting type/subtype (found $type)" + } + + return [list message/rfc822 {}] + } + + default { + error [format "expecting \"/\" (found %s)" $state(buffer)] + } + } + + if {[parselexeme $token] ne "LX_ATOM"} { + error [format "expecting subtype (found %s)" $state(buffer)] + } + append type [string tolower /$state(buffer)] + + array set params {} + while {1} { + switch -- [parselexeme $token] { + LX_END { + return [list $type [array get params]] + } + + LX_SEMICOLON { + } + + default { + error [format "expecting \";\" (found %s)" $state(buffer)] + } + } + + switch -- [parselexeme $token] { + LX_END { + return [list $type [array get params]] + } + + LX_ATOM { + } + + default { + error [format "expecting attribute (found %s)" $state(buffer)] + } + } + + set attribute [string tolower $state(buffer)] + + if {[parselexeme $token] ne "LX_EQUALS"} { + error [format "expecting \"=\" (found %s)" $state(buffer)] + } + + switch -- [parselexeme $token] { + LX_ATOM { + } + + LX_QSTRING { + set state(buffer) [ + string range $state(buffer) 1 [ + expr {[string length $state(buffer)] - 2}]] + } + + default { + error [format "expecting value (found %s)" $state(buffer)] + } + } + set params($attribute) $state(buffer) + } +} + +# ::mime::finalize -- +# +# mime::finalize destroys a MIME part. +# +# If the -subordinates option is present, it specifies which +# subordinates should also be destroyed. The default value is +# "dynamic". +# +# Arguments: +# token The MIME token to parse. +# args Args can be optionally be of the following form: +# ?-subordinates "all" | "dynamic" | "none"? +# +# Results: +# Returns an empty string. + +proc ::mime::finalize {token args} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set options [list -subordinates dynamic] + array set options $args + + switch -- $options(-subordinates) { + all { + #TODO: this code path is untested + if {$state(value) eq "parts"} { + foreach part $state(parts) { + eval [linsert $args 0 mime::finalize $part] + } + } + } + + dynamic { + for {set cid $state(cid)} {$cid > 0} {incr cid -1} { + eval [linsert $args 0 mime::finalize $token-$cid] + } + } + + none { + } + + default { + error "unknown value for -subordinates $options(-subordinates)" + } + } + + foreach name [array names state] { + unset state($name) + } + # FRINK: nocheck + unset $token +} + +# ::mime::getproperty -- +# +# mime::getproperty returns the properties of a MIME part. +# +# The properties are: +# +# property value +# ======== ===== +# content the type/subtype describing the content +# encoding the "Content-Transfer-Encoding" +# params a list of "Content-Type" parameters +# parts a list of tokens for the part's subordinates +# size the approximate size of the content (unencoded) +# +# The "parts" property is present only if the MIME part has +# subordinates. +# +# If mime::getproperty is invoked with the name of a specific +# property, then the corresponding value is returned; instead, if +# -names is specified, a list of all properties is returned; +# otherwise, a serialized array of properties and values is returned. +# +# Arguments: +# token The MIME token to parse. +# property One of 'content', 'encoding', 'params', 'parts', and +# 'size'. Defaults to returning a serialized array of +# properties and values. +# +# Results: +# Returns the properties of a MIME part + +proc ::mime::getproperty {token {property {}}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + switch -- $property { + {} { + array set properties [list content $state(content) \ + encoding $state(encoding) \ + params $state(params) \ + size [getsize $token]] + if {[info exists state(parts)]} { + set properties(parts) $state(parts) + } + + return [array get properties] + } + + -names { + set names [list content encoding params] + if {[info exists state(parts)]} { + lappend names parts + } + + return $names + } + + content + - + encoding + - + params { + return $state($property) + } + + parts { + if {![info exists state(parts)]} { + error "MIME part is a leaf" + } + + return $state(parts) + } + + size { + return [getsize $token] + } + + default { + error "unknown property $property" + } + } +} + +# ::mime::getsize -- +# +# Determine the size (in bytes) of a MIME part/token +# +# Arguments: +# token The MIME token to parse. +# +# Results: +# Returns the size in bytes of the MIME token. + +proc ::mime::getsize {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + switch -- $state(value)/$state(canonicalP) { + file/0 { + set size $state(count) + } + + file/1 { + return [file size $state(file)] + } + + parts/0 + - + parts/1 { + set size 0 + foreach part $state(parts) { + incr size [getsize $part] + } + + return $size + } + + string/0 { + set size [string length $state(string)] + } + + string/1 { + return [string length $state(string)] + } + default { + error "Unknown combination \"$state(value)/$state(canonicalP)\"" + } + } + + if {$state(encoding) eq "base64"} { + set size [expr {($size * 3 + 2) / 4}] + } + + return $size +} + +# ::mime::getheader -- +# +# mime::getheader returns the header of a MIME part. +# +# A header consists of zero or more key/value pairs. Each value is a +# list containing one or more strings. +# +# If mime::getheader is invoked with the name of a specific key, then +# a list containing the corresponding value(s) is returned; instead, +# if -names is specified, a list of all keys is returned; otherwise, a +# serialized array of keys and values is returned. Note that when a +# key is specified (e.g., "Subject"), the list returned usually +# contains exactly one string; however, some keys (e.g., "Received") +# often occur more than once in the header, accordingly the list +# returned usually contains more than one string. +# +# Arguments: +# token The MIME token to parse. +# key Either a key or '-names'. If it is '-names' a list +# of all keys is returned. +# +# Results: +# Returns the header of a MIME part. + +proc ::mime::getheader {token {key {}}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set header $state(header) + switch -- $key { + {} { + set result {} + foreach lower $state(lowerL) mixed $state(mixedL) { + lappend result $mixed $header($lower) + } + return $result + } + + -names { + return $state(mixedL) + } + + default { + set lower [string tolower [set mixed $key]] + + if {![info exists header($lower)]} { + error "key $mixed not in header" + } + return $header($lower) + } + } +} + +# ::mime::setheader -- +# +# mime::setheader writes, appends to, or deletes the value associated +# with a key in the header. +# +# The value for -mode is one of: +# +# write: the key/value is either created or overwritten (the +# default); +# +# append: a new value is appended for the key (creating it as +# necessary); or, +# +# delete: all values associated with the key are removed (the +# "value" parameter is ignored). +# +# Regardless, mime::setheader returns the previous value associated +# with the key. +# +# Arguments: +# token The MIME token to parse. +# key The name of the key whose value should be set. +# value The value for the header key to be set to. +# args An optional argument of the form: +# ?-mode "write" | "append" | "delete"? +# +# Results: +# Returns previous value associated with the specified key. + +proc ::mime::setheader {token key value args} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set options [list -mode write] + array set options $args + + switch -- [set lower [string tolower $key]] { + content-md5 + - + content-type + - + content-transfer-encoding + - + mime-version { + error "key $key may not be set" + } + default {# Skip key} + } + + array set header $state(header) + if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} { + #TODO: this code path is not tested + if {$options(-mode) eq "delete"} { + error "key $key not in header" + } + + lappend state(lowerL) $lower + lappend state(mixedL) $key + + set result {} + } else { + set result $header($lower) + } + switch -- $options(-mode) { + append { + lappend header($lower) $value + } + + delete { + unset header($lower) + set state(lowerL) [lreplace $state(lowerL) $x $x] + set state(mixedL) [lreplace $state(mixedL) $x $x] + } + + write { + set header($lower) [list $value] + } + + default { + error "unknown value for -mode $options(-mode)" + } + } + + set state(header) [array get header] + + return $result +} + +# ::mime::getbody -- +# +# mime::getbody returns the body of a leaf MIME part in canonical form. +# +# If the -command option is present, then it is repeatedly invoked +# with a fragment of the body as this: +# +# uplevel #0 $callback [list "data" $fragment] +# +# (The -blocksize option, if present, specifies the maximum size of +# each fragment passed to the callback.) +# When the end of the body is reached, the callback is invoked as: +# +# uplevel #0 $callback "end" +# +# Alternatively, if an error occurs, the callback is invoked as: +# +# uplevel #0 $callback [list "error" reason] +# +# Regardless, the return value of the final invocation of the callback +# is propagated upwards by mime::getbody. +# +# If the -command option is absent, then the return value of +# mime::getbody is a string containing the MIME part's entire body. +# +# Arguments: +# token The MIME token to parse. +# args Optional arguments of the form: +# ?-decode? ?-command callback ?-blocksize octets? ? +# +# Results: +# Returns a string containing the MIME part's entire body, or +# if '-command' is specified, the return value of the command +# is returned. + +proc ::mime::getbody {token args} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + + set decode 0 + if {[set pos [lsearch -exact $args -decode]] >= 0} { + set decode 1 + set args [lreplace $args $pos $pos] + } + + array set options [list -command [ + list mime::getbodyaux $token] -blocksize 4096] + array set options $args + if {$options(-blocksize) < 1} { + error "-blocksize expects a positive integer, not $options(-blocksize)" + } + + set code 0 + set ecode {} + set einfo {} + + switch -- $state(value)/$state(canonicalP) { + file/0 { + set fd [open $state(file) RDONLY] + + set code [catch { + fconfigure $fd -translation binary + seek $fd [set pos $state(offset)] start + set last [expr {$state(offset) + $state(count) - 1}] + + set fragment {} + while {$pos <= $last} { + if {[set cc [ + expr {($last - $pos) + 1}]] > $options(-blocksize)} { + set cc $options(-blocksize) + } + incr pos [set len [ + string length [set chunk [read $fd $cc]]]] + switch -exact -- $state(encoding) { + base64 + - + quoted-printable { + if {([set x [string last \n $chunk]] > 0) \ + && ($x + 1 != $len)} { + set chunk [string range $chunk 0 $x] + seek $fd [incr pos [expr {($x + 1) - $len}]] start + } + set chunk [ + $state(encoding) -mode decode -- $chunk] + } + 7bit - 8bit - binary - {} { + # Bugfix for [#477088] + # Go ahead, leave chunk alone + } + default { + error "Can't handle content encoding \"$state(encoding)\"" + } + } + append fragment $chunk + + set cc [expr {$options(-blocksize) - 1}] + while {[string length $fragment] > $options(-blocksize)} { + uplevel #0 $options(-command) [ + list data [string range $fragment 0 $cc]] + + set fragment [ + string range $fragment $options(-blocksize) end] + } + } + if {[string length $fragment] > 0} { + uplevel #0 $options(-command) [list data $fragment] + } + } result] + set ecode $errorCode + set einfo $errorInfo + + catch {close $fd} + } + + file/1 { + set fd [open $state(file) RDONLY] + + set code [catch { + fconfigure $fd -translation binary + + while {[string length [ + set fragment [read $fd $options(-blocksize)]]] > 0} { + uplevel #0 $options(-command) [list data $fragment] + } + } result] + set ecode $errorCode + set einfo $errorInfo + + catch {close $fd} + } + + parts/0 + - + parts/1 { + error "MIME part isn't a leaf" + } + + string/0 + - + string/1 { + switch -- $state(encoding)/$state(canonicalP) { + base64/0 + - + quoted-printable/0 { + set fragment [ + $state(encoding) -mode decode -- $state(string)] + } + + default { + # Not a bugfix for [#477088], but clarification + # This handles no-encoding, 7bit, 8bit, and binary. + set fragment $state(string) + } + } + + set code [catch { + set cc [expr {$options(-blocksize) -1}] + while {[string length $fragment] > $options(-blocksize)} { + uplevel #0 $options(-command) [ + list data [string range $fragment 0 $cc]] + + set fragment [ + string range $fragment $options(-blocksize) end] + } + if {[string length $fragment] > 0} { + uplevel #0 $options(-command) [list data $fragment] + } + } result] + set ecode $errorCode + set einfo $errorInfo + } + default { + error "Unknown combination \"$state(value)/$state(canonicalP)\"" + } + } + + set code [catch { + if {$code} { + uplevel #0 $options(-command) [list error $result] + } else { + uplevel #0 $options(-command) [list end] + } + } result] + set ecode $errorCode + set einfo $errorInfo + + if {$code} { + return -code $code -errorinfo $einfo -errorcode $ecode $result + } + + if {$decode} { + array set params [mime::getproperty $token params] + + if {[info exists params(charset)]} { + set charset $params(charset) + } else { + set charset US-ASCII + } + + set enc [reversemapencoding $charset] + if {$enc ne {}} { + set result [::encoding convertfrom $enc $result] + } else { + return -code error "-decode failed: can't reversemap charset $charset" + } + } + + return $result +} + +# ::mime::getbodyaux -- +# +# Builds up the body of the message, fragment by fragment. When +# the entire message has been retrieved, it is returned. +# +# Arguments: +# token The MIME token to parse. +# reason One of 'data', 'end', or 'error'. +# fragment The section of data data fragment to extract a +# string from. +# +# Results: +# Returns nothing, except when called with the 'end' argument +# in which case it returns a string that contains all of the +# data that 'getbodyaux' has been called with. Will throw an +# error if it is called with the reason of 'error'. + +proc ::mime::getbodyaux {token reason {fragment {}}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + switch $reason { + data { + append state(getbody) $fragment + return {} + } + + end { + if {[info exists state(getbody)]} { + set result $state(getbody) + unset state(getbody) + } else { + set result {} + } + + return $result + } + + error { + catch {unset state(getbody)} + error $reason + } + + default { + error "Unknown reason \"$reason\"" + } + } +} + +# ::mime::copymessage -- +# +# mime::copymessage copies the MIME part to the specified channel. +# +# mime::copymessage operates synchronously, and uses fileevent to +# allow asynchronous operations to proceed independently. +# +# Arguments: +# token The MIME token to parse. +# channel The channel to copy the message to. +# +# Results: +# Returns nothing unless an error is thrown while the message +# is being written to the channel. + +proc ::mime::copymessage {token channel} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + + set openP [info exists state(fd)] + + set code [catch {mime::copymessageaux $token $channel} result] + set ecode $errorCode + set einfo $errorInfo + + if {(!$openP) && ([info exists state(fd)])} { + if {![info exists state(root)]} { + catch {close $state(fd)} + } + unset state(fd) + } + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::mime::copymessageaux -- +# +# mime::copymessageaux copies the MIME part to the specified channel. +# +# Arguments: +# token The MIME token to parse. +# channel The channel to copy the message to. +# +# Results: +# Returns nothing unless an error is thrown while the message +# is being written to the channel. + +proc ::mime::copymessageaux {token channel} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set header $state(header) + + if {$state(version) ne {}} { + puts $channel "MIME-Version: $state(version)" + } + foreach lower $state(lowerL) mixed $state(mixedL) { + foreach value $header($lower) { + puts $channel "$mixed: $value" + } + } + if {(!$state(canonicalP)) \ + && ([set encoding $state(encoding)] ne {})} { + puts $channel "Content-Transfer-Encoding: $encoding" + } + + puts -nonewline $channel "Content-Type: $state(content)" + set boundary {} + foreach {k v} $state(params) { + if {$k eq "boundary"} { + set boundary $v + } + + puts -nonewline $channel ";\n $k=\"$v\"" + } + + set converter {} + set encoding {} + if {$state(value) ne "parts"} { + puts $channel {} + + if {$state(canonicalP)} { + if {[set encoding $state(encoding)] eq {}} { + set encoding [encoding $token] + } + if {$encoding ne {}} { + puts $channel "Content-Transfer-Encoding: $encoding" + } + switch -- $encoding { + base64 + - + quoted-printable { + set converter $encoding + } + 7bit - 8bit - binary - {} { + # Bugfix for [#477088], also [#539952] + # Go ahead + } + default { + error "Can't handle content encoding \"$encoding\"" + } + } + } + } elseif {([string match multipart/* $state(content)]) \ + && ($boundary eq {})} { + # we're doing everything in one pass... + set key [clock seconds]$token[info hostname][array get state] + set seqno 8 + while {[incr seqno -1] >= 0} { + set key [md5 -- $key] + } + set boundary "----- =_[string trim [base64 -mode encode -- $key]]" + + puts $channel ";\n boundary=\"$boundary\"" + } else { + puts $channel {} + } + + if {[info exists state(error)]} { + unset state(error) + } + + switch -- $state(value) { + file { + set closeP 1 + if {[info exists state(root)]} { + # FRINK: nocheck + variable $state(root) + upvar 0 $state(root) root + + if {[info exists root(fd)]} { + set fd $root(fd) + set closeP 0 + } else { + set fd [set state(fd) [open $state(file) RDONLY]] + } + set size $state(count) + } else { + set fd [set state(fd) [open $state(file) RDONLY]] + # read until eof + set size -1 + } + seek $fd $state(offset) start + if {$closeP} { + fconfigure $fd -translation binary + } + + puts $channel {} + + while {($size != 0) && (![eof $fd])} { + if {$size < 0 || $size > 32766} { + set X [read $fd 32766] + } else { + set X [read $fd $size] + } + if {$size > 0} { + set size [expr {$size - [string length $X]}] + } + if {$converter eq {}} { + puts -nonewline $channel $X + } else { + puts -nonewline $channel [$converter -mode encode -- $X] + } + } + + if {$closeP} { + catch {close $state(fd)} + unset state(fd) + } + } + + parts { + if {(![info exists state(root)]) \ + && ([info exists state(file)])} { + set state(fd) [open $state(file) RDONLY] + fconfigure $state(fd) -translation binary + } + + switch -glob -- $state(content) { + message/* { + puts $channel {} + foreach part $state(parts) { + mime::copymessage $part $channel + break + } + } + + default { + # Note RFC 2046: See buildmessageaux for details. + + foreach part $state(parts) { + puts $channel \n--$boundary + mime::copymessage $part $channel + } + puts $channel \n--$boundary-- + } + } + + if {[info exists state(fd)]} { + catch {close $state(fd)} + unset state(fd) + } + } + + string { + if {[catch {fconfigure $channel -buffersize} blocksize]} { + set blocksize 4096 + } elseif {$blocksize < 512} { + set blocksize 512 + } + set blocksize [expr {($blocksize / 4) * 3}] + + # [893516] + fconfigure $channel -buffersize $blocksize + + puts $channel {} + + #TODO: tests don't cover these paths + if {$converter eq {}} { + puts -nonewline $channel $state(string) + } else { + puts -nonewline $channel [$converter -mode encode -- $state(string)] + } + } + default { + error "Unknown value \"$state(value)\"" + } + } + + flush $channel + + if {[info exists state(error)]} { + error $state(error) + } +} + +# ::mime::buildmessage -- +# +# The following is a clone of the copymessage code to build up the +# result in memory, and, unfortunately, without using a memory channel. +# I considered parameterizing the "puts" calls in copy message, but +# the need for this procedure may go away, so I'm living with it for +# the moment. +# +# Arguments: +# token The MIME token to parse. +# +# Results: +# Returns the message that has been built up in memory. + +proc ::mime::buildmessage {token} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + + set openP [info exists state(fd)] + + set code [catch {mime::buildmessageaux $token} result] + if {![info exists errorCode]} { + set ecode {} + } else { + set ecode $errorCode + } + set einfo $errorInfo + + if {(!$openP) && ([info exists state(fd)])} { + if {![info exists state(root)]} { + catch {close $state(fd)} + } + unset state(fd) + } + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::mime::buildmessageaux -- +# +# The following is a clone of the copymessageaux code to build up the +# result in memory, and, unfortunately, without using a memory channel. +# I considered parameterizing the "puts" calls in copy message, but +# the need for this procedure may go away, so I'm living with it for +# the moment. +# +# Arguments: +# token The MIME token to parse. +# +# Results: +# Returns the message that has been built up in memory. + +proc ::mime::buildmessageaux {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set header $state(header) + + set result {} + if {$state(version) ne {}} { + append result "MIME-Version: $state(version)\r\n" + } + foreach lower $state(lowerL) mixed $state(mixedL) { + foreach value $header($lower) { + append result "$mixed: $value\r\n" + } + } + if {(!$state(canonicalP)) \ + && ([set encoding $state(encoding)] ne {})} { + append result "Content-Transfer-Encoding: $encoding\r\n" + } + + append result "Content-Type: $state(content)" + set boundary {} + foreach {k v} $state(params) { + if {$k eq "boundary"} { + set boundary $v + } + + append result ";\r\n $k=\"$v\"" + } + + set converter {} + set encoding {} + if {$state(value) ne "parts"} { + #TODO: the path is not covered by tests + append result \r\n + + if {$state(canonicalP)} { + if {[set encoding $state(encoding)] eq {}} { + set encoding [encoding $token] + } + if {$encoding ne {}} { + append result "Content-Transfer-Encoding: $encoding\r\n" + } + switch -- $encoding { + base64 + - + quoted-printable { + set converter $encoding + } + 7bit - 8bit - binary - {} { + # Bugfix for [#477088] + # Go ahead + } + default { + error "Can't handle content encoding \"$encoding\"" + } + } + } + } elseif {([string match multipart/* $state(content)]) \ + && ($boundary eq {})} { + # we're doing everything in one pass... + set key [clock seconds]$token[info hostname][array get state] + set seqno 8 + while {[incr seqno -1] >= 0} { + set key [md5 -- $key] + } + set boundary "----- =_[string trim [base64 -mode encode -- $key]]" + + append result ";\r\n boundary=\"$boundary\"\r\n" + } else { + append result \r\n + } + + if {[info exists state(error)]} { + unset state(error) + } + + switch -- $state(value) { + file { + set closeP 1 + if {[info exists state(root)]} { + # FRINK: nocheck + variable $state(root) + upvar 0 $state(root) root + + if {[info exists root(fd)]} { + set fd $root(fd) + set closeP 0 + } else { + set fd [set state(fd) [open $state(file) RDONLY]] + } + set size $state(count) + } else { + set fd [set state(fd) [open $state(file) RDONLY]] + set size -1 ;# Read until EOF + } + seek $fd $state(offset) start + if {$closeP} { + fconfigure $fd -translation binary + } + + append result \r\n + + while {($size != 0) && (![eof $fd])} { + if {$size < 0 || $size > 32766} { + set X [read $fd 32766] + } else { + set X [read $fd $size] + } + if {$size > 0} { + set size [expr {$size - [string length $X]}] + } + if {$converter ne {}} { + append result [$converter -mode encode -- $X] + } else { + append result $X + } + } + + if {$closeP} { + catch {close $state(fd)} + unset state(fd) + } + } + + parts { + if {(![info exists state(root)]) \ + && ([info exists state(file)])} { + set state(fd) [open $state(file) RDONLY] + fconfigure $state(fd) -translation binary + } + + switch -glob -- $state(content) { + message/* { + append result "\r\n" + foreach part $state(parts) { + append result [buildmessage $part] + break + } + } + + default { + # Note RFC 2046: + # + # The boundary delimiter MUST occur at the + # beginning of a line, i.e., following a CRLF, and + # the initial CRLF is considered to be attached to + # the boundary delimiter line rather than part of + # the preceding part. + # + # - The above means that the CRLF before $boundary + # is needed per the RFC, and the parts must not + # have a closing CRLF of their own. See Tcllib bug + # 1213527, and patch 1254934 for the problems when + # both file/string brnaches added CRLF after the + # body parts. + + foreach part $state(parts) { + append result "\r\n--$boundary\r\n" + append result [buildmessage $part] + } + append result "\r\n--$boundary--\r\n" + } + } + + if {[info exists state(fd)]} { + catch {close $state(fd)} + unset state(fd) + } + } + + string { + append result "\r\n" + + if {$converter ne {}} { + append result [$converter -mode encode -- $state(string)] + } else { + append result $state(string) + } + } + default { + error "Unknown value \"$state(value)\"" + } + } + + if {[info exists state(error)]} { + error $state(error) + } + return $result +} + +# ::mime::encoding -- +# +# Determines how a token is encoded. +# +# Arguments: +# token The MIME token to parse. +# +# Results: +# Returns the encoding of the message (the null string, base64, +# or quoted-printable). + +proc ::mime::encoding {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + switch -glob -- $state(content) { + audio/* + - + image/* + - + video/* { + return base64 + } + + message/* + - + multipart/* { + return {} + } + default {# Skip} + } + + set asciiP 1 + set lineP 1 + switch -- $state(value) { + file { + set fd [open $state(file) RDONLY] + fconfigure $fd -translation binary + + while {[gets $fd line] >= 0} { + if {$asciiP} { + set asciiP [encodingasciiP $line] + } + if {$lineP} { + set lineP [encodinglineP $line] + } + if {(!$asciiP) && (!$lineP)} { + break + } + } + + catch {close $fd} + } + + parts { + return {} + } + + string { + foreach line [split $state(string) "\n"] { + if {$asciiP} { + set asciiP [encodingasciiP $line] + } + if {$lineP} { + set lineP [encodinglineP $line] + } + if {(!$asciiP) && (!$lineP)} { + break + } + } + } + default { + error "Unknown value \"$state(value)\"" + } + } + + switch -glob -- $state(content) { + text/* { + if {!$asciiP} { + #TODO: this path is not covered by tests + foreach {k v} $state(params) { + if {$k eq "charset"} { + set v [string tolower $v] + if {($v ne "us-ascii") \ + && (![string match {iso-8859-[1-8]} $v])} { + return base64 + } + + break + } + } + } + + if {!$lineP} { + return quoted-printable + } + } + + + default { + if {(!$asciiP) || (!$lineP)} { + return base64 + } + } + } + + return {} +} + +# ::mime::encodingasciiP -- +# +# Checks if a string is a pure ascii string, or if it has a non-standard +# form. +# +# Arguments: +# line The line to check. +# +# Results: +# Returns 1 if \r only occurs at the end of lines, and if all +# characters in the line are between the ASCII codes of 32 and 126. + +proc ::mime::encodingasciiP {line} { + foreach c [split $line {}] { + switch -- $c { + { } - \t - \r - \n { + } + + default { + binary scan $c c c + if {($c < 32) || ($c > 126)} { + return 0 + } + } + } + } + if {([set r [string first \r $line]] < 0) \ + || ($r == {[string length $line] - 1})} { + return 1 + } + + return 0 +} + +# ::mime::encodinglineP -- +# +# Checks if a string is a line is valid to be processed. +# +# Arguments: +# line The line to check. +# +# Results: +# Returns 1 the line is less than 76 characters long, the line +# contains more characters than just whitespace, the line does +# not start with a '.', and the line does not start with 'From '. + +proc ::mime::encodinglineP {line} { + if {([string length $line] > 76) \ + || ($line ne [string trimright $line]) \ + || ([string first . $line] == 0) \ + || ([string first {From } $line] == 0)} { + return 0 + } + + return 1 +} + +# ::mime::fcopy -- +# +# Appears to be unused. +# +# Arguments: +# +# Results: +# + +proc ::mime::fcopy {token count {error {}}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {$error ne {}} { + set state(error) $error + } + set state(doneP) 1 +} + +# ::mime::scopy -- +# +# Copy a portion of the contents of a mime token to a channel. +# +# Arguments: +# token The token containing the data to copy. +# channel The channel to write the data to. +# offset The location in the string to start copying +# from. +# len The amount of data to write. +# blocksize The block size for the write operation. +# +# Results: +# The specified portion of the string in the mime token is +# copied to the specified channel. + +proc ::mime::scopy {token channel offset len blocksize} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {$len <= 0} { + set state(doneP) 1 + fileevent $channel writable {} + return + } + + if {[set cc $len] > $blocksize} { + set cc $blocksize + } + + if {[catch { + puts -nonewline $channel [ + string range $state(string) $offset [expr {$offset + $cc - 1}]] + fileevent $channel writable [ + list mime::scopy $token $channel [ + incr offset $cc] [incr len -$cc] $blocksize] + } result]} { + + set state(error) $result + set state(doneP) 1 + fileevent $channel writable {} + } + return +} + +# ::mime::qp_encode -- +# +# Tcl version of quote-printable encode +# +# Arguments: +# string The string to quote. +# encoded_word Boolean value to determine whether or not encoded words +# (RFC 2047) should be handled or not. (optional) +# +# Results: +# The properly quoted string is returned. + +proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} { + # 8.1+ improved string manipulation routines used. + # Replace outlying characters, characters that would normally + # be munged by EBCDIC gateways, and special Tcl characters "[\]{} + # with =xx sequence + + regsub -all -- \ + {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \ + $string {[format =%02X [scan "\\&" %c]]} string + + # Replace the format commands with their result + + set string [subst -novariables $string] + + # soft/hard newlines and other + # Funky cases for SMTP compatibility + set mapChars [ + list " \n" =20\n \t\n =09\n \n\.\n \=2E\n "\nFrom " "\n=46rom "] + if {$encoded_word} { + # Special processing for encoded words (RFC 2047) + lappend mapChars { } _ + } + set string [string map $mapChars $string] + + # Break long lines - ugh + + # Implementation of FR #503336 + if {$no_softbreak} { + set result $string + } else { + set result {} + foreach line [split $string \n] { + while {[string length $line] > 72} { + set chunk [string range $line 0 72] + if {[regexp -- (=|=.)$ $chunk dummy end]} { + + # Don't break in the middle of a code + + set len [expr {72 - [string length $end]}] + set chunk [string range $line 0 $len] + incr len + set line [string range $line $len end] + } else { + set line [string range $line 73 end] + } + append result $chunk=\n + } + append result $line\n + } + + # Trim off last \n, since the above code has the side-effect + # of adding an extra \n to the encoded string and return the + # result. + set result [string range $result 0 end-1] + } + + # If the string ends in space or tab, replace with =xx + + set lastChar [string index $result end] + if {$lastChar eq { }} { + set result [string replace $result end end =20] + } elseif {$lastChar eq "\t"} { + set result [string replace $result end end =09] + } + + return $result +} + +# ::mime::qp_decode -- +# +# Tcl version of quote-printable decode +# +# Arguments: +# string The quoted-prinatble string to decode. +# encoded_word Boolean value to determine whether or not encoded words +# (RFC 2047) should be handled or not. (optional) +# +# Results: +# The decoded string is returned. + +proc ::mime::qp_decode {string {encoded_word 0}} { + # 8.1+ improved string manipulation routines used. + # Special processing for encoded words (RFC 2047) + + if {$encoded_word} { + # _ == \x20, even if SPACE occupies a different code position + set string [string map [list _ \u0020] $string] + } + + # smash the white-space at the ends of lines since that must've been + # generated by an MUA. + + regsub -all -- {[ \t]+\n} $string \n string + set string [string trimright $string " \t"] + + # Protect the backslash for later subst and + # smash soft newlines, has to occur after white-space smash + # and any encoded word modification. + + #TODO: codepath not tested + set string [string map [list \\ {\\} =\n {}] $string] + + # Decode specials + + regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string + + # process \u unicode mapped chars + + return [subst -novariables -nocommands $string] +} + +# ::mime::parseaddress -- +# +# This was originally written circa 1982 in C. we're still using it +# because it recognizes virtually every buggy address syntax ever +# generated! +# +# mime::parseaddress takes a string containing one or more 822-style +# address specifications and returns a list of serialized arrays, one +# element for each address specified in the argument. +# +# Each serialized array contains these properties: +# +# property value +# ======== ===== +# address local@domain +# comment 822-style comment +# domain the domain part (rhs) +# error non-empty on a parse error +# group this address begins a group +# friendly user-friendly rendering +# local the local part (lhs) +# memberP this address belongs to a group +# phrase the phrase part +# proper 822-style address specification +# route 822-style route specification (obsolete) +# +# Note that one or more of these properties may be empty. +# +# Arguments: +# string The address string to parse +# +# Results: +# Returns a list of serialized arrays, one element for each address +# specified in the argument. + +proc ::mime::parseaddress {string} { + global errorCode errorInfo + + variable mime + + set token [namespace current]::[incr mime(uid)] + # FRINK: nocheck + variable $token + upvar 0 $token state + + set code [catch {mime::parseaddressaux $token $string} result] + set ecode $errorCode + set einfo $errorInfo + + foreach name [array names state] { + unset state($name) + } + # FRINK: nocheck + catch {unset $token} + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::mime::parseaddressaux -- +# +# This was originally written circa 1982 in C. we're still using it +# because it recognizes virtually every buggy address syntax ever +# generated! +# +# mime::parseaddressaux does the actually parsing for mime::parseaddress +# +# Each serialized array contains these properties: +# +# property value +# ======== ===== +# address local@domain +# comment 822-style comment +# domain the domain part (rhs) +# error non-empty on a parse error +# group this address begins a group +# friendly user-friendly rendering +# local the local part (lhs) +# memberP this address belongs to a group +# phrase the phrase part +# proper 822-style address specification +# route 822-style route specification (obsolete) +# +# Note that one or more of these properties may be empty. +# +# Arguments: +# token The MIME token to work from. +# string The address string to parse +# +# Results: +# Returns a list of serialized arrays, one element for each address +# specified in the argument. + +proc ::mime::parseaddressaux {token string} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + variable addrtokenL + variable addrlexemeL + + set state(input) $string + set state(glevel) 0 + set state(buffer) {} + set state(lastC) LX_END + set state(tokenL) $addrtokenL + set state(lexemeL) $addrlexemeL + + set result {} + while {[addr_next $token]} { + if {[set tail $state(domain)] ne {}} { + set tail @$state(domain) + } else { + set tail @[info hostname] + } + if {[set address $state(local)] ne {}} { + #TODO: this path is not covered by tests + append address $tail + } + + if {$state(phrase) ne {}} { + #TODO: this path is not covered by tests + set state(phrase) [string trim $state(phrase) \"] + foreach t $state(tokenL) { + if {[string first $t $state(phrase)] >= 0} { + #TODO: is this quoting robust enough? + set state(phrase) \"$state(phrase)\" + break + } + } + + set proper "$state(phrase) <$address>" + } else { + set proper $address + } + + if {[set friendly $state(phrase)] eq {}} { + #TODO: this path is not covered by tests + if {[set note $state(comment)] ne {}} { + if {[string first ( $note] == 0} { + set note [string trimleft [string range $note 1 end]] + } + if {[string last ) $note] \ + == [set len [expr {[string length $note] - 1}]]} { + set note [string range $note 0 [expr {$len - 1}]] + } + set friendly $note + } + + if {($friendly eq {}) \ + && ([set mbox $state(local)] ne {})} { + #TODO: this path is not covered by tests + set mbox [string trim $mbox \"] + + if {[string first / $mbox] != 0} { + set friendly $mbox + } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} { + } elseif {([set friendly [addr_x400 $mbox S]] ne {}) \ + && ([set g [addr_x400 $mbox G]] ne {})} { + set friendly "$g $friendly" + } + + if {$friendly eq {}} { + set friendly $mbox + } + } + } + set friendly [string trim $friendly \"] + + lappend result [list address $address \ + comment $state(comment) \ + domain $state(domain) \ + error $state(error) \ + friendly $friendly \ + group $state(group) \ + local $state(local) \ + memberP $state(memberP) \ + phrase $state(phrase) \ + proper $proper \ + route $state(route)] + + } + + unset state(input) \ + state(glevel) \ + state(buffer) \ + state(lastC) \ + state(tokenL) \ + state(lexemeL) + + return $result +} + +# ::mime::addr_next -- +# +# Locate the next address in a mime token. +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns 1 if there is another address, and 0 if there is not. + +proc ::mime::addr_next {token} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + set nocomplain [package vsatisfies [package provide Tcl] 8.4] + foreach prop {comment domain error group local memberP phrase route} { + if {$nocomplain} { + unset -nocomplain state($prop) + } else { + if {[catch {unset state($prop)}]} {set ::errorInfo {}} + } + } + + switch -- [set code [catch {mime::addr_specification $token} result]] { + 0 { + if {!$result} { + return 0 + } + + switch -- $state(lastC) { + LX_COMMA + - + LX_END { + } + default { + # catch trailing comments... + set lookahead $state(input) + mime::parselexeme $token + set state(input) $lookahead + } + } + } + + 7 { + set state(error) $result + + while {1} { + switch -- $state(lastC) { + LX_COMMA + - + LX_END { + break + } + + default { + mime::parselexeme $token + } + } + } + } + + default { + set ecode $errorCode + set einfo $errorInfo + + return -code $code -errorinfo $einfo -errorcode $ecode $result + } + } + + foreach prop {comment domain error group local memberP phrase route} { + if {![info exists state($prop)]} { + set state($prop) {} + } + } + + return 1 +} + +# ::mime::addr_specification -- +# +# Uses lookahead parsing to determine whether there is another +# valid e-mail address or not. Throws errors if unrecognized +# or invalid e-mail address syntax is used. +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns 1 if there is another address, and 0 if there is not. + +proc ::mime::addr_specification {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + set lookahead $state(input) + switch -- [parselexeme $token] { + LX_ATOM + - + LX_QSTRING { + set state(phrase) $state(buffer) + } + + LX_SEMICOLON { + if {[incr state(glevel) -1] < 0} { + return -code 7 "extraneous semi-colon" + } + + catch {unset state(comment)} + return [addr_specification $token] + } + + LX_COMMA { + catch {unset state(comment)} + return [addr_specification $token] + } + + LX_END { + return 0 + } + + LX_LBRACKET { + return [addr_routeaddr $token] + } + + LX_ATSIGN { + set state(input) $lookahead + return [addr_routeaddr $token 0] + } + + default { + return -code 7 \ + [format "unexpected character at beginning (found %s)" \ + $state(buffer)] + } + } + + switch -- [parselexeme $token] { + LX_ATOM + - + LX_QSTRING { + append state(phrase) " " $state(buffer) + + return [addr_phrase $token] + } + + LX_LBRACKET { + return [addr_routeaddr $token] + } + + LX_COLON { + return [addr_group $token] + } + + LX_DOT { + set state(local) "$state(phrase)$state(buffer)" + unset state(phrase) + mime::addr_routeaddr $token 0 + mime::addr_end $token + } + + LX_ATSIGN { + set state(memberP) $state(glevel) + set state(local) $state(phrase) + unset state(phrase) + mime::addr_domain $token + mime::addr_end $token + } + + LX_SEMICOLON + - + LX_COMMA + - + LX_END { + set state(memberP) $state(glevel) + if {($state(lastC) eq "LX_SEMICOLON") \ + && ([incr state(glevel) -1] < 0)} { + #TODO: this path is not covered by tests + return -code 7 "extraneous semi-colon" + } + + set state(local) $state(phrase) + unset state(phrase) + } + + default { + return -code 7 [ + format "expecting mailbox (found %s)" $state(buffer)] + } + } + + return 1 +} + +# ::mime::addr_routeaddr -- +# +# Parses the domain portion of an e-mail address. Finds the '@' +# sign and then calls mime::addr_route to verify the domain. +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns 1 if there is another address, and 0 if there is not. + +proc ::mime::addr_routeaddr {token {checkP 1}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + set lookahead $state(input) + if {[parselexeme $token] eq "LX_ATSIGN"} { + #TODO: this path is not covered by tests + mime::addr_route $token + } else { + set state(input) $lookahead + } + + mime::addr_local $token + + switch -- $state(lastC) { + LX_ATSIGN { + mime::addr_domain $token + } + + LX_SEMICOLON + - + LX_RBRACKET + - + LX_COMMA + - + LX_END { + } + + default { + return -code 7 [ + format "expecting at-sign after local-part (found %s)" \ + $state(buffer)] + } + } + + if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} { + return -code 7 [ + format "expecting right-bracket (found %s)" $state(buffer)] + } + + return 1 +} + +# ::mime::addr_route -- +# +# Attempts to parse the portion of the e-mail address after the @. +# Tries to verify that the domain definition has a valid form. +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + +proc ::mime::addr_route {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + set state(route) @ + + while {1} { + switch -- [parselexeme $token] { + LX_ATOM + - + LX_DLITERAL { + append state(route) $state(buffer) + } + + default { + return -code 7 \ + [format "expecting sub-route in route-part (found %s)" \ + $state(buffer)] + } + } + + switch -- [parselexeme $token] { + LX_COMMA { + append state(route) $state(buffer) + while {1} { + switch -- [parselexeme $token] { + LX_COMMA { + } + + LX_ATSIGN { + append state(route) $state(buffer) + break + } + + default { + return -code 7 \ + [format "expecting at-sign in route (found %s)" \ + $state(buffer)] + } + } + } + } + + LX_ATSIGN + - + LX_DOT { + append state(route) $state(buffer) + } + + LX_COLON { + append state(route) $state(buffer) + return + } + + default { + return -code 7 \ + [format "expecting colon to terminate route (found %s)" \ + $state(buffer)] + } + } + } +} + +# ::mime::addr_domain -- +# +# Attempts to parse the portion of the e-mail address after the @. +# Tries to verify that the domain definition has a valid form. +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + +proc ::mime::addr_domain {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + while {1} { + switch -- [parselexeme $token] { + LX_ATOM + - + LX_DLITERAL { + append state(domain) $state(buffer) + } + + default { + return -code 7 \ + [format "expecting sub-domain in domain-part (found %s)" \ + $state(buffer)] + } + } + + switch -- [parselexeme $token] { + LX_DOT { + append state(domain) $state(buffer) + } + + LX_ATSIGN { + append state(local) % $state(domain) + unset state(domain) + } + + default { + return + } + } + } +} + +# ::mime::addr_local -- +# +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + +proc ::mime::addr_local {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + set state(memberP) $state(glevel) + + while {1} { + switch -- [parselexeme $token] { + LX_ATOM + - + LX_QSTRING { + append state(local) $state(buffer) + } + + default { + return -code 7 \ + [format "expecting mailbox in local-part (found %s)" \ + $state(buffer)] + } + } + + switch -- [parselexeme $token] { + LX_DOT { + append state(local) $state(buffer) + } + + default { + return + } + } + } +} + +# ::mime::addr_phrase -- +# +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + + +proc ::mime::addr_phrase {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + while {1} { + switch -- [parselexeme $token] { + LX_ATOM + - + LX_QSTRING { + append state(phrase) " " $state(buffer) + } + + default { + break + } + } + } + + switch -- $state(lastC) { + LX_LBRACKET { + return [addr_routeaddr $token] + } + + LX_COLON { + return [addr_group $token] + } + + LX_DOT { + append state(phrase) $state(buffer) + return [addr_phrase $token] + } + + default { + return -code 7 \ + [format "found phrase instead of mailbox (%s%s)" \ + $state(phrase) $state(buffer)] + } + } +} + +# ::mime::addr_group -- +# +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + +proc ::mime::addr_group {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {[incr state(glevel)] > 1} { + return -code 7 [format "nested groups not allowed (found %s)" \ + $state(phrase)] + } + + set state(group) $state(phrase) + unset state(phrase) + + set lookahead $state(input) + while {1} { + switch -- [parselexeme $token] { + LX_SEMICOLON + - + LX_END { + set state(glevel) 0 + return 1 + } + + LX_COMMA { + } + + default { + set state(input) $lookahead + return [addr_specification $token] + } + } + } +} + +# ::mime::addr_end -- +# +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + +proc ::mime::addr_end {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + switch -- $state(lastC) { + LX_SEMICOLON { + if {[incr state(glevel) -1] < 0} { + return -code 7 "extraneous semi-colon" + } + } + + LX_COMMA + - + LX_END { + } + + default { + return -code 7 [format "junk after local@domain (found %s)" \ + $state(buffer)] + } + } +} + +# ::mime::addr_x400 -- +# +# +# Arguments: +# token The MIME token to work from. +# +# Results: +# Returns nothing if successful, and throws an error if invalid +# syntax is found. + +proc ::mime::addr_x400 {mbox key} { + if {[set x [string first /$key= [string toupper $mbox]]] < 0} { + return {} + } + set mbox [string range $mbox [expr {$x + [string length $key] + 2}] end] + + if {[set x [string first / $mbox]] > 0} { + set mbox [string range $mbox 0 [expr {$x - 1}]] + } + + return [string trim $mbox \"] +} + +# ::mime::parsedatetime -- +# +# Fortunately the clock command in the Tcl 8.x core does all the heavy +# lifting for us (except for timezone calculations). +# +# mime::parsedatetime takes a string containing an 822-style date-time +# specification and returns the specified property. +# +# The list of properties and their ranges are: +# +# property range +# ======== ===== +# clock raw result of "clock scan" +# hour 0 .. 23 +# lmonth January, February, ..., December +# lweekday Sunday, Monday, ... Saturday +# mday 1 .. 31 +# min 0 .. 59 +# mon 1 .. 12 +# month Jan, Feb, ..., Dec +# proper 822-style date-time specification +# rclock elapsed seconds between then and now +# sec 0 .. 59 +# wday 0 .. 6 (Sun .. Mon) +# weekday Sun, Mon, ..., Sat +# yday 1 .. 366 +# year 1900 ... +# zone -720 .. 720 (minutes east of GMT) +# +# Arguments: +# value Either a 822-style date-time specification or '-now' +# if the current date/time should be used. +# property The property (from the list above) to return +# +# Results: +# Returns the string value of the 'property' for the date/time that was +# specified in 'value'. + +namespace eval ::mime { + variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat] + variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \ + Friday Saturday] + + # Counting months starts at 1, so just insert a dummy element + # at index 0. + variable MONTHS_SHORT [list {} \ + Jan Feb Mar Apr May Jun \ + Jul Aug Sep Oct Nov Dec] + variable MONTHS_LONG [list {} \ + January February March April May June July \ + August Sepember October November December] +} +proc ::mime::parsedatetime {value property} { + if {$value eq "-now"} { + set clock [clock seconds] + } elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \ + -> value zone_sign zone_hour zone_min]} { + set clock [clock scan $value -gmt 1] + if {[info exists zone_min]} { + set zone_min [scan $zone_min %d] + set zone_hour [scan $zone_hour %d] + set zone [expr {60 * ($zone_min + 60 * $zone_hour)}] + if {$zone_sign eq "+"} { + set zone -$zone + } + incr clock $zone + } + } else { + set clock [clock scan $value] + } + + switch -- $property { + clock { + return $clock + } + + hour { + set value [clock format $clock -format %H] + } + + lmonth { + variable MONTHS_LONG + return [lindex $MONTHS_LONG \ + [scan [clock format $clock -format %m] %d]] + } + + lweekday { + variable WDAYS_LONG + return [lindex $WDAYS_LONG [clock format $clock -format %w]] + } + + mday { + set value [clock format $clock -format %d] + } + + min { + set value [clock format $clock -format %M] + } + + mon { + set value [clock format $clock -format %m] + } + + month { + variable MONTHS_SHORT + return [lindex $MONTHS_SHORT \ + [scan [clock format $clock -format %m] %d]] + } + + proper { + set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" \ + -gmt true] + if {[set diff [expr {($clock-[clock scan $gmt]) / 60}]] < 0} { + set s - + set diff [expr {-($diff)}] + } else { + set s + + } + set zone [format %s%02d%02d $s [ + expr {$diff / 60}] [expr {$diff % 60}]] + + variable WDAYS_SHORT + set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]] + variable MONTHS_SHORT + set mon [lindex $MONTHS_SHORT \ + [scan [clock format $clock -format %m] %d]] + + return [clock format $clock \ + -format "$wday, %d $mon %Y %H:%M:%S $zone"] + } + + rclock { + #TODO: these paths are not covered by tests + if {$value eq "-now"} { + return 0 + } else { + return [expr {[clock seconds] - $clock}] + } + } + + sec { + set value [clock format $clock -format %S] + } + + wday { + return [clock format $clock -format %w] + } + + weekday { + variable WDAYS_SHORT + return [lindex $WDAYS_SHORT [clock format $clock -format %w]] + } + + yday { + set value [clock format $clock -format %j] + } + + year { + set value [clock format $clock -format %Y] + } + + zone { + set value [string trim [string map [list \t { }] $value]] + if {[set x [string last { } $value]] < 0} { + return 0 + } + set value [string range $value [expr {$x + 1}] end] + switch -- [set s [string index $value 0]] { + + - - { + if {$s eq "+"} { + #TODO: This path is not covered by tests + set s {} + } + set value [string trim [string range $value 1 end]] + if {([string length $value] != 4) \ + || ([scan $value %2d%2d h m] != 2) \ + || ($h > 12) \ + || ($m > 59) \ + || (($h == 12) && ($m > 0))} { + error "malformed timezone-specification: $value" + } + set value $s[expr {$h * 60 + $m}] + } + + default { + set value [string toupper $value] + set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT] + set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7] + if {[set x [lsearch -exact $z1 $value]] < 0} { + error "unrecognized timezone-mnemonic: $value" + } + set value [expr {[lindex $z2 $x] * 60}] + } + } + } + + date2gmt + - + date2local + - + dst + - + sday + - + szone + - + tzone + - + default { + error "unknown property $property" + } + } + + if {[set value [string trimleft $value 0]] eq {}} { + #TODO: this path is not covered by tests + set value 0 + } + return $value +} + +# ::mime::uniqueID -- +# +# Used to generate a 'globally unique identifier' for the content-id. +# The id is built from the pid, the current time, the hostname, and +# a counter that is incremented each time a message is sent. +# +# Arguments: +# +# Results: +# Returns the a string that contains the globally unique identifier +# that should be used for the Content-ID of an e-mail message. + +proc ::mime::uniqueID {} { + variable mime + + return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>" +} + +# ::mime::parselexeme -- +# +# Used to implement a lookahead parser. +# +# Arguments: +# token The MIME token to operate on. +# +# Results: +# Returns the next token found by the parser. + +proc ::mime::parselexeme {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + set state(input) [string trimleft $state(input)] + + set state(buffer) {} + if {$state(input) eq {}} { + set state(buffer) end-of-input + return [set state(lastC) LX_END] + } + + set c [string index $state(input) 0] + set state(input) [string range $state(input) 1 end] + + if {$c eq "("} { + set noteP 0 + set quoteP 0 + + while 1 { + append state(buffer) $c + + #TODO: some of these paths are not covered by tests + switch -- $c/$quoteP { + (/0 { + incr noteP + } + + \\/0 { + set quoteP 1 + } + + )/0 { + if {[incr noteP -1] < 1} { + if {[info exists state(comment)]} { + append state(comment) { } + } + append state(comment) $state(buffer) + + return [parselexeme $token] + } + } + + default { + set quoteP 0 + } + } + + if {[set c [string index $state(input) 0]] eq {}} { + set state(buffer) "end-of-input during comment" + return [set state(lastC) LX_ERR] + } + set state(input) [string range $state(input) 1 end] + } + } + + if {$c eq "\""} { + set firstP 1 + set quoteP 0 + + while 1 { + append state(buffer) $c + + switch -- $c/$quoteP { + "\\/0" { + set quoteP 1 + } + + "\"/0" { + if {!$firstP} { + return [set state(lastC) LX_QSTRING] + } + set firstP 0 + } + + default { + set quoteP 0 + } + } + + if {[set c [string index $state(input) 0]] eq {}} { + set state(buffer) "end-of-input during quoted-string" + return [set state(lastC) LX_ERR] + } + set state(input) [string range $state(input) 1 end] + } + } + + if {$c eq {[}} { + set quoteP 0 + + while 1 { + append state(buffer) $c + + switch -- $c/$quoteP { + \\/0 { + set quoteP 1 + } + + ]/0 { + return [set state(lastC) LX_DLITERAL] + } + + default { + set quoteP 0 + } + } + + if {[set c [string index $state(input) 0]] eq {}} { + set state(buffer) "end-of-input during domain-literal" + return [set state(lastC) LX_ERR] + } + set state(input) [string range $state(input) 1 end] + } + } + + if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { + append state(buffer) $c + + return [set state(lastC) [lindex $state(lexemeL) $x]] + } + + while {1} { + append state(buffer) $c + + switch -- [set c [string index $state(input) 0]] { + {} - " " - "\t" - "\n" { + break + } + + default { + if {[lsearch -exact $state(tokenL) $c] >= 0} { + break + } + } + } + + set state(input) [string range $state(input) 1 end] + } + + return [set state(lastC) LX_ATOM] +} + +# ::mime::mapencoding -- +# +# mime::mapencodings maps tcl encodings onto the proper names for their +# MIME charset type. This is only done for encodings whose charset types +# were known. The remaining encodings return {} for now. +# +# Arguments: +# enc The tcl encoding to map. +# +# Results: +# Returns the MIME charset type for the specified tcl encoding, or {} +# if none is known. + +proc ::mime::mapencoding {enc} { + + variable encodings + + if {[info exists encodings($enc)]} { + return $encodings($enc) + } + return {} +} + +# ::mime::reversemapencoding -- +# +# mime::reversemapencodings maps MIME charset types onto tcl encoding names. +# Those that are unknown return {}. +# +# Arguments: +# mimeType The MIME charset to convert into a tcl encoding type. +# +# Results: +# Returns the tcl encoding name for the specified mime charset, or {} +# if none is known. + +proc ::mime::reversemapencoding {mimeType} { + + variable reversemap + + set lmimeType [string tolower $mimeType] + if {[info exists reversemap($lmimeType)]} { + return $reversemap($lmimeType) + } + return {} +} + +# ::mime::word_encode -- +# +# Word encodes strings as per RFC 2047. +# +# Arguments: +# charset The character set to encode the message to. +# method The encoding method (base64 or quoted-printable). +# string The string to encode. +# ?-charset_encoded 0 or 1 Whether the data is already encoded +# in the specified charset (default 1) +# ?-maxlength maxlength The maximum length of each encoded +# word to return (default 66) +# +# Results: +# Returns a word encoded string. + +proc ::mime::word_encode {charset method string {args}} { + + variable encodings + + if {![info exists encodings($charset)]} { + error "unknown charset '$charset'" + } + + if {$encodings($charset) eq {}} { + error "invalid charset '$charset'" + } + + if {$method ne "base64" && $method ne "quoted-printable"} { + error "unknown method '$method', must be base64 or quoted-printable" + } + + # default to encoded and a length that won't make the Subject header to long + array set options [list -charset_encoded 1 -maxlength 66] + array set options $args + + if {$options(-charset_encoded)} { + set unencoded_string [::encoding convertfrom $charset $string] + } else { + set unencoded_string $string + } + + set string_length [string length $unencoded_string] + + if {!$string_length} { + return {} + } + + set string_bytelength [string bytelength $unencoded_string] + + # the 7 is for =?, ?Q?, ?= delimiters of the encoded word + set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}] + switch -exact -- $method { + base64 { + if {$maxlength < 4} { + error "maxlength $options(-maxlength) too short for chosen charset and encoding" + } + set count 0 + set maxlength [expr {($maxlength / 4) * 3}] + while {$count < $string_length} { + set length 0 + set enc_string {} + while {($length < $maxlength) && ($count < $string_length)} { + set char [string range $unencoded_string $count $count] + set enc_char [::encoding convertto $charset $char] + if {($length + [string length $enc_char]) > $maxlength} { + set length $maxlength + } else { + append enc_string $enc_char + incr count + incr length [string length $enc_char] + } + } + set encoded_word [string map [ + list \n {}] [base64 -mode encode -- $enc_string]] + append result "=?$encodings($charset)?B?$encoded_word?=\n " + } + # Trim off last "\n ", since the above code has the side-effect + # of adding an extra "\n " to the encoded string. + + set result [string range $result 0 end-2] + } + quoted-printable { + if {$maxlength < 1} { + error "maxlength $options(-maxlength) too short for chosen charset and encoding" + } + set count 0 + while {$count < $string_length} { + set length 0 + set encoded_word {} + while {($length < $maxlength) && ($count < $string_length)} { + set char [string range $unencoded_string $count $count] + set enc_char [::encoding convertto $charset $char] + set qp_enc_char [qp_encode $enc_char 1] + set qp_enc_char_length [string length $qp_enc_char] + if {$qp_enc_char_length > $maxlength} { + error "maxlength $options(-maxlength) too short for chosen charset and encoding" + } + if {($length + [ + string length $qp_enc_char]) > $maxlength} { + + set length $maxlength + } else { + append encoded_word $qp_enc_char + incr count + incr length [string length $qp_enc_char] + } + } + append result "=?$encodings($charset)?Q?$encoded_word?=\n " + } + # Trim off last "\n ", since the above code has the side-effect + # of adding an extra "\n " to the encoded string. + + set result [string range $result 0 end-2] + } + {} { + # Go ahead + } + default { + error "Can't handle content encoding \"$method\"" + } + } + return $result +} + +# ::mime::word_decode -- +# +# Word decodes strings that have been word encoded as per RFC 2047. +# +# Arguments: +# encoded The word encoded string to decode. +# +# Results: +# Returns the string that has been decoded from the encoded message. + +proc ::mime::word_decode {encoded} { + + variable reversemap + + if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \ + - charset method string] != 1} { + error "malformed word-encoded expression '$encoded'" + } + + set enc [reversemapencoding $charset] + if {$enc eq {}} { + error "unknown charset '$charset'" + } + + switch -exact -- $method { + b - + B { + set method base64 + } + q - + Q { + set method quoted-printable + } + default { + error "unknown method '$method', must be B or Q" + } + } + + switch -exact -- $method { + base64 { + set result [base64 -mode decode -- $string] + } + quoted-printable { + set result [qp_decode $string 1] + } + {} { + # Go ahead + } + default { + error "Can't handle content encoding \"$method\"" + } + } + + return [list $enc $method $result] +} + +# ::mime::field_decode -- +# +# Word decodes strings that have been word encoded as per RFC 2047 +# and converts the string from the original encoding/charset to UTF. +# +# Arguments: +# field The string to decode +# +# Results: +# Returns the decoded string in UTF. + +proc ::mime::field_decode {field} { + # ::mime::field_decode is broken. Here's a new version. + # This code is in the public domain. Don Libes <don@libes.com> + + # Step through a field for mime-encoded words, building a new + # version with unencoded equivalents. + + # Sorry about the grotesque regexp. Most of it is sensible. One + # notable fudge: the final $ is needed because of an apparent bug + # in the regexp engine where the preceding .* otherwise becomes + # non-greedy - perhaps because of the earlier ".*?", sigh. + + while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} { + # don't allow whitespace between encoded words per RFC 2047 + if {{} != $prefix} { + if {![string is space $prefix]} { + append result $prefix + } + } + + set decoded [word_decode $encoded] + foreach {charset - string} $decoded break + + append result [::encoding convertfrom $charset $string] + } + append result $field + return $result +} + +## One-Shot Initialization + +::apply {{} { + variable encList + variable encAliasList + variable reversemap + + foreach {enc mimeType} $encList { + if {$mimeType eq {}} continue + set reversemap([string tolower $mimeType]) $enc + } + + foreach {enc mimeType} $encAliasList { + set reversemap([string tolower $mimeType]) $enc + } + + # Drop the helper variables + unset encList encAliasList + +} ::mime} diff --git a/tcllib/modules/mime/mime.test b/tcllib/modules/mime/mime.test new file mode 100755 index 0000000..71e84d2 --- /dev/null +++ b/tcllib/modules/mime/mime.test @@ -0,0 +1,609 @@ +# mime.test - Test suite for TclMIME -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2000 by Ajuba Solutions +# All rights reserved. +# +# RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 1.0 + +support { + # This code loads md5x, i.e. md5 v2. Proper testing should do one + # run using md5 v1, aka md5.tcl as well. + use md5/md5x.tcl md5 +} +testing { + useLocal mime.tcl mime +} + +# ------------------------------------------------------------------------- + +namespace import mime::* + +# ------------------------------------------------------------------------- + +test mime-1.1 {initialize with no args} { + catch {initialize} res + subst $res +} {specify exactly one of -file, -parts, or -string} + +test mime-2.1 {Generate a MIME message} { + set tok [initialize -canonical "Text/plain" -string "jack and jill"] + set msg [mime::buildmessage $tok] + # The generated message is predictable except for the Content-ID + regexp "MIME-Version: 1.0\r +Content-ID: \[^\n]+\r +Content-Type: text/plain\r +\r +jack and jill" $msg +} 1 + +test mime-2.2 {Generate a multi-part MIME message} { + set tok1 [initialize -canonical "Text/plain" -string "jack and jill"] + set tok2 [initialize -canonical "Text/plain" -string "james"] + set bigTok [mime::initialize -canonical Multipart/MyType \ + -param [list MyParam foo] \ + -param [list boundary bndry] \ + -header [list Content-Description "Test Multipart"] \ + -parts [list $tok1 $tok2]] + set msg [mime::buildmessage $bigTok] + # The generated message is predictable except for the Content-ID + list [regexp "MIME-Version: 1.0\r +Content-Description: Test Multipart\r +Content-ID: \[^\n]+\r +Content-Type: multipart/mytype;\r + \[^\n]+;\r + \[^\n]+\r +\r +--bndry\r +MIME-Version: 1.0\r +Content-ID: \[^\n]+\r +Content-Type: text/plain\r +\r +jack and jill\r +--bndry\r +MIME-Version: 1.0\r +Content-ID: \[^\n]+\r +Content-Type: text/plain\r +\r +james\r +--bndry--\r +" $msg] [regexp "boundary=\"bndry\"" $msg] [regexp "myparam=\"foo\"" $msg] +} {1 1 1} + +test mime-3.1 {Parse a MIME message} { + set msg {MIME-Version: 1.0 +Content-Type: Text/plain + +I'm the message.} + set tok [mime::initialize -string $msg] + mime::getbody $tok +} "I'm the message." + +test mime-3.2 {Parse a multi-part MIME message} { + set msg {MIME-Version: 1.0 +Content-Type: Multipart/foo; boundary="bar" + +--bar +MIME-Version: 1.0 +Content-Type: Text/plain + +part1 +--bar +MIME-Version: 1.0 +Content-Type: Text/plain + +part2 +--bar +MIME-Version: 1.0 +Content-Type: Text/plain + +part3 +--bar-- +} + + set tok [mime::initialize -string $msg] + set partToks [mime::getproperty $tok parts] + + set res "" + foreach childTok $partToks { + lappend res [mime::getbody $childTok] + } + set res +} {part1 part2 part3} + +test mime-3.3 {Try to parse a totally invalid message} { + catch {mime::initialize -string "blah"} err0 + set err0 +} {improper line in header: blah} + +test mime-3.4 {Try to parse a MIME message with an invalid version} { + set msg1 {MIME-Version: 2.0 +Content-Type: text/plain + +msg1} + + set tok [mime::initialize -string $msg1] + catch {mime::getbody $tok} err1 + catch {mime::buildmessage $tok} err1a + list $err1 $err1a +} "msg1 {MIME-Version: 2.0\r +Content-Type: text/plain\r +\r +msg1}" + +test mime-3.5 {Try to parse a MIME message with no newline between headers and data} { + set msg2 {MIME-Version: 1.0 +Content-Type: foobar +data without newline} + + catch {mime::initialize -string $msg2} err2 + set err2 +} {improper line in header: data without newline} + +test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} { + + # No MIME version + set msg3 {Content-Type: text/plain + +foo} + + set tok [mime::initialize -string $msg3] + catch {mime::getbody $tok} err3 + catch {mime::buildmessage $tok} err3a + list $err3 $err3a +} "foo {MIME-Version: 1.0\r +Content-Type: text/plain\r +\r +foo}" + +test mime-3.7 {Test mime with a bad email [SF Bug 631314 ]} { + set tok [mime::initialize -file \ + [file join $tcltest::testsDirectory badmail1.txt]] + + set res {} + set ctok [lindex [mime::getproperty $tok parts] 0] + lappend res [dictsort [mime::getproperty $tok]] + lappend res [dictsort [mime::getproperty $ctok]] + mime::finalize $tok + string map [list $ctok CHILD] $res +} {{content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {charset us-ascii} size 0}} + +test mime-3.8 {Test mime with another bad email [SF Bug 631314 ]} { + set tok [mime::initialize -file \ + [file join $tcltest::testsDirectory badmail2.txt]] + set res {} + set ctok [lindex [mime::getproperty $tok parts] 0] + lappend res [dictsort [mime::getproperty $tok]] + lappend res [dictsort [mime::getproperty $ctok]] + mime::finalize $tok + string map [list $ctok CHILD] $res +} {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 659} {content application/octet-stream encoding base64 params {} size 659}} + +test mime-3.9 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back} { + set msg {MIME-Version: 1.0 +Content-Type: text/plain; charset=ISO-8859-1 + +Fran\xE7ois +} + set tok [mime::initialize -string $msg] + mime::getbody $tok -decode +} {Fran\xE7ois +} + +test mime-3.10 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back (example from encoding man page)} { + set msg {MIME-Version: 1.0 +Content-Type: text/plain; charset=EUC-JP +Content-Transfer-Encoding: quoted-printable + +=A4=CF} + set tok [mime::initialize -string $msg] + mime::getbody $tok -decode +} "\u306F" + +test mime-3.11 {Parse a MIME message without a charset encoded body and use getbody -decode to get it back} { + set msg {MIME-Version: 1.0 +Content-Type: text/plain +Content-Transfer-Encoding: quoted-printable + +A plain text message.} + set tok [mime::initialize -string $msg] + mime::getbody $tok -decode +} "A plain text message." + +test mime-3.12 {Parse a MIME message with a charset encoded body in an unrecognised charset and use getbody -decode to attempt to get it back} { + set msg {MIME-Version: 1.0 +Content-Type: text/plain; charset=SCRIBBLE +Content-Transfer-Encoding: quoted-printable + +This is a message in the scribble charset that tcl does not recognise.} + set tok [mime::initialize -string $msg] + catch {mime::getbody $tok -decode} errmsg + set errmsg +} "-decode failed: can't reversemap charset SCRIBBLE" + +test mime-3.13 {Parse a MIME message with a charset encoded body in an unrecognised charset but don't use -decode so we get it back raw} { + set msg {MIME-Version: 1.0 +Content-Type: text/plain; charset=SCRIBBLE +Content-Transfer-Encoding: quoted-printable + +This is a message in the scribble charset that tcl does not recognise.} + set tok [mime::initialize -string $msg] + mime::getbody $tok +} "This is a message in the scribble charset that tcl does not recognise." + +test mime-4.1 {Test qp_encode with a > 76 character string containing special chars.} { + set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\"" + mime::qp_encode $str1 +} "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22" + +test mime-4.2 {Check that encode/decode yields original string} { + set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\" " + set enc [mime::qp_encode $str1] + set dec [mime::qp_decode $enc] + string equal $dec $str1 +} {1} + +test mime-4.3 {mime::decode data that might come from an MUA} { + set enc "I'm the =22 message =\nwith some new lines= \n but with some extra space, too. " + mime::qp_decode $enc +} "I'm the \" message with some new lines but with some extra space, too." + +test mime-4.4 {Test qp_encode with non-US_ASCCI characters.} { + set str1 "Test de caractères accentués : â î é ç et quelques contrôles \"\[|\]()\"" + mime::qp_encode $str1 +} "Test de caract=E8res accentu=E9s : =E2 =EE =E9 =E7 et quelques contr=F4le=\ns =22=5B=7C=5D()=22" + + +test mime-4.5 {Test qp_encode with softbreak} { + set str1 [string repeat abc 40] + mime::qp_encode $str1 +} "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabca= +bcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" + +test mime-4.6 {Test qp_encode with softbreak} { + set str1 [string repeat abc 40] + mime::qp_encode $str1 0 1 +} [string repeat abc 40] + + + + +test mime-5.1 {Test word_encode with quoted-printable method} { + mime::word_encode iso8859-1 quoted-printable "Test de contrôle effectué" +} "=?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?=" + +test mime-5.2 {Test word_encode with base64 method} { + mime::word_encode iso8859-1 base64 "Test de contrôle effectué" +} "=?ISO-8859-1?B?VGVzdCBkZSBjb250cvRsZSBlZmZlY3R16Q==?=" + +test mime-5.3 {Test encode+decode with quoted-printable method} { + set enc [mime::word_encode iso8859-1 quoted-printable "Test de contrôle effectué"] + mime::word_decode $enc +} {iso8859-1 quoted-printable {Test de contrôle effectué}} + +test mime-5.4 {Test encode+decode with base64 method} { + set enc [mime::word_encode iso8859-1 base64 "Test de contrôle effectué"] + mime::word_decode $enc +} {iso8859-1 base64 {Test de contrôle effectué}} + +test mime-5.5 {Test decode with lowercase quoted-printable method} { + mime::word_decode "=?ISO-8859-1?q?Test_lowercase_q?=" +} {iso8859-1 quoted-printable {Test lowercase q}} + +test mime-5.6 {Test decode with lowercase base64 method} { + mime::word_decode "=?ISO-8859-1?b?VGVzdCBsb3dlcmNhc2UgYg==?=" +} {iso8859-1 base64 {Test lowercase b}} + +test mime-5.7 {Test word_encode with quoted-printable method across encoded word boundaries} { + mime::word_encode iso8859-1 quoted-printable "Test de contrôle effectué" -maxlength 31 +} "=?ISO-8859-1?Q?Test_de_contr?= + =?ISO-8859-1?Q?=F4le_effectu?= + =?ISO-8859-1?Q?=E9?=" + +test mime-5.8 {Test word_encode with quoted-printable method across encoded word boundaries} { + mime::word_encode iso8859-1 quoted-printable "Test de contrôle effectué" -maxlength 32 +} "=?ISO-8859-1?Q?Test_de_contr?= + =?ISO-8859-1?Q?=F4le_effectu?= + =?ISO-8859-1?Q?=E9?=" + +test mime-5.9 {Test word_encode with quoted-printable method and multibyte character} { + mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" +} "=?EUC-JP?Q?Following_me_is_a_multibyte_character_=A4=CF?=" + +set n 10 +while {$n < 14} { + test mime-5.$n {Test word_encode with quoted-printable method and multibyte character across encoded word boundary} { + mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" -maxlength [expr 42 + $n] + } "=?EUC-JP?Q?Following_me_is_a_multibyte_character_?= + =?EUC-JP?Q?=A4=CF?=" + incr n +} + +test mime-5.14 {Test word_encode with quoted-printable method and multibyte character (triple)} { + mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" +} "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?=" + +set n 15 +while {$n < 23} { + test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} { + mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n] + } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_?= + =?UTF-8?Q?=E3=81=AF?=" + incr n +} + +while {$n < 25} { + test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} { + mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n] + } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?=" + incr n +} + +while {$n < 29} { + test mime-5.$n {Test word_encode with base64 method across encoded word boundaries} { + mime::word_encode euc-jp base64 "There is a multibyte character \xA4\xCF" -maxlength [expr 28 + $n] + } "=?EUC-JP?B?VGhlcmUgaXMgYSBtdWx0aWJ5dGUgY2hhcmFjdGVy?= + =?EUC-JP?B?IKTP?=" + incr n +} + +while {$n < 33} { + test mime-5.$n {Test word_encode with base64 method and triple byte character across encoded word boundary} { + mime::word_encode utf-8 base64 "Here is a multibyte character \xE3\x81\xAF" -maxlength [expr 23 + $n] + } "=?UTF-8?B?SGVyZSBpcyBhIG11bHRpYnl0ZSBjaGFyYWN0ZXIg?= + =?UTF-8?B?44Gv?=" + incr n +} + +test mime-5.33 {Test word_encode with quoted-printable method and -maxlength set to same length as will the result} { + mime::word_encode iso8859-1 quoted-printable "123" -maxlength 20 +} "=?ISO-8859-1?Q?123?=" + +test mime-5.34 {Test word_encode with base64 method and -maxlength set to same length as will the result} { + mime::word_encode iso8859-1 base64 "123" -maxlength 21 +} "=?ISO-8859-1?B?MTIz?=" + +test mime-5.35 {Test word_encode with quoted-printable method and non charset encoded string} { + mime::word_encode utf-8 quoted-printable "\u306F" -charset_encoded 0 +} "=?UTF-8?Q?=E3=81=AF?=" + +test mime-5.36 {Test word_encode with base64 method and non charset encoded string} { + mime::word_encode utf-8 base64 "\u306F" -charset_encoded 0 +} "=?UTF-8?B?44Gv?=" + +test mime-5.36 {Test word_encode with base64 method and one byte} { + mime::word_encode iso8859-1 base64 "a" +} "=?ISO-8859-1?B?YQ==?=" + +test mime-5.37 {Test word_encode with base64 method and two bytes} { + mime::word_encode euc-jp base64 "\xA4\xCF" +} "=?EUC-JP?B?pM8=?=" + +test mime-5.38 {Test word_encode with unknown charset} { + catch {mime::word_encode scribble quoted-printable "scribble is an unknown charset"} errmsg + set errmsg +} "unknown charset 'scribble'" + +test mime-5.39 {Test word_encode with invalid charset} { + catch {mime::word_encode unicode quoted-printable "unicode is not a valid charset"} errmsg + set errmsg +} "invalid charset 'unicode'" + +test mime-5.40 {Test word_encode with invalid method} { + catch {mime::word_encode iso8859-1 tea-leaf "tea-leaf is not a valid method"} errmsg + set errmsg +} "unknown method 'tea-leaf', must be base64 or quoted-printable" + +test mime-5.41 {Test word_encode with maxlength to short for method quoted-printable} { + catch {mime::word_encode iso8859-1 quoted-printable "1" -maxlength 17} errmsg + set errmsg +} "maxlength 17 too short for chosen charset and encoding" + +test mime-5.42 {Test word_encode with maxlength on the limit for quoted_printable and an unquoted character} { + catch {mime::word_encode iso8859-1 quoted-printable "_" -maxlength 18} errmsg + set errmsg +} "=?ISO-8859-1?Q?_?=" + +test mime-5.43 {Test word_encode with maxlength to short for method quoted_printable and a character to be quoted} { + catch {mime::word_encode iso8859-1 quoted-printable "=" -maxlength 18} errmsg + set errmsg +} "maxlength 18 too short for chosen charset and encoding" + + +test mime-5.44 {Test word_encode with maxlength to short for method quoted-printable and multibyte character} { + catch {mime::word_encode euc-jp quoted-printable "\xA4\xCF" -maxlength 17} errmsg + set errmsg +} "maxlength 17 too short for chosen charset and encoding" + +test mime-5.45 {Test word_encode with maxlength to short for method base64} { + catch {mime::word_encode iso8859-1 base64 "1" -maxlength 20} errmsg + set errmsg +} "maxlength 20 too short for chosen charset and encoding" + +test mime-6.1 {Test field_decode (from RFC 2047, part 8)} { + mime::field_decode {=?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>} +} {Keith Moore <moore@cs.utk.edu>} + +test mime-6.2 {Test field_decode (from RFC 2047, part 8)} { + mime::field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <paf@nada.kth.se>} +} {Patrik Fältström <paf@nada.kth.se>} + +test mime-6.3 {Test field_decode (from RFC 2047, part 8)} { + mime::field_decode {=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= + =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=} +} {If you can read this you understand the example.} + +foreach {n encoded expected} { + 4 "(=?ISO-8859-1?Q?a?=)" + "(a)" + 5 "(=?ISO-8859-1?Q?a?= b)" + "(a b)" + 6 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" + "(ab)" + 7 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" + "(ab)" + 8 "(=?ISO-8859-1?Q?a?= + =?ISO-8859-1?Q?b?=)" + "(ab)" + 9 "(=?ISO-8859-1?Q?a_b?=)" + "(a b)" + 10 "(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)" + "(a b)" + 11 "(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)" + "(ax b)" + 12 "a b c" + "a b c" + 13 "" + "" +} { + test mime-6.$n {Test field_decode (from RFC 2047, part 8)} { + mime::field_decode $encoded + } $expected ; # {} +} + +foreach {bug n encoded expected} { + 764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(Hürz)" +} { + test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" { + mime::field_decode $encoded + } $expected ; # {} +} + +test mime-8.1 {Test reversemapencoding+mapencoding with preferred name} { + set charset [mime::reversemapencoding "US-ASCII"] + mime::mapencoding $charset +} {US-ASCII} + +test mime-8.2 {Test reversemapencoding+mapencoding with alias} { + set charset [mime::reversemapencoding "UTF8"] + mime::mapencoding $charset +} {UTF-8} + + +test mime-9.0 {Test chunk handling of copymessage and helpers} { + set in [makeFile [set data [string repeat [string repeat "123456789 " 10]\n 350]] input.txt] + set mi [makeFile {} mime.txt] + + set token [mime::initialize -canonical text/plain -file $in] + + set f [open $mi w] + fconfigure $f -translation binary + mime::copymessage $token $f + close $f + + set token [mime::initialize -file $mi] + set newdata [mime::getbody $token] + set res [string compare $data $newdata] + + removeFile input.txt + removeFile mime.txt + unset data newdata token f in mi + set res +} 0 + +set ::env(TZ) "UTC0" +set epoch [clock scan 2000-01-01] +foreach {n stamp date} { + 1 86340 {Sat, 01 Jan 2000 23:59:00 +0000} + 2 5176620 {Tue, 29 Feb 2000 21:57:00 +0000} + 3 31610520 {Sun, 31 Dec 2000 20:42:00 +0000} + 4 31708740 {Mon, 01 Jan 2001 23:59:00 +0000} + 5 68248620 {Thu, 28 Feb 2002 21:57:00 +0000} + 6 126218520 {Wed, 31 Dec 2003 20:42:00 +0000} +} { + test mime-10.$n "Test formatting dates (RFC 822)" { + # To verify that clock scan gets the expected value. + set stamp_test [expr {[mime::parsedatetime $date clock] - $epoch}] + # Parse and re-format should get us the original. + set parsed_test [mime::parsedatetime $date proper] + list $stamp_test $parsed_test + } [list $stamp $date] +} + + +test mime-11.0 {Bug 1825092} { + set in [makeFile {From sw@fooooooooo.de Sat Oct 20 17:58:49 2007 +Return-Path: <sw@fooooooooo.de> +Message-ID: <17849372.3849122@fooooooooo.de> +From: Somwhere <sw@fooooooooo.de> +MIME-Version: 1.0 +To: Here <h@fooooooooo.de> +Subject: test +Content-Type: multipart/mixed; + boundary="------------090305080603000703000106" + +This is a multi-part message in MIME format. +--------------090305080603000703000106 +Content-Type: text/plain; charset=ISO-8859-15 +Content-Transfer-Encoding: 8bit + +XXX + +--------------090305080603000703000106 +Content-Disposition: attachment; + filename="a0036.dss" +Content-Transfer-Encoding: base64 +Content-Type: application/octet-stream; + name="a0036.dss" + +BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2 +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ +--------------090305080603000703000106-- +} mail_part] + set token [mime::initialize -file $in] + set allparts [mime::getproperty $token parts] + set attachment [lindex $allparts 1] + + set out [makeFile {} mail_att] + set ofh [open $out w] + fconfigure $ofh -translation binary + mime::copymessage $attachment $ofh + close $ofh + + set data [viewFile $out] + file delete $in $out + set data +} {MIME-Version: 1.0 +Content-Disposition: attachment; + filename="a0036.dss" +Content-Transfer-Encoding: base64 +Content-Type: application/octet-stream; + name="a0036.dss" + +BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2
+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ} + +# ------------------------------------------------------------------------- + +test mime-12.0 {Bug 3483716} { + set token [mime::initialize -string {Content-Type: message/delivery-status; name="deliverystatus.txt" +Content-Disposition: attachment; filename="deliverystatus.txt"; size=138; +creation-date="Thu, 02 Feb 2012 13:50:05 GMT"; +modification-date="Thu, 02 Feb 2012 13:50:05 GMT" +Content-Description: deliverystatus.txt +Content-Transfer-Encoding: base64 + +T3JpZ2luYWwtUmVjaXBpZW50OiA8L2ZheD1ibHViYkBndW1taS5ib290PgpBY3Rpb246IGZhaWxl +ZApEaWFnbm9zdGljLUNvZGU6IHNtdHA7IDU1MCAjNS4xLjAgQWRkcmVzcyByZWplY3RlZC4KUmVt +b3RlLU1UQTogNTMuMjQuMjgyLjE1MA== +}] + set parts [mime::getproperty $token parts] + mime::getheader [lindex $parts end] Remote-MTA +} 53.24.282.150 + +# ------------------------------------------------------------------------- + +testsuiteCleanup +return diff --git a/tcllib/modules/mime/pkgIndex.tcl b/tcllib/modules/mime/pkgIndex.tcl new file mode 100644 index 0000000..973efdc --- /dev/null +++ b/tcllib/modules/mime/pkgIndex.tcl @@ -0,0 +1,4 @@ +if {![package vsatisfies [package provide Tcl] 8.3]} {return} +package ifneeded smtp 1.4.5 [list source [file join $dir smtp.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5]} {return} +package ifneeded mime 1.6 [list source [file join $dir mime.tcl]] diff --git a/tcllib/modules/mime/rfc2629.dtd b/tcllib/modules/mime/rfc2629.dtd new file mode 100644 index 0000000..9ae39b3 --- /dev/null +++ b/tcllib/modules/mime/rfc2629.dtd @@ -0,0 +1,209 @@ +<!-- + DTD for the RFC document series, draft of 99-01-30 + --> + + +<!-- + Contents + + DTD data types + + The top-level + + Front matter + + The Body + + Back matter + --> + + +<!-- + DTD data types: + + entity description + ====== =============================================== + NUMBER [0-9]+ + NUMBERS a comma-separated list of NUMBER + + DAY the day of the month, e.g., "1" + MONTH the month of the year, e.g., "January" + YEAR a four-digit year, e.g., "1999" + + URI e.g., "http://invisible.net/" + + ATEXT/CTEXT printable ASCII text (no line-terminators) + + TEXT character data + --> + + +<!ENTITY % NUMBER "CDATA"> +<!ENTITY % NUMBERS "CDATA"> + +<!ENTITY % DAY "CDATA"> +<!ENTITY % MONTH "CDATA"> +<!ENTITY % YEAR "CDATA"> + +<!ENTITY % URI "CDATA"> + +<!ENTITY % ATEXT "CDATA"> +<!ENTITY % CTEXT "#PCDATA"> + +<!ENTITY % TEXT "#PCDATA"> + +<!ENTITY rfc.number "XXXX"> + + +<!-- + The top-level + --> + + +<!-- + attributes for the "rfc" element are supplied by the RFC + editor. when preparing drafts, authors should leave them blank. + + the "seriesNo" attribute is used if the category is, e.g., BCP. + --> +<!ELEMENT rfc (front,middle,back?)> +<!ATTLIST rfc + number %NUMBER; #IMPLIED + obsoletes %NUMBERS; "" + updates %NUMBERS; "" + category (std|bcp|info|exp|historic) + "info" + seriesNo %NUMBER; #IMPLIED + ipr (full2026|noDerivativeWorks2026|none) + #IMPLIED + docName %ATEXT; #IMPLIED> + +<!-- + Front matter + --> + + +<!ELEMENT front (title,author+,date,area*,workgroup*,keyword*, + abstract?,note*)> + +<!-- the "abbrev" attribute is used for headers, etc. --> +<!ELEMENT title (%CTEXT;)> +<!ATTLIST title + abbrev %ATEXT; #IMPLIED> + +<!ELEMENT author (organization,address?)> +<!ATTLIST author + initials %ATEXT; #IMPLIED + surname %ATEXT; #IMPLIED + fullname %ATEXT; #IMPLIED> + +<!ELEMENT organization + (%CTEXT;)> +<!ATTLIST organization + abbrev %ATEXT; #IMPLIED> + +<!ELEMENT address (postal?,phone?,facsimile?,email?,uri?)> + +<!-- at most one of each the city, region, code, and country + elements may be present --> +<!ELEMENT postal (street+,(city|region|code|country)*)> +<!ELEMENT street (%CTEXT;)> +<!ELEMENT city (%CTEXT;)> +<!ELEMENT region (%CTEXT;)> +<!ELEMENT code (%CTEXT;)> +<!ELEMENT country (%CTEXT;)> +<!ELEMENT phone (%CTEXT;)> +<!ELEMENT facsimile (%CTEXT;)> +<!ELEMENT email (%CTEXT;)> +<!ELEMENT uri (%CTEXT;)> + +<!ELEMENT date EMPTY> +<!ATTLIST date + day %DAY; #IMPLIED + month %MONTH; #REQUIRED + year %YEAR; #REQUIRED> + +<!-- meta-data... --> +<!ELEMENT area (%CTEXT;)> +<!ELEMENT workgroup (%CTEXT;)> +<!ELEMENT keyword (%CTEXT;)> + +<!ELEMENT abstract (t)+> +<!ELEMENT note (t)+> +<!ATTLIST note + title %ATEXT; #REQUIRED> + + +<!-- + The body + --> + + +<!ELEMENT middle (section)+> + +<!ELEMENT section (t|figure|section)*> +<!ATTLIST section + anchor ID #IMPLIED + title %ATEXT; #REQUIRED> + +<!ELEMENT t (%TEXT;|list|figure|xref|eref|iref|vspace)*> +<!ATTLIST t + hangText %ATEXT; #IMPLIED> + +<!-- the value of the style attribute is inherited from the closest + parent --> +<!ELEMENT list (t+)> +<!ATTLIST list + style (numbers|symbols|hanging|empty) + "empty"> + +<!ELEMENT xref (%CTEXT;)> +<!ATTLIST xref + target IDREF #REQUIRED + pageno (true|false) "false"> + +<!ELEMENT eref (%CTEXT;)> +<!ATTLIST eref + target %URI; #REQUIRED> + +<!ELEMENT iref EMPTY> +<!ATTLIST iref + item %ATEXT; #REQUIRED + subitem %ATEXT; ""> + +<!ELEMENT vspace EMPTY> +<!ATTLIST vspace + blankLines %NUMBER; "0"> + +<!ELEMENT figure (preamble?,artwork,postamble?)> +<!ATTLIST figure + anchor ID #IMPLIED + title %ATEXT; ""> + +<!ELEMENT preamble (%TEXT;|xref|eref|iref)*> +<!ELEMENT artwork (%TEXT;)*> +<!ATTLIST artwork + xml:space (default|preserve) "preserve" + name %ATEXT; "" + type %ATEXT; ""> + +<!ELEMENT postamble (%TEXT;|xref|eref|iref)*> + + +<!-- + Back matter + --> + + +<!-- sections, if present, are appendices --> +<!ELEMENT back (references?,section*)> + +<!ELEMENT references (reference+)> +<!ELEMENT reference (front,seriesInfo*)> +<!ATTLIST reference + anchor ID #IMPLIED + target %URI; #IMPLIED> +<!ELEMENT seriesInfo EMPTY> +<!ATTLIST seriesInfo + name %ATEXT; #REQUIRED + value %ATEXT; #REQUIRED> diff --git a/tcllib/modules/mime/smtp.man b/tcllib/modules/mime/smtp.man new file mode 100644 index 0000000..4e5a00b --- /dev/null +++ b/tcllib/modules/mime/smtp.man @@ -0,0 +1,190 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin smtp n 1.4.5] +[see_also ftp] +[see_also http] +[see_also mime] +[see_also pop3] +[copyright {1999-2000 Marshall T. Rose and others}] +[moddesc {smtp client}] +[titledesc {Client-side tcl implementation of the smtp protocol}] +[category Networking] +[require Tcl] +[require mime [opt 1.5.4]] +[require smtp [opt 1.4.5]] +[description] +[para] + +The [package smtp] library package provides the client side of the +Simple Mail Transfer Protocol (SMTP) (1) (2). + +[list_begin definitions] + +[call [cmd ::smtp::sendmessage] [arg token] [arg option]...] + +This command sends the MIME part (see package [package mime]) +represented by [arg token] to an SMTP server. [arg options] is a list +of options and their associated values. The recognized options are: + +[list_begin definitions] + +[def [option -servers]] + +A list of SMTP servers. The default is [const localhost]. + +[def [option -ports]] + +A list of SMTP ports. The default is [const 25]. + +[def [option -client]] + +The name to use as our hostname when connecting to the server. By +default this is either localhost if one of the servers is localhost, +or is set to the string returned by [cmd "info hostname"]. + +[def [option -queue]] + +Indicates that the SMTP server should be asked to queue the message +for later processing. A boolean value. + +[def [option -atleastone]] + +Indicates that the SMTP server must find at least one recipient +acceptable for the message to be sent. A boolean value. + +[def [option -originator]] + +A string containing an 822-style address specification. If present the +header isn't examined for an originator address. + +[def [option -recipients]] + +A string containing one or more 822-style address specifications. If +present the header isn't examined for recipient addresses). If the +string contains more than one address they will be separated by +commas. + +[def [option -header]] + +A list containing two elements, an smtp header and its associated +value (the -header option may occur zero or more times). + +[def [option -usetls]] + +This package supports the RFC 3207 TLS extension (3) by default provided the +tls package is available. You can turn this off with this boolean option. + +[def [option -tlspolicy]] + +This option lets you specify a command to be called if an error occurs +during TLS setup. The command is called with the SMTP code and diagnostic +message appended. The command should return 'secure' or 'insecure' where +insecure will cause the package to continue on the unencrypted channel. +Returning 'secure' will cause the socket to be closed and the next server +in the [option -servers] list to be tried. + +[def [option -username]] +[def [option -password]] + +If your SMTP server requires authentication (RFC 2554 (4)) before +accepting mail you can use [option -username] and [option -password] +to provide your authentication details to the server. Currently this +package supports DIGEST-MD5, CRAM-MD5, LOGIN and PLAIN authentication +methods. The most secure method will be tried first and each method +tried in turn until we are either authorized or we run out of +methods. Note that if the server permits a TLS connection, then the +authorization will occur after we begin using the secure channel. + +[para] +Please also read the section on [sectref Authentication], it details +the necessary prequisites, i.e. packages needed to support these +options and authentication. + +[list_end] +[para] + +If the [option -originator] option is not present, the originator +address is taken from [const From] (or [const Resent-From]); +similarly, if the [option -recipients] option is not present, +recipient addresses are taken from [const To], [const cc], and +[const Bcc] (or [const Resent-To], and so on). Note that the header +key/values supplied by the [option -header] option (not those present +in the MIME part) are consulted. Regardless, header key/values are +added to the outgoing message as necessary to ensure that a valid +822-style message is sent. + +[para] + +The command returns a list indicating which recipients were +unacceptable to the SMTP server. Each element of the list is another +list, containing the address, an SMTP error code, and a textual +diagnostic. Depending on the [option -atleastone] option and the +intended recipients, a non-empty list may still indicate that the +message was accepted by the server. + +[list_end] + +[section Authentication] + +Beware. SMTP authentication uses [package SASL]. I.e. if the user +has to authenticate a connection, i.e. use the options [option -user] +and [option -password] (see above) it is necessary to have the +[package sasl] package available so that [package smtp] can load it. + +[para] + +This is a soft dependency because not everybody requires authentication, +and [package sasl] depends on a lot of the cryptographic (secure) hashes, +i.e. all of [package md5], [package otp], [package md4], [package sha1], +and [package ripemd160]. + +[section EXAMPLE] + +[example { +proc send_simple_message {recipient email_server subject body} { + package require smtp + package require mime + + set token [mime::initialize -canonical text/plain \\ + -string $body] + mime::setheader $token Subject $subject + smtp::sendmessage $token \\ + -recipients $recipient -servers $email_server + mime::finalize $token +} + +send_simple_message someone@somewhere.com localhost \\ + "This is the subject." "This is the message." +}] + +[include ../common-text/tls-security-notes.inc] + +[section {REFERENCES}] + +[list_begin enumerated] + +[enum] + Jonathan B. Postel, "SIMPLE MAIL TRANSFER PROTOCOL", RFC 821, August 1982. + ([uri http://www.rfc-editor.org/rfc/rfc821.txt]) + +[enum] + J. Klensin, "Simple Mail Transfer Protocol", RFC 2821, April 2001. + ([uri http://www.rfc-editor.org/rfc/rfc2821.txt]) + +[enum] + P. Hoffman, "SMTP Service Extension for Secure SMTP over Transport + Layer Security", RFC 3207, February 2002. + ([uri http://www.rfc-editor.org/rfc/rfc3207.txt]) + +[enum] + J. Myers, "SMTP Service Extension for Authentication", + RFC 2554, March 1999. + ([uri http://www.rfc-editor.org/rfc/rfc2554.txt]) + +[list_end] + +[vset CATEGORY smtp] +[include ../doctools2base/include/feedback.inc] + +[keywords mail mail email smtp mime tls \ + {rfc 821} {rfc 822} {rfc 2821} {rfc 3207} {rfc 2554} internet net] +[manpage_end] diff --git a/tcllib/modules/mime/smtp.tcl b/tcllib/modules/mime/smtp.tcl new file mode 100644 index 0000000..9e160e1 --- /dev/null +++ b/tcllib/modules/mime/smtp.tcl @@ -0,0 +1,1508 @@ +# smtp.tcl - SMTP client +# +# Copyright (c) 1999-2000 Marshall T. Rose +# Copyright (c) 2003-2006 Pat Thoyts +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +package require Tcl 8.3 +package require mime 1.4.1 + +catch { + package require SASL 1.0; # tcllib 1.8 + package require SASL::NTLM 1.0; # tcllib 1.8 +} + +# +# state variables: +# +# sd: socket to server +# afterID: afterID associated with ::smtp::timer +# options: array of user-supplied options +# readable: semaphore for vwait +# addrs: number of recipients negotiated +# error: error during read +# line: response read from server +# crP: just put a \r in the data +# nlP: just put a \n in the data +# size: number of octets sent in DATA +# + +namespace eval ::smtp { + variable trf 1 + variable smtp + array set smtp { uid 0 } + + namespace export sendmessage +} + +if {[catch {package require Trf 2.0}]} { + # Trf is not available, but we can live without it as long as the + # transform and unstack procs are defined. + + # Warning! + # This is a fragile emulation of the more general calling sequence + # that appears to work with this code here. + + proc transform {args} { + upvar state mystate + set mystate(size) 1 + } + proc unstack {channel} { + # do nothing + return + } + set ::smtp::trf 0 +} + + +# ::smtp::sendmessage -- +# +# Sends a mime object (containing a message) to some recipients +# +# Arguments: +# part The MIME object containing the message to send +# args A list of arguments specifying various options for sending the +# message: +# -atleastone A boolean specifying whether or not to send the +# message at all if any of the recipients are +# invalid. A value of false (as defined by +# ::smtp::boolean) means that ALL recipients must be +# valid in order to send the message. A value of +# true means that as long as at least one recipient +# is valid, the message will be sent. +# -debug A boolean specifying whether or not debugging is +# on. If debugging is enabled, status messages are +# printed to stderr while trying to send mail. +# -queue A boolean specifying whether or not the message +# being sent should be queued for later delivery. +# -header A single RFC 822 header key and value (as a list), +# used to specify to whom to send the message +# (To, Cc, Bcc), the "From", etc. +# -originator The originator of the message (equivalent to +# specifying a From header). +# -recipients A string containing recipient e-mail addresses. +# NOTE: This option overrides any recipient addresses +# specified with -header. +# -servers A list of mail servers that could process the +# request. +# -ports A list of SMTP ports to use for each SMTP server +# specified +# -client The string to use as our host name for EHLO or HELO +# This defaults to 'localhost' or [info hostname] +# -maxsecs Maximum number of seconds to allow the SMTP server +# to accept the message. If not specified, the default +# is 120 seconds. +# -usetls A boolean flag. If the server supports it and we +# have the package, use TLS to secure the connection. +# -tlspolicy A command to call if the TLS negotiation fails for +# some reason. Return 'insecure' to continue with +# normal SMTP or 'secure' to close the connection and +# try another server. +# -username These are needed if your SMTP server requires +# -password authentication. +# +# Results: +# Message is sent. On success, return "". On failure, throw an +# exception with an error code and error message. + +proc ::smtp::sendmessage {part args} { + global errorCode errorInfo + + # Here are the meanings of the following boolean variables: + # aloP -- value of -atleastone option above. + # debugP -- value of -debug option above. + # origP -- 1 if -originator option was specified, 0 otherwise. + # queueP -- value of -queue option above. + + set aloP 0 + set debugP 0 + set origP 0 + set queueP 0 + set maxsecs 120 + set originator "" + set recipients "" + set servers [list localhost] + set client "" ;# default is set after options processing + set ports [list 25] + set tlsP 1 + set tlspolicy {} + set username {} + set password {} + + array set header "" + + # lowerL will contain the list of header keys (converted to lower case) + # specified with various -header options. mixedL is the mixed-case version + # of the list. + set lowerL "" + set mixedL "" + + # Parse options (args). + + if {[expr {[llength $args]%2}]} { + # Some option didn't get a value. + error "Each option must have a value! Invalid option list: $args" + } + + foreach {option value} $args { + switch -- $option { + -atleastone {set aloP [boolean $value]} + -debug {set debugP [boolean $value]} + -queue {set queueP [boolean $value]} + -usetls {set tlsP [boolean $value]} + -tlspolicy {set tlspolicy $value} + -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]} + -header { + if {[llength $value] != 2} { + error "-header expects a key and a value, not $value" + } + set mixed [lindex $value 0] + set lower [string tolower $mixed] + set disallowedHdrList \ + [list content-type \ + content-transfer-encoding \ + content-md5 \ + mime-version] + if {[lsearch -exact $disallowedHdrList $lower] > -1} { + error "Content-Type, Content-Transfer-Encoding,\ + Content-MD5, and MIME-Version cannot be user-specified." + } + if {[lsearch -exact $lowerL $lower] < 0} { + lappend lowerL $lower + lappend mixedL $mixed + } + + lappend header($lower) [lindex $value 1] + } + + -originator { + set originator $value + if {$originator == ""} { + set origP 1 + } + } + + -recipients { + set recipients $value + } + + -servers { + set servers $value + } + + -client { + set client $value + } + + -ports { + set ports $value + } + + -username { set username $value } + -password { set password $value } + + default { + error "unknown option $option" + } + } + } + + if {[lsearch -glob $lowerL resent-*] >= 0} { + set prefixL resent- + set prefixM Resent- + } else { + set prefixL "" + set prefixM "" + } + + # Set a bunch of variables whose value will be the real header to be used + # in the outbound message (with proper case and prefix). + + foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} { + set lower [string tolower $mixed] + # FRINK: nocheck + set ${lower}L $prefixL$lower + # FRINK: nocheck + set ${lower}M $prefixM$mixed + } + + if {$origP} { + # -originator was specified with "", so SMTP sender should be marked "". + set sender "" + } else { + # -originator was specified with a value, OR -originator wasn't + # specified at all. + + # If no -originator was provided, get the originator from the "From" + # header. If there was no "From" header get it from the username + # executing the script. + + set who "-originator" + if {$originator == ""} { + if {![info exists header($fromL)]} { + set originator $::tcl_platform(user) + } else { + set originator [join $header($fromL) ,] + + # Indicate that we're using the From header for the originator. + + set who $fromM + } + } + + # If there's no "From" header, create a From header with the value + # of -originator as the value. + + if {[lsearch -exact $lowerL $fromL] < 0} { + lappend lowerL $fromL + lappend mixedL $fromM + lappend header($fromL) $originator + } + + # ::mime::parseaddress returns a list whose elements are huge key-value + # lists with info about the addresses. In this case, we only want one + # originator, so we want the length of the main list to be 1. + + set addrs [::mime::parseaddress $originator] + if {[llength $addrs] > 1} { + error "too many mailboxes in $who: $originator" + } + array set aprops {error "invalid address \"$from\""} + array set aprops [lindex $addrs 0] + if {$aprops(error) != ""} { + error "error in $who: $aprops(error)" + } + + # sender = validated originator or the value of the From header. + + set sender $aprops(address) + + # If no Sender header has been specified and From is different from + # originator, then set the sender header to the From. Otherwise, don't + # specify a Sender header. + set from [join $header($fromL) ,] + if {[lsearch -exact $lowerL $senderL] < 0 && \ + [string compare $originator $from]} { + if {[info exists aprops]} { + unset aprops + } + array set aprops {error "invalid address \"$from\""} + array set aprops [lindex [::mime::parseaddress $from] 0] + if {$aprops(error) != ""} { + error "error in $fromM: $aprops(error)" + } + if {[string compare $aprops(address) $sender]} { + lappend lowerL $senderL + lappend mixedL $senderM + lappend header($senderL) $aprops(address) + } + } + } + + # We're done parsing the arguments. + + if {$recipients != ""} { + set who -recipients + } elseif {![info exists header($toL)]} { + error "need -header \"$toM ...\"" + } else { + set recipients [join $header($toL) ,] + # Add Cc values to recipients list + set who $toM + if {[info exists header($ccL)]} { + append recipients ,[join $header($ccL) ,] + append who /$ccM + } + + set dccInd [lsearch -exact $lowerL $dccL] + if {$dccInd >= 0} { + # Add Dcc values to recipients list, and get rid of Dcc header + # since we don't want to output that. + append recipients ,[join $header($dccL) ,] + append who /$dccM + + unset header($dccL) + set lowerL [lreplace $lowerL $dccInd $dccInd] + set mixedL [lreplace $mixedL $dccInd $dccInd] + } + } + + set brecipients "" + set bccInd [lsearch -exact $lowerL $bccL] + if {$bccInd >= 0} { + set bccP 1 + + # Build valid bcc list and remove bcc element of header array (so that + # bcc info won't be sent with mail). + foreach addr [::mime::parseaddress [join $header($bccL) ,]] { + if {[info exists aprops]} { + unset aprops + } + array set aprops {error "invalid address \"$from\""} + array set aprops $addr + if {$aprops(error) != ""} { + error "error in $bccM: $aprops(error)" + } + lappend brecipients $aprops(address) + } + + unset header($bccL) + set lowerL [lreplace $lowerL $bccInd $bccInd] + set mixedL [lreplace $mixedL $bccInd $bccInd] + } else { + set bccP 0 + } + + # If there are no To headers, add "" to bcc list. WHY?? + if {[lsearch -exact $lowerL $toL] < 0} { + lappend lowerL $bccL + lappend mixedL $bccM + lappend header($bccL) "" + } + + # Construct valid recipients list from recipients list. + + set vrecipients "" + foreach addr [::mime::parseaddress $recipients] { + if {[info exists aprops]} { + unset aprops + } + array set aprops {error "invalid address \"$from\""} + array set aprops $addr + if {$aprops(error) != ""} { + error "error in $who: $aprops(error)" + } + lappend vrecipients $aprops(address) + } + + # If there's no date header, get the date from the mime message. Same for + # the message-id. + + if {([lsearch -exact $lowerL $dateL] < 0) \ + && ([catch { ::mime::getheader $part $dateL }])} { + lappend lowerL $dateL + lappend mixedL $dateM + lappend header($dateL) [::mime::parsedatetime -now proper] + } + + if {([lsearch -exact $lowerL ${message-idL}] < 0) \ + && ([catch { ::mime::getheader $part ${message-idL} }])} { + lappend lowerL ${message-idL} + lappend mixedL ${message-idM} + lappend header(${message-idL}) [::mime::uniqueID] + + } + + # Get all the headers from the MIME object and save them so that they can + # later be restored. + set savedH [::mime::getheader $part] + + # Take all the headers defined earlier and add them to the MIME message. + foreach lower $lowerL mixed $mixedL { + foreach value $header($lower) { + ::mime::setheader $part $mixed $value -mode append + } + } + + if {[string length $client] < 1} { + if {![string compare $servers localhost]} { + set client localhost + } else { + set client [info hostname] + } + } + + # Create smtp token, which essentially means begin talking to the SMTP + # server. + set token [initialize -debug $debugP -client $client \ + -maxsecs $maxsecs -usetls $tlsP \ + -multiple $bccP -queue $queueP \ + -servers $servers -ports $ports \ + -tlspolicy $tlspolicy \ + -username $username -password $password] + + if {![string match "::smtp::*" $token]} { + # An error occurred and $token contains the error info + array set respArr $token + return -code error $respArr(diagnostic) + } + + set code [catch { sendmessageaux $token $part \ + $sender $vrecipients $aloP } \ + result] + set ecode $errorCode + set einfo $errorInfo + + # Send the message to bcc recipients as a MIME attachment. + + if {($code == 0) && ($bccP)} { + set inner [::mime::initialize -canonical message/rfc822 \ + -header [list Content-Description \ + "Original Message"] \ + -parts [list $part]] + + set subject "\[$bccM\]" + if {[info exists header(subject)]} { + append subject " " [lindex $header(subject) 0] + } + + set outer [::mime::initialize \ + -canonical multipart/digest \ + -header [list From $originator] \ + -header [list Bcc ""] \ + -header [list Date \ + [::mime::parsedatetime -now proper]] \ + -header [list Subject $subject] \ + -header [list Message-ID [::mime::uniqueID]] \ + -header [list Content-Description \ + "Blind Carbon Copy"] \ + -parts [list $inner]] + + + set code [catch { sendmessageaux $token $outer \ + $sender $brecipients \ + $aloP } result2] + set ecode $errorCode + set einfo $errorInfo + + if {$code == 0} { + set result [concat $result $result2] + } else { + set result $result2 + } + + catch { ::mime::finalize $inner -subordinates none } + catch { ::mime::finalize $outer -subordinates none } + } + + # Determine if there was any error in prior operations and set errorcodes + # and error messages appropriately. + + switch -- $code { + 0 { + set status orderly + } + + 7 { + set code 1 + array set response $result + set result "$response(code): $response(diagnostic)" + set status abort + } + + default { + set status abort + } + } + + # Destroy SMTP token 'cause we're done with it. + + catch { finalize $token -close $status } + + # Restore provided MIME object to original state (without the SMTP headers). + + foreach key [::mime::getheader $part -names] { + mime::setheader $part $key "" -mode delete + } + foreach {key values} $savedH { + foreach value $values { + ::mime::setheader $part $key $value -mode append + } + } + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::smtp::sendmessageaux -- +# +# Sends a mime object (containing a message) to some recipients using an +# existing SMTP token. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# part The MIME object containing the message to send. +# originator The e-mail address of the entity sending the message, +# usually the From clause. +# recipients List of e-mail addresses to whom message will be sent. +# aloP Boolean "atleastone" setting; see the -atleastone option +# in ::smtp::sendmessage for details. +# +# Results: +# Message is sent. On success, return "". On failure, throw an +# exception with an error code and error message. + +proc ::smtp::sendmessageaux {token part originator recipients aloP} { + global errorCode errorInfo + + winit $token $part $originator + + set goodP 0 + set badP 0 + set oops "" + foreach recipient $recipients { + set code [catch { waddr $token $recipient } result] + set ecode $errorCode + set einfo $errorInfo + + switch -- $code { + 0 { + incr goodP + } + + 7 { + incr badP + + array set response $result + lappend oops [list $recipient $response(code) \ + $response(diagnostic)] + } + + default { + return -code $code -errorinfo $einfo -errorcode $ecode $result + } + } + } + + if {($goodP) && ((!$badP) || ($aloP))} { + wtext $token $part + } else { + catch { talk $token 300 RSET } + } + + return $oops +} + +# ::smtp::initialize -- +# +# Create an SMTP token and open a connection to the SMTP server. +# +# Arguments: +# args A list of arguments specifying various options for sending the +# message: +# -debug A boolean specifying whether or not debugging is +# on. If debugging is enabled, status messages are +# printed to stderr while trying to send mail. +# -client Either localhost or the name of the local host. +# -multiple Multiple messages will be sent using this token. +# -queue A boolean specifying whether or not the message +# being sent should be queued for later delivery. +# -servers A list of mail servers that could process the +# request. +# -ports A list of ports on mail servers that could process +# the request (one port per server-- defaults to 25). +# -usetls A boolean to indicate we will use TLS if possible. +# -tlspolicy Command called if TLS setup fails. +# -username These provide the authentication information +# -password to be used if needed by the SMTP server. +# +# Results: +# On success, return an smtp token. On failure, throw +# an exception with an error code and error message. + +proc ::smtp::initialize {args} { + global errorCode errorInfo + + variable smtp + + set token [namespace current]::[incr smtp(uid)] + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set state [list afterID "" options "" readable 0] + array set options [list -debug 0 -client localhost -multiple 1 \ + -maxsecs 120 -queue 0 -servers localhost \ + -ports 25 -usetls 1 -tlspolicy {} \ + -username {} -password {}] + array set options $args + set state(options) [array get options] + + # Iterate through servers until one accepts a connection (and responds + # nicely). + + set index 0 + foreach server $options(-servers) { + set state(readable) 0 + if {[llength $options(-ports)] >= $index} { + set port [lindex $options(-ports) $index] + } else { + set port 25 + } + if {$options(-debug)} { + puts stderr "Trying $server..." + flush stderr + } + + if {[info exists state(sd)]} { + unset state(sd) + } + + if {[set code [catch { + set state(sd) [socket -async $server $port] + fconfigure $state(sd) -blocking off -translation binary + fileevent $state(sd) readable [list ::smtp::readable $token] + } result]]} { + set ecode $errorCode + set einfo $errorInfo + + catch { close $state(sd) } + continue + } + + if {[set code [catch { hear $token 600 } result]]} { + array set response [list code 400 diagnostic $result] + } else { + array set response $result + } + set ecode $errorCode + set einfo $errorInfo + switch -- $response(code) { + 220 { + } + + 421 - default { + # 421 - Temporary problem on server + catch {close $state(sd)} + continue + } + } + + set r [initialize_ehlo $token] + if {$r != {}} { + return $r + } + incr index + } + + # None of the servers accepted our connection, so close everything up and + # return an error. + finalize $token -close drop + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# If we cannot load the tls package, ignore the error +proc ::smtp::load_tls {} { + set r [catch {package require tls}] + if {$r} {set ::errorInfo ""} + return $r +} + +proc ::smtp::initialize_ehlo {token} { + global errorCode errorInfo + upvar einfo einfo + upvar ecode ecode + upvar code code + + # FRINK: nocheck + variable $token + upvar 0 $token state + array set options $state(options) + + # Try enhanced SMTP first. + + if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \ + result]]} { + array set response [list code 400 diagnostic $result args ""] + } else { + array set response $result + } + set ecode $errorCode + set einfo $errorInfo + if {(500 <= $response(code)) && ($response(code) <= 599)} { + if {[set code [catch { talk $token 300 \ + "HELO $options(-client)" } \ + result]]} { + array set response [list code 400 diagnostic $result args ""] + } else { + array set response $result + } + set ecode $errorCode + set einfo $errorInfo + } + + if {$response(code) == 250} { + # Successful response to HELO or EHLO command, so set up queuing + # and whatnot and return the token. + + set state(esmtp) $response(args) + + if {(!$options(-multiple)) \ + && ([lsearch $response(args) ONEX] >= 0)} { + catch {smtp::talk $token 300 ONEX} + } + if {($options(-queue)) \ + && ([lsearch $response(args) XQUE] >= 0)} { + catch {smtp::talk $token 300 QUED} + } + + # Support STARTTLS extension. + # The state(tls) item is used to see if we have already tried this. + if {($options(-usetls)) && ![info exists state(tls)] \ + && (([lsearch $response(args) STARTTLS] >= 0) + || ([lsearch $response(args) TLS] >= 0))} { + if {![load_tls]} { + set state(tls) 0 + if {![catch {smtp::talk $token 300 STARTTLS} resp]} { + array set starttls $resp + if {$starttls(code) == 220} { + fileevent $state(sd) readable {} + catch { + ::tls::import $state(sd) + catch {::tls::handshake $state(sd)} msg + set state(tls) 1 + } + fileevent $state(sd) readable \ + [list ::smtp::readable $token] + return [initialize_ehlo $token] + } else { + # Call a TLS client policy proc here + # returns secure close and try another server. + # returns insecure continue on current socket + set policy insecure + if {$options(-tlspolicy) != {}} { + catch { + eval $options(-tlspolicy) \ + [list $starttls(code)] \ + [list $starttls(diagnostic)] + } policy + } + if {$policy != "insecure"} { + set code error + set ecode $starttls(code) + set einfo $starttls(diagnostic) + catch {close $state(sd)} + return {} + } + } + } + } + } + + # If we have not already tried and the server supports it and we + # have a username -- lets try to authenticate. + # + if {![info exists state(auth)] + && [llength [package provide SASL]] != 0 + && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 + && [string length $options(-username)] > 0 } { + + # May be AUTH mech or AUTH=mech + # We want to use the strongest mechanism that has been offered + # and that we support. If we cannot find a mechanism that + # succeeds, we will go ahead and try to carry on unauthenticated. + # This may still work else we'll get an unauthorised error later. + + set mechs [string range [lindex $response(args) $andx] 5 end] + foreach mech [SASL::mechanisms] { + if {[lsearch -exact $mechs $mech] == -1} { continue } + if {[catch { + Authenticate $token $mech + } msg]} { + if {$options(-debug)} { + puts stderr "AUTH $mech failed: $msg " + flush stderr + } + } + if {[info exists state(auth)] && $state(auth)} { + if {$state(auth) == 1} { + break + } else { + # After successful AUTH we are supposed to redo + # our connection for mechanisms that setup a new + # security layer -- these should set state(auth) + # greater than 1 + fileevent $state(sd) readable \ + [list ::smtp::readable $token] + return [initialize_ehlo $token] + } + } + } + } + + return $token + } else { + # Bad response; close the connection and hope the next server + # is happier. + catch {close $state(sd)} + } + return {} +} + +proc ::smtp::SASLCallback {token context command args} { + upvar #0 $token state + upvar #0 $context ctx + array set options $state(options) + switch -exact -- $command { + login { return "" } + username { return $options(-username) } + password { return $options(-password) } + hostname { return [info host] } + realm { + if {[string equal $ctx(mech) "NTLM"] \ + && [info exists ::env(USERDOMAIN)]} { + return $::env(USERDOMAIN) + } else { + return "" + } + } + default { + return -code error "error: unsupported SASL information requested" + } + } +} + +proc ::smtp::Authenticate {token mechanism} { + upvar 0 $token state + package require base64 + set ctx [SASL::new -mechanism $mechanism \ + -callback [list [namespace origin SASLCallback] $token]] + + set state(auth) 0 + set result [smtp::talk $token 300 "AUTH $mechanism"] + array set response $result + + while {$response(code) == 334} { + # The NTLM initial response is not base64 encoded so handle it. + if {[catch {base64::decode $response(diagnostic)} challenge]} { + set challenge $response(diagnostic) + } + SASL::step $ctx $challenge + set result [smtp::talk $token 300 \ + [base64::encode -maxlen 0 [SASL::response $ctx]]] + array set response $result + } + + if {$response(code) == 235} { + set state(auth) 1 + return $result + } else { + return -code 7 $result + } +} + +# ::smtp::finalize -- +# +# Deletes an SMTP token by closing the connection to the SMTP server, +# cleanup up various state. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# args Optional arguments, where the only useful option is -close, +# whose valid values are the following: +# orderly Normal successful completion. Close connection and +# clear state variables. +# abort A connection exists to the SMTP server, but it's in +# a weird state and needs to be reset before being +# closed. Then clear state variables. +# drop No connection exists, so we just need to clean up +# state variables. +# +# Results: +# SMTP connection is closed and state variables are cleared. If there's +# an error while attempting to close the connection to the SMTP server, +# throw an exception with the error code and error message. + +proc ::smtp::finalize {token args} { + global errorCode errorInfo + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set options [list -close orderly] + array set options $args + + switch -- $options(-close) { + orderly { + set code [catch { talk $token 120 QUIT } result] + } + + abort { + set code [catch { + talk $token 0 RSET + talk $token 0 QUIT + } result] + } + + drop { + set code 0 + set result "" + } + + default { + error "unknown value for -close $options(-close)" + } + } + set ecode $errorCode + set einfo $errorInfo + + catch { close $state(sd) } + + if {$state(afterID) != ""} { + catch { after cancel $state(afterID) } + } + + foreach name [array names state] { + unset state($name) + } + # FRINK: nocheck + unset $token + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::smtp::winit -- +# +# Send originator info to SMTP server. This occurs after HELO/EHLO +# command has completed successfully (in ::smtp::initialize). This function +# is called by ::smtp::sendmessageaux. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# part MIME token for the message to be sent. May be used for +# handling some SMTP extensions. +# originator The e-mail address of the entity sending the message, +# usually the From clause. +# mode SMTP command specifying the mode of communication. Default +# value is MAIL. +# +# Results: +# Originator info is sent and SMTP server's response is returned. If an +# error occurs, throw an exception. + +proc ::smtp::winit {token part originator {mode MAIL}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} { + error "unknown origination mode $mode" + } + + set from "$mode FROM:<$originator>" + + # RFC 1870 - SMTP Service Extension for Message Size Declaration + if {[info exists state(esmtp)] + && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { + catch { + set size [string length [mime::buildmessage $part]] + append from " SIZE=$size" + } + } + + array set response [set result [talk $token 600 $from]] + + if {$response(code) == 250} { + set state(addrs) 0 + return $result + } else { + return -code 7 $result + } +} + +# ::smtp::waddr -- +# +# Send recipient info to SMTP server. This occurs after originator info +# is sent (in ::smtp::winit). This function is called by +# ::smtp::sendmessageaux. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# recipient One of the recipients to whom the message should be +# delivered. +# +# Results: +# Recipient info is sent and SMTP server's response is returned. If an +# error occurs, throw an exception. + +proc ::smtp::waddr {token recipient} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + set result [talk $token 3600 "RCPT TO:<$recipient>"] + array set response $result + + switch -- $response(code) { + 250 - 251 { + incr state(addrs) + return $result + } + + default { + return -code 7 $result + } + } +} + +# ::smtp::wtext -- +# +# Send message to SMTP server. This occurs after recipient info +# is sent (in ::smtp::winit). This function is called by +# ::smtp::sendmessageaux. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# part The MIME object containing the message to send. +# +# Results: +# MIME message is sent and SMTP server's response is returned. If an +# error occurs, throw an exception. + +proc ::smtp::wtext {token part} { + # FRINK: nocheck + variable $token + upvar 0 $token state + array set options $state(options) + + set result [talk $token 300 DATA] + array set response $result + if {$response(code) != 354} { + return -code 7 $result + } + + if {[catch { wtextaux $token $part } result]} { + catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) } + return -code 7 [list code 400 diagnostic $result] + } + + set secs $options(-maxsecs) + + set result [talk $token $secs .] + array set response $result + switch -- $response(code) { + 250 - 251 { + return $result + } + + default { + return -code 7 $result + } + } +} + +# ::smtp::wtextaux -- +# +# Helper function that coordinates writing the MIME message to the socket. +# In particular, it stacks the channel leading to the SMTP server, sets up +# some file events, sends the message, unstacks the channel, resets the +# file events to their original state, and returns. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# part The MIME object containing the message to send. +# +# Results: +# Message is sent. If anything goes wrong, throw an exception. + +proc ::smtp::wtextaux {token part} { + global errorCode errorInfo + + # FRINK: nocheck + variable $token + upvar 0 $token state + + # Workaround a bug with stacking channels on top of TLS. + # FRINK: nocheck + set trf [set [namespace current]::trf] + if {[info exists state(tls)] && $state(tls)} { + set trf 0 + } + + flush $state(sd) + fileevent $state(sd) readable "" + if {$trf} { + transform -attach $state(sd) -command [list ::smtp::wdata $token] + } else { + set state(size) 1 + } + fileevent $state(sd) readable [list ::smtp::readable $token] + + # If trf is not available, get the contents of the message, + # replace all '.'s that start their own line with '..'s, and + # then write the mime body out to the filehandle. Do not forget to + # deal with bare LF's here too (SF bug #499242). + + if {$trf} { + set code [catch { ::mime::copymessage $part $state(sd) } result] + } else { + set code [catch { ::mime::buildmessage $part } result] + if {$code == 0} { + # Detect and transform bare LF's into proper CR/LF + # sequences. + + while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {} + regsub -all -- {\n\.} $result "\n.." result + + # Fix for bug #827436 - mail data must end with CRLF.CRLF + if {[string compare [string index $result end] "\n"] != 0} { + append result "\r\n" + } + set state(size) [string length $result] + puts -nonewline $state(sd) $result + set result "" + } + } + set ecode $errorCode + set einfo $errorInfo + + flush $state(sd) + fileevent $state(sd) readable "" + if {$trf} { + unstack $state(sd) + } + fileevent $state(sd) readable [list ::smtp::readable $token] + + return -code $code -errorinfo $einfo -errorcode $ecode $result +} + +# ::smtp::wdata -- +# +# This is the custom transform using Trf to do CR/LF translation. If Trf +# is not installed on the system, then this function never gets called and +# no translation occurs. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# command Trf provided command for manipulating socket data. +# buffer Data to be converted. +# +# Results: +# buffer is translated, and state(size) is set. If Trf is not installed +# on the system, the transform proc defined at the top of this file sets +# state(size) to 1. state(size) is used later to determine a timeout +# value. + +proc ::smtp::wdata {token command buffer} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + switch -- $command { + create/write - + clear/write - + delete/write { + set state(crP) 0 + set state(nlP) 1 + set state(size) 0 + } + + write { + set result "" + + foreach c [split $buffer ""] { + switch -- $c { + "." { + if {$state(nlP)} { + append result . + } + set state(crP) 0 + set state(nlP) 0 + } + + "\r" { + set state(crP) 1 + set state(nlP) 0 + } + + "\n" { + if {!$state(crP)} { + append result "\r" + } + set state(crP) 0 + set state(nlP) 1 + } + + default { + set state(crP) 0 + set state(nlP) 0 + } + } + + append result $c + } + + incr state(size) [string length $result] + return $result + } + + flush/write { + set result "" + + if {!$state(nlP)} { + if {!$state(crP)} { + append result "\r" + } + append result "\n" + } + + incr state(size) [string length $result] + return $result + } + + create/read - + delete/read { + # Bugfix for [#539952] + } + + query/ratio { + # Indicator for unseekable channel, + # for versions of Trf which ask for + # this. + return {0 0} + } + query/maxRead { + # No limits on reading bytes from the channel below, for + # versions of Trf which ask for this information + return -1 + } + + default { + # Silently pass all unknown commands. + #error "Unknown command \"$command\"" + } + } + + return "" +} + +# ::smtp::talk -- +# +# Sends an SMTP command to a server +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# secs Timeout after which command should be aborted. +# command Command to send to SMTP server. +# +# Results: +# command is sent and response is returned. If anything goes wrong, throw +# an exception. + +proc ::smtp::talk {token secs command} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set options $state(options) + + if {$options(-debug)} { + puts stderr "--> $command (wait upto $secs seconds)" + flush stderr + } + + if {[catch { puts -nonewline $state(sd) "$command\r\n" + flush $state(sd) } result]} { + return [list code 400 diagnostic $result] + } + + if {$secs == 0} { + return "" + } + + return [hear $token $secs] +} + +# ::smtp::hear -- +# +# Listens for SMTP server's response to some prior command. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# secs Timeout after which we should stop waiting for a response. +# +# Results: +# Response is returned. + +proc ::smtp::hear {token secs} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set options $state(options) + + array set response [list args ""] + + set firstP 1 + while {1} { + if {$secs >= 0} { + ## SF [ 836442 ] timeout with large data + ## correction, aotto 031105 - + if {$secs > 600} {set secs 600} + set state(afterID) [after [expr {$secs*1000}] \ + [list ::smtp::timer $token]] + } + + if {!$state(readable)} { + vwait ${token}(readable) + } + + # Wait until socket is readable. + if {$state(readable) != -1} { + catch { after cancel $state(afterID) } + set state(afterID) "" + } + + if {$state(readable) < 0} { + array set response [list code 400 diagnostic $state(error)] + break + } + set state(readable) 0 + + if {$options(-debug)} { + puts stderr "<-- $state(line)" + flush stderr + } + + if {[string length $state(line)] < 3} { + array set response \ + [list code 500 \ + diagnostic "response too short: $state(line)"] + break + } + + if {$firstP} { + set firstP 0 + + if {[scan [string range $state(line) 0 2] %d response(code)] \ + != 1} { + array set response \ + [list code 500 \ + diagnostic "unrecognizable code: $state(line)"] + break + } + + set response(diagnostic) \ + [string trim [string range $state(line) 4 end]] + } else { + lappend response(args) \ + [string trim [string range $state(line) 4 end]] + } + + # When status message line ends in -, it means the message is complete. + + if {[string compare [string index $state(line) 3] -]} { + break + } + } + + return [array get response] +} + +# ::smtp::readable -- +# +# Reads a line of data from SMTP server when the socket is readable. This +# is the callback of "fileevent readable". +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# +# Results: +# state(line) contains the line of data and state(readable) is reset. +# state(readable) gets the following values: +# -3 if there's a premature eof, +# -2 if reading from socket fails. +# 1 if reading from socket was successful + +proc ::smtp::readable {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {[catch { array set options $state(options) }]} { + return + } + + set state(line) "" + if {[catch { gets $state(sd) state(line) } result]} { + set state(readable) -2 + set state(error) $result + } elseif {$result == -1} { + if {[eof $state(sd)]} { + set state(readable) -3 + set state(error) "premature end-of-file from server" + } + } else { + # If the line ends in \r, remove the \r. + if {![string compare [string index $state(line) end] "\r"]} { + set state(line) [string range $state(line) 0 end-1] + } + set state(readable) 1 + } + + if {$state(readable) < 0} { + if {$options(-debug)} { + puts stderr " ... $state(error) ..." + flush stderr + } + + catch { fileevent $state(sd) readable "" } + } +} + +# ::smtp::timer -- +# +# Handles timeout condition on any communication with the SMTP server. +# +# Arguments: +# token SMTP token that has an open connection to the SMTP server. +# +# Results: +# Sets state(readable) to -1 and state(error) to an error message. + +proc ::smtp::timer {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set options $state(options) + + set state(afterID) "" + set state(readable) -1 + set state(error) "read from server timed out" + + if {$options(-debug)} { + puts stderr " ... $state(error) ..." + flush stderr + } +} + +# ::smtp::boolean -- +# +# Helper function for unifying boolean values to 1 and 0. +# +# Arguments: +# value Some kind of value that represents true or false (i.e. 0, 1, +# false, true, no, yes, off, on). +# +# Results: +# Return 1 if the value is true, 0 if false. If the input value is not +# one of the above, throw an exception. + +proc ::smtp::boolean {value} { + switch -- [string tolower $value] { + 0 - false - no - off { + return 0 + } + + 1 - true - yes - on { + return 1 + } + + default { + error "unknown boolean value: $value" + } + } +} + +# ------------------------------------------------------------------------- + +package provide smtp 1.4.5 + +# ------------------------------------------------------------------------- +# Local variables: +# indent-tabs-mode: nil +# End: |