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