1# IMAP4 protocol pure Tcl implementation. 2# 3# COPYRIGHT AND PERMISSION NOTICE 4# 5# Copyright (C) 2004 Salvatore Sanfilippo <antirez@invece.org>. 6# 7# All rights reserved. 8# 9# Permission is hereby granted, free of charge, to any person obtaining a 10# copy of this software and associated documentation files (the 11# "Software"), to deal in the Software without restriction, including 12# without limitation the rights to use, copy, modify, merge, publish, 13# distribute, and/or sell copies of the Software, and to permit persons 14# to whom the Software is furnished to do so, provided that the above 15# copyright notice(s) and this permission notice appear in all copies of 16# the Software and that both the above copyright notice(s) and this 17# permission notice appear in supporting documentation. 18# 19# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 20# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 21# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 22# OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 23# HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL 24# INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING 25# FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, 26# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION 27# WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 28# 29# Except as contained in this notice, the name of a copyright holder 30# shall not be used in advertising or otherwise to promote the sale, use 31# or other dealings in this Software without prior written authorization 32# of the copyright holder. 33 34# TODO 35# - Idle mode 36# - Async mode 37# - Authentications 38# - Literals on file mode 39# - fix OR in search, and implement time-related searches 40# All the rest... see the RFC 41 42# History 43# 20100623: G. Reithofer, creating tcl package 0.1, adding some todos 44# option -inline for ::imap4::fetch, in order to return data as a Tcl list 45# isableto without arguments returns the capability list 46# implementation of LIST command 47# 20100709: Adding suppport for SSL connections, namespace variable 48# use_ssl must be set to 1 and package TLS must be loaded 49# 20100716: Bug in parsing special leading FLAGS characters in FETCH 50# command repaired, documentation cleanup. 51# 52 53package require Tcl 8.5 54package provide imap4 0.3 55 56namespace eval imap4 { 57 variable debugmode 0 ;# inside debug mode? usually not. 58 variable folderinfo 59 variable mboxinfo 60 variable msginfo 61 variable info 62 63 # if set to 1 tls::socket must be loaded 64 variable use_ssl 0 65 66 # Debug mode? Don't use it for production! It will print debugging 67 # information to standard output and run a special IMAP debug mode shell 68 # on protocol error. 69 variable debug 0 70 71 # Version 72 variable version "2010-07-16" 73 74 # This is where we take state of all the IMAP connections. 75 # The following arrays are indexed with the connection channel 76 # to access the per-channel information. 77 array set folderinfo {} ;# list of folders. 78 array set mboxinfo {} ;# selected mailbox info. 79 array set msginfo {} ;# messages info. 80 array set info {} ;# general connection state info. 81 82 # Return the next tag to use in IMAP requests. 83 proc tag {chan} { 84 variable info 85 incr info($chan,curtag) 86 } 87 88 # Assert that the channel is one of the specified states 89 # by the 'states' list. 90 # otherwise raise an error. 91 proc requirestate {chan states} { 92 variable info 93 if {[lsearch $states $info($chan,state)] == -1} { 94 error "IMAP channel not in one of the following states: '$states' (current state is '$info($chan,state)')" 95 } 96 } 97 98 # Open a new IMAP connection and initalize the handler. 99 proc open {hostname {port 0}} { 100 variable info 101 variable debug 102 variable use_ssl 103 if {$debug} { 104 puts "I: open $hostname $port (SSL=$use_ssl)" 105 } 106 107 if {$use_ssl} { 108 if {[info procs ::tls::socket] eq ""} { 109 error "Package TLS must be loaded for secure connections." 110 } 111 if {!$port} { 112 set port 993 113 } 114 set chan [::tls::socket $hostname $port] 115 } else { 116 if {!$port} { 117 set port 143 118 } 119 set chan [socket $hostname $port] 120 } 121 fconfigure $chan -encoding binary -translation binary 122 # Intialize the connection state array 123 initinfo $chan 124 # Get the banner 125 processline $chan 126 # Save the banner 127 set info($chan,banner) [lastline $chan] 128 return $chan 129 } 130 131 # Initialize the info array for a new connection. 132 proc initinfo {chan} { 133 variable info 134 set info($chan,curtag) 0 135 set info($chan,state) NOAUTH 136 set info($chan,folders) {} 137 set info($chan,capability) {} 138 set info($chan,raise_on_NO) 1 139 set info($chan,raise_on_BAD) 1 140 set info($chan,idle) {} 141 set info($chan,lastcode) {} 142 set info($chan,lastline) {} 143 set info($chan,lastrequest) {} 144 } 145 146 # Destroy an IMAP connection and free the used space. 147 proc cleanup {chan} { 148 variable info 149 variable folderinfo 150 variable mboxinfo 151 variable msginfo 152 153 close $chan 154 155 array unset folderinfo $chan,* 156 array unset mboxinfo $chan,* 157 array unset msginfo $chan,* 158 array unset info $chan,* 159 160 return $chan 161 } 162 163 # Returns the last error code received. 164 proc lastcode {chan} { 165 variable info 166 return $info($chan,lastcode) 167 } 168 169 # Returns the last line received from the server. 170 proc lastline {chan} { 171 variable info 172 return $info($chan,lastline) 173 } 174 175 # Process an IMAP response line. 176 # This function trades semplicity in IMAP commands 177 # implementation with monolitic handling of responses. 178 # However note that the IMAP server can reply to a command 179 # with many different untagged info, so to have the reply 180 # processing centralized makes this simple to handle. 181 # 182 # Returns the line's tag. 183 proc processline {chan} { 184 variable info 185 variable debug 186 variable mboxinfo 187 variable folderinfo 188 189 set literals {} 190 while {1} { 191 # Read a line 192 if {[gets $chan buf] == -1} { 193 error "IMAP unexpected EOF from server." 194 } 195 196 append line $buf 197 # Remove the trailing CR at the end of the line, if any. 198 if {[string index $line end] eq "\r"} { 199 set line [string range $line 0 end-1] 200 } 201 202 # Check if there is a literal to read, and read it if any. 203 if {[regexp {{([0-9]+)}\s+$} $buf => length]} { 204 # puts "Reading $length bytes of literal..." 205 lappend literals [read $chan $length] 206 } else { 207 break 208 } 209 } 210 set info($chan,lastline) $line 211 212 if {$debug} { 213 puts "S: $line" 214 } 215 216 # Extract the tag. 217 set idx [string first { } $line] 218 if {$idx <= 0} { 219 protoerror $chan "IMAP: malformed response '$line'" 220 } 221 222 set tag [string range $line 0 [expr {$idx-1}]] 223 set line [string range $line [expr {$idx+1}] end] 224 # If it's just a command continuation response, return. 225 if {$tag eq {+}} {return +} 226 227 # Extract the error code, if it's a tagged line 228 if {$tag ne {*}} { 229 set idx [string first { } $line] 230 if {$idx <= 0} { 231 protoerror $chan "IMAP: malformed response '$line'" 232 } 233 set code [string range $line 0 [expr {$idx-1}]] 234 set line [string trim [string range $line [expr {$idx+1}] end]] 235 set info($chan,lastcode) $code 236 } 237 238 # Extract information from the line 239 set dirty 0 240 switch -glob -- $line { 241 {*\[READ-ONLY\]*} {set mboxinfo($chan,perm) READ-ONLY; incr dirty} 242 {*\[READ-WRITE\]*} {set mboxinfo($chan,perm) READ-WRITE; incr dirty} 243 {*\[TRYCREATE\]*} {set mboxinfo($chan,perm) TRYCREATE; incr dirty} 244 {LIST *(*)*} { 245 # regexp not secure enough ... delimiters must be PLAIN SPACES (see RFC) 246 # set res [regexp {LIST (\(.*\))(!?\s)[ ](.*)$} $line => flags delim fname] 247 # p1| p2| p3| 248 # LIST (\Noselect) "/" ~/Mail/foo 249 set p1 [string first "(" $line] 250 set p2 [string first ")" $line [expr {$p1+1}]] 251 set p3 [string first " " $line [expr {$p2+2}]] 252 if {$p1<0||$p2<0||$p3<0} { 253 protoerror $chan "IMAP: Not a valid RFC822 LIST format in '$line'" 254 } 255 set flags [string range $line [expr {$p1+1}] [expr {$p2-1}]] 256 set delim [string range $line [expr {$p2+2}] [expr {$p3-1}]] 257 set fname [string range $line [expr {$p3+1}] end] 258 if {$fname eq ""} { 259 set folderinfo($chan,delim) [string trim $delim {"}] 260 } else { 261 set fflag {} 262 foreach f [split $flags] { 263 lappend fflag $f 264 } 265 lappend folderinfo($chan,names) $fname 266 lappend folderinfo($chan,flags) [list $fname $fflag] 267 if {$delim ne "NIL"} { 268 set folderinfo($chan,delim) [string trim $delim {"}] 269 } 270 } 271 incr dirty 272 } 273 {FLAGS *(*)*} { 274 regexp {.*\((.*)\).*} $line => flags 275 set mboxinfo($chan,flags) $flags 276 incr dirty 277 } 278 {*\[PERMANENTFLAGS *(*)*\]*} { 279 regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags 280 set mboxinfo($chan,permflags) $flags 281 incr dirty 282 } 283 } 284 285 if {!$dirty && $tag eq {*}} { 286 switch -regexp -nocase -- $line { 287 {^[0-9]+\s+EXISTS} { 288 regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists) 289 incr dirty 290 } 291 {^[0-9]+\s+RECENT} { 292 regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent) 293 incr dirty 294 } 295 {.*?\[UIDVALIDITY\s+[0-9]+?\]} { 296 regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \ 297 mboxinfo($chan,uidval) 298 incr dirty 299 } 300 {.*?\[UNSEEN\s+[0-9]+?\]} { 301 regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \ 302 mboxinfo($chan,unseen) 303 incr dirty 304 } 305 {.*?\[UIDNEXT\s+[0-9]+?\]} { 306 regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \ 307 mboxinfo($chan,uidnext) 308 incr dirty 309 } 310 {^[0-9]+\s+FETCH} { 311 processfetchline $chan $line $literals 312 incr dirty 313 } 314 {^CAPABILITY\s+.*} { 315 regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring 316 set info($chan,capability) [split [string toupper $capstring]] 317 incr dirty 318 } 319 {^LIST\s*$} { 320 regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists) 321 incr dirty 322 } 323 {^SEARCH\s*$} { 324 # Search tag without list of messages. Nothing found 325 # so we set an empty list. 326 set mboxinfo($chan,found) {} 327 } 328 {^SEARCH\s+.*} { 329 regexp {^SEARCH\s+(.*)\s*$} $line => foundlist 330 set mboxinfo($chan,found) $foundlist 331 incr dirty 332 } 333 default { 334 if {$debug} { 335 puts "*** WARNING: unprocessed server reply '$line'" 336 } 337 } 338 } 339 } 340 341 if {[string length [set info($chan,idle)]] && $dirty} { 342 # ... Notify. 343 } 344 345 # if debug and no dirty and untagged line... warning: unprocessed IMAP line 346 return $tag 347 } 348 349 # Process untagged FETCH lines. 350 proc processfetchline {chan line literals} { 351 variable msginfo 352 regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items 353 foreach {name val} [imaptotcl items literals] { 354 set attribname [switch -glob -- [string toupper $name] { 355 INTERNALDATE {format internaldate} 356 BODYSTRUCTURE {format bodystructure} 357 {BODY\[HEADER.FIELDS*\]} {format fields} 358 {BODY.PEEK\[HEADER.FIELDS*\]} {format fields} 359 {BODY\[*\]} {format body} 360 {BODY.PEEK\[*\]} {format body} 361 HEADER {format header} 362 RFC822.HEADER {format header} 363 RFC822.SIZE {format size} 364 RFC822.TEXT {format text} 365 ENVELOPE {format envelope} 366 FLAGS {format flags} 367 UID {format uid} 368 default { 369 protoerror $chan "IMAP: Unknown FETCH item '$name'. Upgrade the software" 370 } 371 }] 372 373 switch -- $attribname { 374 fields { 375 set last_fieldname __garbage__ 376 foreach f [split $val "\n\r"] { 377 # Handle multi-line headers. Append to the last header 378 # if this line starts with a tab character. 379 if {[string is space [string index $f 0]]} { 380 append msginfo($chan,$msgnum,$last_fieldname) " [string range $f 1 end]" 381 continue 382 } 383 # Process the line searching for a new field. 384 if {![string length $f]} continue 385 if {[set fnameidx [string first ":" $f]] == -1} { 386 protoerror $chan "IMAP: Not a valid RFC822 field '$f'" 387 } 388 set fieldname [string tolower [string range $f 0 $fnameidx]] 389 set last_fieldname $fieldname 390 set fieldval [string trim \ 391 [string range $f [expr {$fnameidx+1}] end]] 392 set msginfo($chan,$msgnum,$fieldname) $fieldval 393 } 394 } 395 default { 396 set msginfo($chan,$msgnum,$attribname) $val 397 } 398 } 399 #puts "$attribname -> [string range $val 0 20]" 400 } 401 # parray msginfo 402 } 403 404 # Convert IMAP data into Tcl data. Consumes the part of the 405 # string converted. 406 # 'literals' is a list with all the literals extracted 407 # from the original line, in the same order they appeared. 408 proc imaptotcl {datavar literalsvar} { 409 upvar 1 $datavar data $literalsvar literals 410 set data [string trim $data] 411 switch -- [string index $data 0] { 412 \{ {imaptotcl_literal data literals} 413 "(" {imaptotcl_list data literals} 414 "\"" {imaptotcl_quoted data} 415 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number data} 416 \) {imaptotcl_endlist data;# that's a trick to parse lists} 417 default {imaptotcl_symbol data} 418 } 419 } 420 421 # Extract a literal 422 proc imaptotcl_literal {datavar literalsvar} { 423 upvar 1 $datavar data $literalsvar literals 424 if {![regexp {{.*?}} $data match]} { 425 protoerror $chan "IMAP data format error: '$data'" 426 } 427 set data [string range $data [string length $match] end] 428 set retval [lindex $literals 0] 429 set literals [lrange $literals 1 end] 430 return $retval 431 } 432 433 # Extract a quoted string 434 proc imaptotcl_quoted {datavar} { 435 upvar 1 $datavar data 436 if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} { 437 protoerror $chan "IMAP data format error: '$data'" 438 } 439 set data [string range $data [string length $match] end] 440 return [string range $match 1 end-1] 441 } 442 443 # Extract a number 444 proc imaptotcl_number {datavar} { 445 upvar 1 $datavar data 446 if {![regexp {^[0-9]+} $data match]} { 447 protoerror $chan "IMAP data format error: '$data'" 448 } 449 set data [string range $data [string length $match] end] 450 return $match 451 } 452 453 # Extract a "symbol". Not really exists in IMAP, but there 454 # are named items, and this names have a strange unquoted 455 # syntax like BODY[HEAEDER.FIELD (From To)] and other stuff 456 # like that. 457 proc imaptotcl_symbol {datavar} { 458 upvar 1 $datavar data 459 # matching patterns: "BODY[HEAEDER.FIELD", 460 # "HEAEDER.FIELD", "\Answered", "$Forwarded" 461 set pattern {([\w\.]+\[[^\[]+\]|[\w\.]+|[\\\$]\w+)} 462 if {![regexp $pattern $data => match]} { 463 protoerror $chan "IMAP data format error: '$data'" 464 } 465 set data [string range $data [string length $match] end] 466 return $match 467 } 468 469 # Extract an IMAP list. 470 proc imaptotcl_list {datavar literalsvar} { 471 upvar 1 $datavar data $literalsvar literals 472 set list {} 473 # Remove the first '(' char 474 set data [string range $data 1 end] 475 # Get all the elements of the list. May indirectly recurse called 476 # by [imaptotcl]. 477 while {[string length $data]} { 478 set ele [imaptotcl data literals] 479 if {$ele eq {)}} { 480 break 481 } 482 lappend list $ele 483 } 484 return $list 485 } 486 487 # Just extracts the ")" character alone. 488 # This is actually part of the list extraction work. 489 proc imaptotcl_endlist {datavar} { 490 upvar 1 $datavar data 491 set data [string range $data 1 end] 492 return ")" 493 } 494 495 # Process IMAP responses. If the IMAP channel is not 496 # configured to raise errors on IMAP errors, returns 0 497 # on OK response, otherwise 1 is returned. 498 proc getresponse {chan} { 499 variable info 500 501 # Process lines until the tagged one. 502 while {[set tag [processline $chan]] eq {*} || $tag eq {+}} {} 503 switch -- [lastcode $chan] { 504 OK {return 0} 505 NO { 506 if {$info($chan,raise_on_NO)} { 507 error "IMAP error: [lastline $chan]" 508 } 509 return 1 510 } 511 BAD { 512 if {$info($chan,raise_on_BAD)} { 513 protoerror $chan "IMAP error: [lastline $chan]" 514 } 515 return 1 516 } 517 default { 518 protoerror $chan "IMAP protocol error. Unknown response code '[lastcode $chan]'" 519 } 520 } 521 } 522 523 # Write a request. 524 proc request {chan request} { 525 variable debug 526 variable info 527 528 set t "[tag $chan] $request" 529 if {$debug} { 530 puts "C: $t" 531 } 532 set info($chan,lastrequest) $t 533 puts -nonewline $chan "$t\r\n" 534 flush $chan 535 } 536 537 # Write a multiline request. The 'request' list must contain 538 # parts of command and literals interleaved. Literals are ad odd 539 # list positions (1, 3, ...). 540 proc multiline_request {chan request} { 541 variable debug 542 variable info 543 544 lset request 0 "[tag $chan][lindex $request 0]" 545 set items [llength $request] 546 foreach {line literal} $request { 547 # Send the line 548 if {$debug} { 549 puts "C: $line" 550 } 551 puts -nonewline $chan "$line\r\n" 552 flush $chan 553 incr items -1 554 if {!$items} break 555 556 # Wait for the command continuation response 557 if {[processline $chan] ne {+}} { 558 protoerror $chan "Expected a command continuation response but got '[lastline $chan]'" 559 } 560 561 # Send the literal 562 if {$debug} { 563 puts "C> $literal" 564 } 565 puts -nonewline $chan $literal 566 flush $chan 567 incr items -1 568 } 569 set info($chan,lastrequest) $request 570 } 571 572 # Login using the IMAP LOGIN command. 573 proc login {chan user pass} { 574 variable info 575 576 requirestate $chan NOAUTH 577 request $chan "LOGIN $user $pass" 578 if {[getresponse $chan]} { 579 return 1 580 } 581 set info($chan,state) AUTH 582 return 0 583 } 584 585 # Mailbox selection. 586 proc select {chan {mailbox INBOX}} { 587 selectmbox $chan SELECT $mailbox 588 } 589 590 # Read-only equivalent of SELECT. 591 proc examine {chan {mailbox INBOX}} { 592 selectmbox $chan EXAMINE $mailbox 593 } 594 595 # General function for selection. 596 proc selectmbox {chan cmd mailbox} { 597 variable info 598 variable mboxinfo 599 600 requirestate $chan AUTH 601 # Clean info about the previous mailbox if any, 602 # but save a copy to restore this info on error. 603 set savedmboxinfo [array get mboxinfo $chan,*] 604 array unset mboxinfo $chan,* 605 request $chan "$cmd $mailbox" 606 if {[getresponse $chan]} { 607 array set mboxinfo $savedmboxinfo 608 return 1 609 } 610 611 set info($chan,state) SELECT 612 # Set the new name as mbox->current. 613 set mboxinfo($chan,current) $mailbox 614 return 0 615 } 616 617 # Parse an IMAP range, store 'start' and 'end' in the 618 # named vars. If the first number of the range is omitted, 619 # 1 is assumed. If the second number of the range is omitted, 620 # the value of "exists" of the current mailbox is assumed. 621 # 622 # So : means all the messages. 623 proc parserange {chan range startvar endvar} { 624 625 upvar $startvar start $endvar end 626 set rangelist [split $range :] 627 switch -- [llength $rangelist] { 628 1 { 629 if {![string is integer $range]} { 630 error "Invalid range" 631 } 632 set start $range 633 set end $range 634 } 635 2 { 636 foreach {start end} $rangelist break 637 if {![string length $start]} { 638 set start 1 639 } 640 if {![string length $end]} { 641 set end [mboxinfo $chan exists] 642 } 643 if {![string is integer $start] || ![string is integer $end]} { 644 error "Invalid range" 645 } 646 } 647 default { 648 error "Invalid range" 649 } 650 } 651 } 652 653 # Fetch a number of attributes from messages 654 proc fetch {chan range opt args} { 655 if {$opt eq "-inline"} { 656 set inline 1 657 } else { 658 set inline 0 659 set args [linsert $args 0 $opt] 660 } 661 requirestate $chan SELECT 662 parserange $chan $range start end 663 664 set items {} 665 set hdrfields {} 666 foreach w $args { 667 switch -glob -- [string toupper $w] { 668 ALL {lappend items ALL} 669 BODYSTRUCTURE {lappend items BODYSTRUCTURE} 670 ENVELOPE {lappend items ENVELOPE} 671 FLAGS {lappend items FLAGS} 672 SIZE {lappend items RFC822.SIZE} 673 TEXT {lappend items RFC822.TEXT} 674 HEADER {lappend items RFC822.HEADER} 675 UID {lappend items UID} 676 *: {lappend hdrfields $w} 677 default { 678 # Fixme: better to raise an error here? 679 lappend hdrfields $w: 680 } 681 } 682 } 683 684 if {[llength $hdrfields]} { 685 set item {BODY[HEADER.FIELDS (} 686 foreach field $hdrfields { 687 append item [string toupper [string range $field 0 end-1]] { } 688 } 689 set item [string range $item 0 end-1] 690 append item {)]} 691 lappend items $item 692 } 693 694 # Send the request 695 request $chan "FETCH $start:$end ([join $items])" 696 if {[getresponse $chan]} { 697 if {$inline} { 698 # Should we throw an error here? 699 return "" 700 } 701 return 1 702 } 703 704 if {!$inline} { 705 return 0 706 } 707 708 # -inline procesing begins here 709 set mailinfo {} 710 for {set i $start} {$i <= $end} {incr i} { 711 set mailrec {} 712 foreach {h} $args { 713 lappend mailrec [msginfo $chan $i $h ""] 714 } 715 lappend mailinfo $mailrec 716 } 717 return $mailinfo 718 } 719 720 # Get information (previously collected using fetch) from a given message. 721 # If the 'info' argument is omitted or a null string, the full list 722 # of information available for the given message is returned. 723 # 724 # If the required information name is suffixed with a ? character, 725 # the command requires true if the information is available, or 726 # false if it is not. 727 proc msginfo {chan msgid args} { 728 variable msginfo 729 730 switch -- [llength $args] { 731 0 { 732 set info {} 733 } 734 1 { 735 set info [lindex $args 0] 736 set use_defval 0 737 } 738 2 { 739 set info [lindex $args 0] 740 set defval [lindex $args 1] 741 set use_defval 1 742 } 743 default { 744 error "msginfo called with bad number of arguments! Try msginfo channel messageid ?info? ?defaultvalue?" 745 } 746 } 747 set info [string tolower $info] 748 # Handle the missing info case 749 if {![string length $info]} { 750 set list [array names msginfo $chan,$msgid,*] 751 set availinfo {} 752 foreach l $list { 753 lappend availinfo [string range $l \ 754 [string length $chan,$msgid,] end] 755 } 756 return $availinfo 757 } 758 759 if {[string index $info end] eq {?}} { 760 set info [string range $info 0 end-1] 761 return [info exists msginfo($chan,$msgid,$info)] 762 } else { 763 if {![info exists msginfo($chan,$msgid,$info)]} { 764 if {$use_defval} { 765 return $defval 766 } else { 767 error "No such information '$info' available for message id '$msgid'" 768 } 769 } 770 return $msginfo($chan,$msgid,$info) 771 } 772 } 773 774 # Get information on the currently selected mailbox. 775 # If the 'info' argument is omitted or a null string, the full list 776 # of information available for the mailbox is returned. 777 # 778 # If the required information name is suffixed with a ? character, 779 # the command requires true if the information is available, or 780 # false if it is not. 781 proc mboxinfo {chan {info {}}} { 782 variable mboxinfo 783 784 # Handle the missing info case 785 if {![string length $info]} { 786 set list [array names mboxinfo $chan,*] 787 set availinfo {} 788 foreach l $list { 789 lappend availinfo [string range $l \ 790 [string length $chan,] end] 791 } 792 return $availinfo 793 } 794 795 set info [string tolower $info] 796 if {[string index $info end] eq {?}} { 797 set info [string range $info 0 end-1] 798 return [info exists mboxinfo($chan,$info)] 799 } else { 800 if {![info exists mboxinfo($chan,$info)]} { 801 error "No such information '$info' available for the current mailbox" 802 } 803 return $mboxinfo($chan,$info) 804 } 805 } 806 807 # Get information on the last folders list. 808 # If the 'info' argument is omitted or a null string, the full list 809 # of information available for the folders is returned. 810 # 811 # If the required information name is suffixed with a ? character, 812 # the command requires true if the information is available, or 813 # false if it is not. 814 proc folderinfo {chan {info {}}} { 815 variable folderinfo 816 817 # Handle the missing info case 818 if {![string length $info]} { 819 set list [array names folderinfo $chan,*] 820 set availinfo {} 821 foreach l $list { 822 lappend availinfo [string range $l \ 823 [string length $chan,] end] 824 } 825 return $availinfo 826 } 827 828 set info [string tolower $info] 829 if {[string index $info end] eq {?}} { 830 set info [string range $info 0 end-1] 831 return [info exists folderinfo($chan,$info)] 832 } else { 833 if {![info exists folderinfo($chan,$info)]} { 834 error "No such information '$info' available for the current folders" 835 } 836 return $folderinfo($chan,$info) 837 } 838 } 839 840 841 # Get capabilties 842 proc capability {chan} { 843 request $chan "CAPABILITY" 844 if {[getresponse $chan]} { 845 return 1 846 } 847 return 0 848 } 849 850 # Get the current state 851 proc state {chan} { 852 variable info 853 return $info($chan,state) 854 } 855 856 # Test for capability. Use the capability command 857 # to ask the server if not already done by the user. 858 proc isableto {chan {capa ""}} { 859 variable info 860 861 if {![llength $info($chan,capability)]} { 862 set result [capability $chan] 863 } 864 865 if {$capa eq ""} { 866 if {$result} { 867 # We return empty string on error 868 return "" 869 } 870 return $info($chan,capability) 871 } 872 873 set capa [string toupper $capa] 874 expr {[lsearch -exact $info($chan,capability) $capa] != -1} 875 } 876 877 # NOOP command. May get information as untagged data. 878 proc noop {chan} { 879 simplecmd $chan NOOP {NOAUTH AUTH SELECT} {} 880 } 881 882 # CHECK. Flush to disk. 883 proc check {chan} { 884 simplecmd $chan CHECK SELECT {} 885 } 886 887 # Close the mailbox. Permanently removes \Deleted messages and return to 888 # the AUTH state. 889 proc close {chan} { 890 variable info 891 892 if {[simplecmd $chan CLOSE SELECT {}]} { 893 return 1 894 } 895 896 set info($chan,state) AUTH 897 return 0 898 } 899 900 # Create a new mailbox. 901 proc create {chan mailbox} { 902 simplecmd $chan CREATE {AUTH SELECT} $mailbox 903 } 904 905 # Delete a mailbox 906 proc delete {chan mailbox} { 907 simplecmd $chan DELETE {AUTH SELECT} $mailbox 908 } 909 910 # Rename a mailbox 911 proc rename {chan oldname newname} { 912 simplecmd $chan RENAME {AUTH SELECT} $oldname $newname 913 } 914 915 # Subscribe to a mailbox 916 proc subscribe {chan mailbox} { 917 simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox 918 } 919 920 # Unsubscribe to a mailbox 921 proc unsubscribe {chan mailbox} { 922 simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox 923 } 924 925 # List of folders 926 proc folders {chan {opt ""} {ref ""} {mbox "*"}} { 927 variable folderinfo 928 array unset folderinfo $chan,* 929 930 if {$opt eq "-inline"} { 931 set inline 1 932 } else { 933 set ref $opt 934 set mbox $ref 935 set inline 0 936 } 937 938 set folderinfo($chan,match) [list $ref $mbox] 939 # parray folderinfo 940 set rv [simplecmd $chan LIST {SELECT AUTH} \"$ref\" \"$mbox\"] 941 if {$inline} { 942 set rv {} 943 foreach f [folderinfo $chan flags] { 944 set lflags {} 945 foreach {fl} [lindex $f 1] { 946 if {[string is alnum [string index $fl 0]]} { 947 lappend lflags [string tolower $fl]] 948 } else { 949 lappend lflags [string tolower [string range $fl 1 end]] 950 } 951 } 952 lappend rv [list [lindex $f 0] $lflags] 953 } 954 } 955 # parray folderinfo 956 return $rv 957 } 958 959 # This a general implementation for a simple implementation 960 # of an IMAP command that just requires to call ::imap4::request 961 # and ::imap4::getresponse. 962 proc simplecmd {chan command validstates args} { 963 requirestate $chan $validstates 964 965 set req "$command" 966 foreach arg $args { 967 append req " $arg" 968 } 969 970 request $chan $req 971 if {[getresponse $chan]} { 972 return 1 973 } 974 975 return 0 976 } 977 978 # Search command. 979 proc search {chan args} { 980 if {![llength $args]} { 981 error "missing arguments. Usage: search chan arg ?arg ...?" 982 } 983 984 requirestate $chan SELECT 985 set imapexpr [convert_search_expr $args] 986 multiline_prefix_command imapexpr "SEARCH" 987 multiline_request $chan $imapexpr 988 if {[getresponse $chan]} { 989 return 1 990 } 991 992 return 0 993 } 994 995 # Creates an IMAP octect-count. 996 # Used to send literals. 997 proc literalcount {string} { 998 return "{[string length $string]}" 999 } 1000 1001 # Append a command part to a multiline request 1002 proc multiline_append_command {reqvar cmd} { 1003 upvar 1 $reqvar req 1004 1005 if {[llength $req] == 0} { 1006 lappend req {} 1007 } 1008 1009 lset req end "[lindex $req end] $cmd" 1010 } 1011 1012 # Append a literal to a multiline request. Uses a quoted 1013 # string in simple cases. 1014 proc multiline_append_literal {reqvar lit} { 1015 upvar 1 $reqvar req 1016 1017 if {![string is alnum $lit]} { 1018 lset req end "[lindex $req end] [literalcount $lit]" 1019 lappend req $lit {} 1020 } else { 1021 multiline_append_command req "\"$lit\"" 1022 } 1023 } 1024 1025 # Prefix a multiline request with a command. 1026 proc multiline_prefix_command {reqvar cmd} { 1027 upvar 1 $reqvar req 1028 1029 if {![llength $req]} { 1030 lappend req {} 1031 } 1032 1033 lset req 0 " $cmd[lindex $req 0]" 1034 } 1035 1036 # Concat an already created search expression to a multiline request. 1037 proc multiline_concat_expr {reqvar expr} { 1038 upvar 1 $reqvar req 1039 lset req end "[lindex $req end] ([string range [lindex $expr 0] 1 end]" 1040 set req [concat $req [lrange $expr 1 end]] 1041 lset req end "[lindex $req end])" 1042 } 1043 1044 # Helper for the search command. Convert a programmer friendly expression 1045 # (actually a tcl list) to the IMAP syntax. Returns a list composed of 1046 # request, literal, request, literal, ... (to be sent with 1047 # ::imap4::multiline_request). 1048 proc convert_search_expr {expr} { 1049 set result {} 1050 1051 while {[llength $expr]} { 1052 switch -glob -- [string toupper [set token [lpop expr]]] { 1053 *: { 1054 set wanted [lpop expr] 1055 multiline_append_command result "HEADER [string range $token 0 end-1]" 1056 multiline_append_literal result $wanted 1057 } 1058 1059 ANSWERED - DELETED - DRAFT - FLAGGED - RECENT - 1060 SEEN - NEW - OLD - UNANSWERED - UNDELETED - 1061 UNDRAFT - UNFLAGGED - UNSEEN - 1062 ALL {multiline_append_command result [string toupper $token]} 1063 1064 BODY - CC - FROM - SUBJECT - TEXT - KEYWORD - 1065 BCC { 1066 set wanted [lpop expr] 1067 multiline_append_command result "$token" 1068 multiline_append_literal result $wanted 1069 } 1070 1071 OR { 1072 set first [convert_search_expr [lpop expr]] 1073 set second [convert_search_expr [lpop expr]] 1074 multiline_append_command result "OR" 1075 multiline_concat_expr result $first 1076 multiline_concat_expr result $second 1077 } 1078 1079 NOT { 1080 set e [convert_search_expr [lpop expr]] 1081 multiline_append_command result "NOT" 1082 multiline_concat_expr result $e 1083 } 1084 1085 SMALLER - 1086 LARGER { 1087 set len [lpop expr] 1088 if {![string is integer $len]} { 1089 error "Invalid integer follows '$token' in IMAP search" 1090 } 1091 multiline_append_command result "$token $len" 1092 } 1093 1094 ON - SENTBEFORE - SENTON - SENTSINCE - SINCE - 1095 BEFORE {error "TODO"} 1096 1097 UID {error "TODO"} 1098 default { 1099 error "Syntax error in search expression: '... $token $expr'" 1100 } 1101 } 1102 } 1103 return $result 1104 } 1105 1106 # Pop an element from the list inside the named variable and return it. 1107 # If a list is empty, raise an error. The error is specific for the 1108 # search command since it's the only one calling this function. 1109 proc lpop {listvar} { 1110 upvar 1 $listvar l 1111 1112 if {![llength $l]} { 1113 error "Bad syntax for search expression (missing argument)" 1114 } 1115 1116 set res [lindex $l 0] 1117 set l [lrange $l 1 end] 1118 return $res 1119 } 1120 1121 # Debug mode. 1122 # This is a developers mode only that pass the control to the 1123 # programmer. Every line entered is sent verbatim to the 1124 # server (after the addition of the request identifier). 1125 # The ::imap4::debug variable is automatically set to '1' on enter. 1126 # 1127 # It's possible to execute Tcl commands starting the line 1128 # with a slash. 1129 1130 proc debugmode {chan {errormsg {None}}} { 1131 variable debugmode 1 1132 variable debugchan $chan 1133 variable version 1134 variable folderinfo 1135 variable mboxinfo 1136 variable msginfo 1137 variable info 1138 1139 set welcometext [list \ 1140 "------------------------ IMAP DEBUG MODE --------------------" \ 1141 "IMAP Debug mode usage: Every line typed will be sent" \ 1142 "verbatim to the IMAP server prefixed with a unique IMAP tag." \ 1143 "To execute Tcl commands prefix the line with a / character." \ 1144 "The current debugged channel is returned by the \[me\] command." \ 1145 "Type ! to exit" \ 1146 "Type 'info' to see information about the connection" \ 1147 "Type 'help' to display this information" \ 1148 "" \ 1149 "Last error: '$errormsg'" \ 1150 "IMAP library version: '$version'" \ 1151 "" \ 1152 ] 1153 foreach l $welcometext { 1154 puts $l 1155 } 1156 1157 debugmode_info $chan 1158 while 1 { 1159 puts -nonewline "imap debug> " 1160 flush stdout 1161 gets stdin line 1162 if {![string length $line]} continue 1163 if {$line eq {!}} exit 1164 if {$line eq {info}} { 1165 debugmode_info $chan 1166 continue 1167 } 1168 if {$line eq {help}} { 1169 foreach l $welcometext { 1170 if {$l eq ""} break 1171 puts $l 1172 } 1173 continue 1174 } 1175 if {[string index $line 0] eq {/}} { 1176 catch {eval [string range $line 1 end]} result 1177 puts $result 1178 continue 1179 } 1180 # Let's send the request to imap server 1181 request $chan $line 1182 if {[catch {getresponse $chan} error]} { 1183 puts "--- ERROR ---\n$error\n-------------\n" 1184 } 1185 } 1186 } 1187 1188 # Little helper for debugmode command. 1189 proc debugmode_info {chan} { 1190 variable info 1191 puts "Last sent request: '$info($chan,lastrequest)'" 1192 puts "Last received line: '$info($chan,lastline)'" 1193 puts "" 1194 } 1195 1196 # Protocol error! Enter the debug mode if ::imap4::debug is true. 1197 # Otherwise just raise the error. 1198 proc protoerror {chan msg} { 1199 variable debug 1200 variable debugmode 1201 1202 if {$debug && !$debugmode} { 1203 debugmode $chan $msg 1204 } else { 1205 error $msg 1206 } 1207 } 1208 1209 proc me {} { 1210 variable debugchan 1211 set debugchan 1212 } 1213 1214 # Other stuff to do in random order... 1215 # 1216 # proc ::imap4::idle notify-command 1217 # proc ::imap4::auth plain ... 1218 # proc ::imap4::securestauth user pass 1219 # proc ::imap4::store 1220 # proc ::imap4::logout (need to clean both msg and mailbox info arrays) 1221} 1222 1223################################################################################ 1224# Example and test 1225################################################################################ 1226if {[info exists argv0] && [info script] eq $argv0} { 1227 # set imap4::debug 0 1228 set FOLDER INBOX 1229 set port 0 1230 if {[llength $argv] < 3} { 1231 puts "Usage: imap4.tcl <server> <user> <pass> ?folder? ?-secure? ?-debug?" 1232 exit 1233 } 1234 1235 lassign $argv server user pass 1236 if {$argc > 3} { 1237 for {set i 3} {$i<$argc} {incr i} { 1238 set opt [lindex $argv $i] 1239 switch -- $opt { 1240 "-debug" { 1241 set imap4::debug 1 1242 } 1243 "-secure" { 1244 set imap4::use_ssl 1 1245 puts "Package TLS [package require tls] loaded" 1246 } 1247 default { 1248 set FOLDER $opt 1249 } 1250 } 1251 } 1252 } 1253 1254 # open and login ... 1255 set imap [imap4::open $server] 1256 imap4::login $imap $user $pass 1257 1258 imap4::select $imap $FOLDER 1259 # Output all the information about that mailbox 1260 foreach info [imap4::mboxinfo $imap] { 1261 puts "$info -> [imap4::mboxinfo $imap $info]" 1262 } 1263 set num_mails [imap4::mboxinfo $imap exists] 1264 if {!$num_mails} { 1265 puts "No mail in folder '$FOLDER'" 1266 } else { 1267 set fields {from: to: subject: size} 1268 # fetch 3 records (at most)) inline 1269 set max [expr {$num_mails<=3?$num_mails:3}] 1270 foreach rec [imap4::fetch $imap :$max -inline {*}$fields] { 1271 puts -nonewline "#[incr idx])" 1272 for {set j 0} {$j<[llength $fields]} {incr j} { 1273 puts "\t[lindex $fields $j] [lindex $rec $j]" 1274 } 1275 } 1276 1277 # Show all the information available about the message ID 1 1278 puts "Available info about message 1 => [imap4::msginfo $imap 1]" 1279 } 1280 1281 # Use the capability stuff 1282 puts "Capabilities: [imap4::isableto $imap]" 1283 puts "Is able to imap4rev1? [imap4::isableto $imap imap4rev1]" 1284 if {$imap4::debug} { 1285 imap4::debugmode $imap 1286 } 1287 1288 # Cleanup 1289 imap4::cleanup $imap 1290} 1291