# IMAP4 protocol pure Tcl implementation. # # COPYRIGHT AND PERMISSION NOTICE # # Copyright (C) 2004 Salvatore Sanfilippo . # # All rights reserved. # # Permission is hereby granted, free of charge, to any person obtaining a # copy of this software and associated documentation files (the # "Software"), to deal in the Software without restriction, including # without limitation the rights to use, copy, modify, merge, publish, # distribute, and/or sell copies of the Software, and to permit persons # to whom the Software is furnished to do so, provided that the above # copyright notice(s) and this permission notice appear in all copies of # the Software and that both the above copyright notice(s) and this # permission notice appear in supporting documentation. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS # OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT # OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR # HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL # INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING # FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, # NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION # WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. # # Except as contained in this notice, the name of a copyright holder # shall not be used in advertising or otherwise to promote the sale, use # or other dealings in this Software without prior written authorization # of the copyright holder. # # $Id: imap4.tcl,v 1.2 2004/06/22 17:47:46 mic42 Exp $ # TODO # - option -inline for ::imap4::fetch, in order to return data as a Tcl list. # - Idle mode # - Async mode # - Authentications # - Literals on file mode # - isableto without arguments should return the capability list. # - fix OR in search, and implement time-related searches # All the rest... se the RFC package require Tcl 8.4 package require struct::list 1.4 namespace eval ::imap4 { # This is where we take state of all the IMAP connections. # The following arrays are indexed with the connection channel # to access the per-channel information. # general connection state info variable info array set info {} # selected mailbox info variable mboxinfo array set mboxinfo {} # messages info variable msginfo array set msginfo {} # inside debug mode? default is off variable debugmode 0 # Debug mode? Don't use it for production! It will print debugging # information to standard output and run a special IMAP debug mode shell # on protocol error. variable debug 1 # Version variable version "2004-03-07" } # imap4::open -- # # Open a new IMAP connection and initialize the protocol handler. # # Arguments: # hostname Hostname of the IMAP server to use # port Port to use (defaults to 143) # # Results: # chan Identifier for IMAP channel # proc ::imap4::open {hostname {port 143}} { set chan [socket $hostname $port] fconfigure $chan -encoding binary -translation binary # Intialize the connection state array ::imap4::initinfo $chan # Get the banner ::imap4::processline $chan # Save the banner set ::imap4::info($chan,banner) [::imap4::lastline $chan] return $chan } # imap4::cleanup -- # # Cleanup the internal state and close the IMAP channel. # # Arguments: # chan Identifier for IMAP channel # # Results: # chan Identifier for close IMAP channel # proc ::imap4::cleanup chan { variable info variable mboxinfo variable msginfo close $chan array unset info $chan,* array unset mboxinfo $chan,* array unset msginfo $chan,* return $chan } # imap4::lastcode -- # # Return the last error code for the IMAP channel. # # Arguments: # chan Identifier for IMAP channel # # Results: # code Last error code for the given channel # proc ::imap4::lastcode chan { variable info return $info($chan,lastcode) } # imap4::lastline -- # # Return the last line received from the server. # # Arguments: # chan Identifier for IMAP channel # # Results: # line Last line received from the server # proc ::imap4::lastline chan { variable info return $info($chan,lastline) } # imap4::state -- # # Get the current state # # Arguments: # chan Identifier for IMAP channel # # Results: # state Current state of the channel # proc ::imap4::state chan { variable info return $info($chan,state) } # imap4::isableto -- # # Test for capability. Use the capability command # to ask the server if not already done by the user. # # Arguments: # chan Identifier for IMAP channel # capa Capability to check # # Results: # 1/0 1 if supported, 0 otherwise # proc ::imap4::isableto {chan capa} { variable info if {![llength $info($chan,capability)]} { if {[::imap4::capability $chan]} { # mic42 FIXME: This looks strange, # should probably be an error, as this signals the # capabilities request failed # return 1 } } set capa [string toupper $capa] expr {[lsearch -exact $info($chan,capability) $capa] != -1} } # imap4::msginfo -- # # Get information (previously collected using fetch) from a given message. # If the 'info' argument is omitted or a null string, the full list # of information available for the given message is returned. # # If the required information name is suffixed with a ? character, # the command requires true if the information is available, or # false if it is not. # # Arguments: # chan Identifier for IMAP channel # msgid Message identifier # info Type of info (optional) # default default value for info # # Results: # msginfo The message info requested or # list of all valid info values if info and default # are missing. # proc ::imap4::msginfo {chan msgid args} { variable msginfo switch -- [llength $args] { 0 { set info {} } 1 { set info [lindex $args 0] set use_defval 0 } 2 { set info [lindex $args 0] set defval [lindex $args 1] set use_defval 1 } default { error "::imap4::msginfo called with bad number of arguments! Try ::imap4::msginfo channel messageid ?info? ?defaultvalue?" } } set info [string tolower $info] # Handle the missing info case if {![string length $info]} { set list [array names msginfo $chan,$msgid,*] set availinfo {} foreach l $list { lappend availinfo [string range $l \ [string length $chan,$msgid,] end] } return $availinfo } if {[string index $info end] eq {?}} { set info [string range $info 0 end-1] return [info exists msginfo($chan,$msgid,$info)] } else { if {![info exists msginfo($chan,$msgid,$info)]} { if {$use_defval} { return $defval } else { error "No such information '$info' available for message id '$msgid'" } } return $msginfo($chan,$msgid,$info) } } # imap4::mboxinfo -- # # Get information on the currently selected mailbox. # If the 'info' argument is omitted or a null string, the full list # of information available for the mailbox is returned. # # If the required information name is suffixed with a ? character, # the command requires true if the information is available, or # false if it is not. # # Arguments: # chan Identifier for IMAP channel # info type of info requested, defaults to {} # # Results: # mboxinfo Information about the selected mailbox # proc ::imap4::mboxinfo {chan {info {}}} { set info [string tolower $info] # Handle the missing info case if {![string length $info]} { set list [array names ::imap4::mboxinfo $chan,*] set availinfo {} foreach l $list { lappend availinfo [string range $l \ [string length $chan,] end] } return $availinfo } if {[string index $info end] eq {?}} { set info [string range $info 0 end-1] return [info exists ::imap4::mboxinfo($chan,$info)] } else { if {![info exists ::imap4::mboxinfo($chan,$info)]} { error "No such information '$info' available for the current mailbox" } return $::imap4::mboxinfo($chan,$info) } } ############################################################################### # # Helper procs # ############################################################################### # imap4::initinfo -- # # Initialize the per connection info array for a new # IMAP connection. # # Arguments: # chan Identifier for IMAP channel # # Results: # none proc ::imap4::initinfo chan { variable info set info($chan,curtag) 0 set info($chan,state) NOAUTH set info($chan,capability) {} set info($chan,raise_on_NO) 1 set info($chan,raise_on_BAD) 1 set info($chan,idle) {} set info($chan,lastcode) {} set info($chan,lastline) {} set info($chan,lastrequest) {} return } ############################################################################### # # Implementations of IMAP protocol commands. # # ############################################################################### # imap4::capability -- # # Get capabilties, issues a # CAPABILITY command to the server. # # Arguments: # chan Identifer for IMAP channel # # Results: # 0/1 0 if successful, 1 otherwise # proc ::imap4::capability chan { ::imap4::request $chan "CAPABILITY" if {[::imap4::getresponse $chan]} { return 1 } return 0 } # imap4::check -- # # CHECK. Flush to disk. # # Arguments: # chan Identifier for IMAP channel # # Results: # 0/1 # proc ::imap4::check chan { ::imap4::simplecmd $chan CHECK SELECT {} } # imap4::close -- # # Close the mailbox. Permanently removes \Deleted messages and return to # the AUTH state. # # Arguments: # chan Identifier for IMAP channel # # Results: # 0/1 # # Side Effects: # sets the state info # proc ::imap4::close chan { if {[::imap4::simplecmd $chan CLOSE SELECT {}]} { return 1 } set ::imap4::info($chan,state) AUTH return 0 } # imap4::create -- # # Create a new mailbox. # # Arguments: # chan Identifier for IMAP channel # mailbox Mailbox name # # Results: # 0/1 # proc ::imap4::create {chan mailbox} { ::imap4::simplecmd $chan CREATE {AUTH SELECT} $mailbox } # imap4::delete -- # # Delete a mailbox # # Arguments: # chan Identifier for IMAP channel # mailbox Mailbox name # # Results: # 0/1 # proc ::imap4::delete {chan mailbox} { ::imap4::simplecmd $chan DELETE {AUTH SELECT} $mailbox } # imap4::examine -- # # Read-only equivalent of SELECT, uses the # EXAMINE command. # # Arguments: # chan Identifier for IMAP channel # mailbox Name of the mailbox to examine, # defaults to INBOX. # # Results: # 0/1 0 if successful, 1 otherwise # proc ::imap4::examine {chan {mailbox INBOX}} { ::imap4::selectmbox $chan EXAMINE $mailbox } # imap4::fetch -- # # Fetch a number of attributes from messages # # Arguments: # chan Identifier for IMAP channel # range IMAP range to fetch # args list of attributes to fetch # # Results: # 0/1 0 if successful, 1 otherwise # # Side Effects: # proc ::imap4::fetch {chan range args} { ::imap4::requirestate $chan SELECT ::imap4::parserange $chan $range start end set items {} set hdrfields {} foreach w $args { switch -glob -- [string toupper $w] { ALL {lappend items ALL} BODYSTRUCTURE {lappend items BODYSTRUCTURE} ENVELOPE {lappend items ENVELOPE} FLAGS {lappend items FLAGS} SIZE {lappend items RFC822.SIZE} TEXT {lappend items RFC822.TEXT} HEADER {lappend items RFC822.HEADER} UID {lappend items UID} *: { lappend hdrfields $w } default { # Fixme: better to raise an error here? lappend hdrfields $w: } } } if {[llength $hdrfields]} { set item {BODY[HEADER.FIELDS (} foreach field $hdrfields { append item [string toupper [string range $field 0 end-1]] { } } set item [string range $item 0 end-1] append item {)]} lappend items $item } # Send the request ::imap4::request $chan "FETCH $start:$end ([join $items])" if {[::imap4::getresponse $chan]} { return 1 } return 0 } # imap4::login -- # # Login using the IMAP LOGIN command. # # Arguments: # chan Identifier for IMAP channel # user Username to use for LOGIN # pass Password to use for LOGIN # # Results: # 0/1 0 if successful, 1 otherwise # # Side Effects: # move channel to AUTH state if successful # proc ::imap4::login {chan user pass} { ::imap4::requirestate $chan NOAUTH ::imap4::request $chan "LOGIN $user $pass" if {[::imap4::getresponse $chan]} { return 1 } set ::imap4::info($chan,state) AUTH return 0 } # imap4::noop -- # # NOOP command. May get information as untagged data. # Useful for keeping an IMAP connection alive. # # Arguments: # chan Identifier for IMAP channel # # Results: # 0/1 # # Side Effects: # may get information as untagged data # proc ::imap4::noop chan { ::imap4::simplecmd $chan NOOP {NOAUTH AUTH SELECT} {} } # imap4::rename -- # # Rename a mailbox # # Arguments: # chan Identifier for IMAP channel # oldname Name of mailbox to rename # newname New name of mailbox # # Results: # 0/1 # proc ::imap4::rename {chan oldname newname} { ::imap4::simplecmd $chan RENAME {AUTH SELECT} $oldname $newname } # imap4::search -- # # SEARCH command. # # Arguments: # chan Identifier for IMAP channel # args search arguments # # Results: # 0/1 # proc ::imap4::search {chan args} { if {![llength $args]} { error "missing arguments. Usage: ::imap4::search chan arg ?arg ...?" } ::imap4::requirestate $chan SELECT set imapexpr [::imap4::convert_search_expr $args] ::imap4::multiline_prefix_command imapexpr "SEARCH" ::imap4::multiline_request $chan $imapexpr if {[::imap4::getresponse $chan]} { return 1 } return 0 } # imap4::select -- # # Mailbox selection. Performs a SELECT command. # # Arguments: # chan Identifier for IMAP channel # mailbox Name of the mailbox to select, # defaults to INBOX. # # Results: # 0/1 0 if successful, 1 otherwise # proc ::imap4::select {chan {mailbox INBOX}} { ::imap4::selectmbox $chan SELECT $mailbox } # imap4::subscribe -- # # Subscribe to a mailbox # # Arguments: # chan Identifier for IMAP channel # mailbox Name of mailbox # # Results: # 0/1 # proc ::imap4::subscribe {chan mailbox} { ::imap4::simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox } # imap4::unsubscribe -- # # Unsubscribe to a mailbox # # Arguments: # chan Identifier for IMAP channel # mailbox Name of a mailbox # # Results: # 0/1 # proc ::imap4::unsubscribe {chan mailbox} { ::imap4::simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox } ############################################################################### # # Protocol support functions # ############################################################################### # imap4::literalcount -- # # Creates an IMAP octect-count. # Used to send literals. # # Arguments: # string string to check # # Results: # litcount IMAP literal octet count # proc ::imap4::literalcount string { return "{[string length $string]}" } # imap4::convert_search_expr -- # # Helper for the search command. Convert a programmer friendly expression # (actually a tcl list) to the IMAP syntax. Returns a list composed of # request, literal, request, literal, ... (to be sent with # ::imap4::multiline_request). # # Arguments: # expr Expression to use for search expression # # Results: # imapexpr IMAP search expression # proc ::imap4::convert_search_expr expr { set result {} while {[llength $expr]} { switch -glob -- [string toupper [set token [::struct::list shift expr]]] { *: { set wanted [::struct::list shift expr] ::imap4::multiline_append_command result "HEADER [string range $token 0 end-1]" ::imap4::multiline_append_literal result $wanted } ANSWERED - DELETED - DRAFT - FLAGGED - RECENT - SEEN - NEW - OLD - UNANSWERED - UNDELETED - UNDRAFT - UNFLAGGED - UNSEEN - ALL {::imap4::multiline_append_command result [string toupper $token]} BODY - CC - FROM - SUBJECT - TEXT - KEYWORD - BCC { set wanted [::struct::list shift expr] ::imap4::multiline_append_command result "$token" ::imap4::multiline_append_literal result $wanted } OR { set first [::imap4::convert_search_expr [::struct::list shift expr]] set second [::imap4::convert_search_expr [::struct::list shift expr]] ::imap4::multiline_append_command result "OR" ::imap4::multiline_concat_expr result $first ::imap4::multiline_concat_expr result $second } NOT { set e [::imap4::convert_search_expr [::struct::list shift expr]] ::imap4::multiline_append_command result "NOT" ::imap4::multiline_concat_expr result $e } SMALLER - LARGER { set len [::struct::list shift expr] if {![string is integer $len]} { error "Invalid integer follows '$token' in IMAP search" } ::imap4::multiline_append_command result "$token $len" } ON - SENTBEFORE - SENTON - SENTSINCE - SINCE - BEFORE {error "TODO"} UID {error "TODO"} default { error "Syntax error in search expression: '... $token $expr'" } } } return $result } # imap4::multiline_append_command -- # # Append a command part to a multiline request # # Arguments: # reqvar Variable storing the request # cmd command to append # # Results: # none # proc ::imap4::multiline_append_command {reqvar cmd} { upvar 1 $reqvar req if {[llength $req] == 0} { lappend req {} } lset req end "[lindex $req end] $cmd" } # imap4::multiline_append_literal -- # # Append a literal to a multiline request. Uses a quoted # string in simple cases. # # Arguments: # reqvar Variable storing the request # lit literal to append # # Results: # none # proc ::imap4::multiline_append_literal {reqvar lit} { upvar 1 $reqvar req if {![string is alnum $lit]} { lset req end "[lindex $req end] [::imap4::literalcount $lit]" lappend req $lit {} } else { ::imap4::multiline_append_command req "\"$lit\"" } } # imap4::multiline_prefix_command -- # # Prefix a multiline request with a command. # # Arguments: # reqvar Variable storing the request # cmd Command to prepend # # Results: # none # proc ::imap4::multiline_prefix_command {reqvar cmd} { upvar 1 $reqvar req if {![llength $req]} { lappend req {} } lset req 0 " $cmd[lindex $req 0]" } # imap4::multiline_concat_expr -- # # Concat an already created search expression to a multiline request. # # Arguments: # reqvar Variable storing the request # expr expression to append # # Results: # ? # proc ::imap4::multiline_concat_expr {reqvar expr} { upvar 1 $reqvar req lset req end "[lindex $req end] ([string range [lindex $expr 0] 1 end]" set req [concat $req [lrange $expr 1 end]] lset req end "[lindex $req end])" } # imap4::simplecmd -- # # This a general implementation for a simple implementation # of an IMAP command that just requires to call ::imap4::request # and ::imap4::getresponse. # # Arguments: # chan Identifier for IMAP channel # command IMAP command # validstates The valid states for this command # args Arguments to the IMAP command # proc ::imap4::simplecmd {chan command validstates args} { ::imap4::requirestate $chan $validstates set req "$command" foreach arg $args { append req " $arg" } ::imap4::request $chan $req if {[::imap4::getresponse $chan]} { return 1 } return 0 } # imap4::selectmbox -- # # General function for mailbox selection. # # Arguments: # chan Identifier for IMAP channel # cmd IMAP command to use # mailbox Name of mailbox to use # # Results: # 0/1 0 if successful, 1 otherwise # # Side Effects: # move to SELECT state if successful # proc ::imap4::selectmbox {chan cmd mailbox} { ::imap4::requirestate $chan AUTH # Clean info about the previous mailbox if any, # but save a copy to restore this info on error. set savedmboxinfo [array get ::imap4::mboxinfo $chan,*] array unset ::imap4::mboxinfo $chan,* ::imap4::request $chan "$cmd $mailbox" if {[::imap4::getresponse $chan]} { array set ::imap4::mboxinfo $savedmboxinfo return 1 } set ::imap4::info($chan,state) SELECT # Set the new name as mbox->current. set ::imap4::mboxinfo($chan,current) $mailbox return 0 } # imap4::tag -- # # Return the next tag to use in IMAP requests. # # Arguments: # chan Identifier for IMAP channel # # Results: # tag A valid tag for an IMAP request # proc ::imap4::tag chan { incr ::imap4::info($chan,curtag) } # imap4::checkstate -- # # Check that the channel is in one of the specified states. # # Arguments: # chan Identifier for IMAP channel # states List of states # # Results: # bool Either 1 or 0. # proc ::imap4::checkstate {chan states} { expr {[lsearch -exact $states $::imap4::info($chan,state)] == -1} } # imap4::requirestate -- # # Asserts that the channel is in one of the specified states. # # Arguments: # chan Identifier for IMAP channel # states List of states # # Results: # none # # Side Effects: # An error is raised if the channel is not in one # of the states in the states list. # proc ::imap4::requirestate {chan states} { if {[checkstate $chan $states]} { error "IMAP channel not in one of the following states: '$state' (current state is '$::imap4::info($chan,state)')" } } ############################################################################## # # procs for decoding IMAP responses and general processing # ############################################################################## # imap4::processline -- # # Process an IMAP response line. # This function trades simplicity in IMAP commands # implementation with monolitic handling of responses. # However note that the IMAP server can reply to a command # with many different untagged info, so to have the reply # processing centralized makes this simple to handle. # # Arguments: # chan Identifier for IMAP channel # # Results: # tag Tag found on the line # proc ::imap4::processline chan { set literals {} while 1 { # Read a line if {[gets $chan buf] == -1} { error "IMAP unexpected EOF from server." } append line $buf # Remove the trailing CR at the end of the line, if any. if {[string index $line end] eq "\r"} { set line [string range $line 0 end-1] } # Check if there is a literal to read, and read it if any. if {[regexp {{([0-9]+)}\s+$} $buf => length]} { # puts "Reading $length bytes of literal..." lappend literals [read $chan $length] } else { break } } set ::imap4::info($chan,lastline) $line if {$::imap4::debug} { puts "S: $line" } # Extract the tag. set idx [string first { } $line] if {$idx == -1 || $idx == 0} { ::imap4::protoerror $chan "IMAP: malformed response '$line'" } set tag [string range $line 0 [expr {$idx-1}]] set line [string range $line [expr {$idx+1}] end] # If it's just a command continuation response, return. if {$tag eq {+}} {return +} # Extract the error code, if it's a tagged line if {$tag ne {*}} { set idx [string first { } $line] if {$idx == -1 || $idx == 0} { ::imap4::protoerror $chan "IMAP: malformed response '$line'" } set code [string range $line 0 [expr {$idx-1}]] set line [string trim [string range $line [expr {$idx+1}] end]] set ::imap4::info($chan,lastcode) $code } # Extract information from the line set dirty 0 switch -glob -- $line { {*\[READ-ONLY\]*} {set ::imap4::mboxinfo($chan,perm) READ-ONLY; incr dirty} {*\[READ-WRITE\]*} {set ::imap4::mboxinfo($chan,perm) READ-WRITE; incr dirty} {*\[TRYCREATE\]*} {set ::imap4::mboxinfo($chan,perm) TRYCREATE; incr dirty} {FLAGS *(*)*} { regexp {.*\((.*)\).*} $line => flags set ::imap4::mboxinfo($chan,flags) $flags incr dirty } {*\[PERMANENTFLAGS *(*)*\]*} { regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags set ::imap4::mboxinfo($chan,permflags) $flags incr dirty } } if {!$dirty && $tag eq {*}} { # FIXME: match should be case insensitive. switch -regexp -- $line { {^[0-9]+\s+EXISTS} { regexp {^([0-9]+)\s+EXISTS} $line => ::imap4::mboxinfo($chan,exists) incr dirty } {^[0-9]+\s+RECENT} { regexp {^([0-9]+)\s+RECENT} $line => ::imap4::mboxinfo($chan,recent) incr dirty } {.*?\[UIDVALIDITY\s+[0-9]+?\]} { regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \ ::imap4::mboxinfo($chan,uidval) incr dirty } {.*?\[UNSEEN\s+[0-9]+?\]} { regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \ ::imap4::mboxinfo($chan,unseen) incr dirty } {.*?\[UIDNEXT\s+[0-9]+?\]} { regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \ ::imap4::mboxinfo($chan,uidnext) incr dirty } {^[0-9]+\s+FETCH} { processfetchline $chan $line $literals incr dirty } {^CAPABILITY\s+.*} { regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring set ::imap4::info($chan,capability) [split [string toupper $capstring]] incr dirty } {^SEARCH\s*$} { # Search tag without list of messages. Nothing found # so we set an empty list. set ::imap4::mboxinfo($chan,found) {} } {^SEARCH\s+.*} { regexp {^SEARCH\s+(.*)\s*$} $line => foundlist set ::imap4::mboxinfo($chan,found) $foundlist incr dirty } default { if {$::imap4::debug} { puts "*** WARNING: unprocessed server reply '$line'" } } } } if {[string length [set ::imap4::info($chan,idle)]] && $dirty} { # ... Notify. } # if debug and no dirty and untagged line... warning: unprocessed IMAP line return $tag } # imap4::processfetchline -- # # Process untagged FETCH lines. # # Arguments: # chan Identifier for IMAP channel # line Line to process # literals IMAP literals (?) # # Results: # ? # # Side Effects: # Fills in the msginfo # proc ::imap4::processfetchline {chan line literals} { regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items foreach {name val} [imaptotcl items literals] { set attribname [switch -glob -- [string toupper $name] { INTERNALDATE {format internaldate} BODYSTRUCTURE {format bodystructure} {BODY\[HEADER.FIELDS*\]} {format fields} {BODY.PEEK\[HEADER.FIELDS*\]} {format fields} {BODY\[*\]} {format body} {BODY.PEEK\[*\]} {format body} HEADER {format header} RFC822.HEADER {format header} RFC822.SIZE {format size} RFC822.TEXT {format text} ENVELOPE {format envelope} FLAGS {format flags} UID {format uid} default { ::imap4::protoerror $chan "IMAP: Unknown FETCH item '$name'. Upgrade the software" } }] switch -- $attribname { fields { set last_fieldname __garbage__ foreach f [split $val "\n\r"] { # Handle multi-line headers. Append to the last header # if this line starts with a tab character. if {[string is space [string index $f 0]]} { append ::imap4::msginfo($chan,$msgnum,$last_fieldname) " [string range $f 1 end]" continue } # Process the line searching for a new field. if {![string length $f]} continue if {[set fnameidx [string first ":" $f]] == -1} { ::imap4::protoerror $chan "IMAP: Not a valid RFC822 field '$f'" } set fieldname [string tolower [string range $f 0 $fnameidx]] set last_fieldname $fieldname set fieldval [string trim \ [string range $f [expr {$fnameidx+1}] end]] set ::imap4::msginfo($chan,$msgnum,$fieldname) $fieldval } } default { set ::imap4::msginfo($chan,$msgnum,$attribname) $val } } #puts "$attribname -> [string range $val 0 20]" } } # imap4::parserange -- # # Parse an IMAP range, store 'start' and 'end' in the # named vars. If the first number of the range is omitted, # 1 is assumed. If the second number of the range is omitted, # the value of "exists" of the current mailbox is assumed. # # So : means all the messages. # # Arguments: # chan Identifier for IMAP channel # range range to parse # startvar variable to store the start in # endvar variable to store the end in # # Results: # none # # Side Effects: # results are stored in startvar and endvar # proc ::imap4::parserange {chan range startvar endvar} { upvar $startvar start $endvar end set rangelist [split $range :] switch -- [llength $rangelist] { 1 { if {![string is integer $range]} { error "Invalid range" } set start $range set end $range } 2 { foreach {start end} $rangelist break if {![string length $start]} { set start 1 } if {![string length $end]} { set end [::imap4::mboxinfo $chan exists] } if {![string is integer $start] || ![string is integer $end]} { error "Invalid range" } } default { error "Invalid range" } } } # imap4::imaptotcl -- # # Convert IMAP data into Tcl data. Consumes the part of the # string converted. # 'literals' is a list with all the literals extracted # from the original line, in the same order they appeared. # # Arguments: # datavar variable holding the data to parse # literalsvar variable holding the literals # # Results: # ? # # Side Effects: # consumes data from datavar # proc ::imap4::imaptotcl {datavar literalsvar} { upvar 1 $datavar data $literalsvar literals set data [string trim $data] switch -- [string index $data 0] { \{ {imaptotcl_literal data literals} "(" {imaptotcl_list data literals} "\"" {imaptotcl_quoted data} 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number data} \) {imaptotcl_endlist data;# that's a trick to parse lists} default {imaptotcl_symbol data} } } # imap4::imaptotcl_literal -- # # Extract a literal # # Arguments: # datavar variable holding the data to parse # literalsvar variable holding the literals # # Results: # ? # # Side Effects: # consumes data from datavar # proc ::imap4::imaptotcl_literal {datavar literalsvar} { upvar 1 $datavar data $literalsvar literals if {![regexp {{.*?}} $data match]} { ::imap4::protoerror $chan "IMAP data format error: '$data'" } set data [string range $data [string length $match] end] set retval [lindex $literals 0] set literals [lrange $literals 1 end] return $retval } # imap4::imaptotcl_quoted -- # # Extract a quoted string # # Arguments: # datavar variable holding the data to parse # # Results: # string The extracted string # # Side Effects: # consumes data from datavar # proc ::imap4::imaptotcl_quoted datavar { upvar 1 $datavar data if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} { ::imap4::protoerror $chan "IMAP data format error: '$data'" } set data [string range $data [string length $match] end] return [string range $match 1 end-1] } # imap4::imaptotcl_number -- # # Extract a number # # Arguments: # datavar variable holding the data to parse # # Results: # number An integer number # # Side Effects: # consumes data from datavar # proc imaptotcl_number datavar { upvar 1 $datavar data if {![regexp {^[0-9]+} $data match]} { ::imap4::protoerror $chan "IMAP data format error: '$data'" } set data [string range $data [string length $match] end] return $match } # imap4::imaptotcl_symbol -- # # Extract a "symbol". Not really exists in IMAP, but there # are named items, and this names have a strange unquoted # syntax like BODY[HEAEDER.FIELD (From To)] and other stuff # like that. # # Arguments: # datavar variable holding the data to parse # # Results: # match The symbol found # # Side Effects: # consume data from datavar # proc ::imap4::imaptotcl_symbol datavar { upvar 1 $datavar data if {![regexp {([\w\.]+\[[^\[]+\]|[\w\.]+)} $data => match]} { ::imap4::protoerror $chan "IMAP data format error: '$data'" } set data [string range $data [string length $match] end] return $match } # imap4::imaptotcl_list -- # # Extract an IMAP list. # # Arguments: # datavar variable holding the data to parse # literalsvar variable holding the literals # # Results: # ? # # Side Effects: # consumes data from datavar # proc ::imap4::imaptotcl_list {datavar literalsvar} { upvar 1 $datavar data $literalsvar literals set list {} # Remove the first '(' char set data [string range $data 1 end] # Get all the elements of the list. May indirectly recurse called # by [imaptotcl]. while {[string length $data]} { set ele [imaptotcl data literals] if {$ele eq {)}} { break } lappend list $ele } return $list } # imap4::imaptotcl_endlist -- # # Just extracts the ")" character alone. # This is actually part of the list extraction work. # # Arguments: # datavar variable holding the data to parse # # Results: # char The character "(" # # Side Effects: # consumes data from datavar # proc ::imap4::imaptotcl_endlist datavar { upvar 1 $datavar data set data [string range $data 1 end] return ")" } ###################################################################### # # procs for communication with server # ###################################################################### # imap4::request -- # # Write a request to the IMAP channel. # # Arguments: # chan Identifier for IMAP channel # request Request to send # # Results: # none # proc ::imap4::request {chan request} { set t "[::imap4::tag $chan] $request" if {$::imap4::debug} { puts "C: $t" } set ::imap4::info($chan,lastrequest) $t puts -nonewline $chan "$t\r\n" flush $chan } # imap4::multiline_request -- # # Write a multiline request. The 'request' list must contain # parts of command and literals interleaved. Literals are at odd # list positions (1, 3, ...). # # Arguments: # chan Identifier for IMAP channel # request request list # # Results: # none # proc ::imap4::multiline_request {chan request} { lset request 0 "[::imap4::tag $chan][lindex $request 0]" set items [llength $request] foreach {line literal} $request { # Send the line if {$::imap4::debug} { puts "C: $line" } puts -nonewline $chan "$line\r\n" flush $chan incr items -1 if {!$items} break # Wait for the command continuation response if {[::imap4::processline $chan] ne {+}} { ::imap4::protoerror $chan "Expected a command continuation response but got '[::imap4::lastline $chan]'" } # Send the literal if {$::imap4::debug} { puts "C> $literal" } puts -nonewline $chan $literal flush $chan incr items -1 } set ::imap4::info($chan,lastrequest) $request } # imap4::getresponse -- # # Process IMAP responses. If the IMAP channel is not # configured to raise errors on IMAP errors, returns 0 # on OK response, otherwise 1 is returned. # # Arguments: # chan Identifier for IMAP channel # # Results: # 0/1 0 for BAD/NO , 1 for OK # # Side Effects: # may raise errors # proc ::imap4::getresponse chan { # Process lines until the tagged one. while {[set tag [::imap4::processline $chan]] eq {*} || $tag eq {+}} {} switch -- [::imap4::lastcode $chan] { OK {return 0} NO { if {$::imap4::info($chan,raise_on_NO)} { error "IMAP error: [::imap4::lastline $chan]" } return 1 } BAD { if {$::imap4::info($chan,raise_on_BAD)} { ::imap4::protoerror $chan "IMAP error: [::imap4::lastline $chan]" } return 1 } default { ::imap4::protoerror $chan "IMAP protocol error. Unknown response code '[::imap4::lastcode $chan]'" } } } ######################################################################################## # # Debug and example code # ######################################################################################## # Debug mode. # This is a developers mode only that pass the control to the # programmer. Every line entered is sent verbatim to the # server (after the addition of the request identifier). # The ::imap4::debug variable is automatically set to '1' on enter. # # It's possible to execute Tcl commands starting the line # with a slash. proc ::imap4::debugmode {chan {errormsg {None}}} { set ::imap4::debugmode 1 set ::imap4::debugchan $chan set welcometext [list \ "------------------------ IMAP DEBUG MODE --------------------" \ "IMAP Debug mode usage: Every line typed will be sent" \ "verbatim to the IMAP server prefixed with a unique IMAP tag." \ "To execute Tcl commands prefix the line with a / character." \ "The current debugged channel is returned by the \[me\] command." \ "Type ! to exit" \ "Type help for more information" \ "Type info to see information about the connection" \ "" \ "Last error: '$errormsg'" \ "IMAP library version: '$imap4::version'" \ "" \ ] foreach l $welcometext { puts $l } ::imap4::debugmode_info $chan while 1 { puts -nonewline "imap debug> " flush stdout gets stdin line if {![string length $line]} continue if {$line eq {!}} exit if {$line eq {info}} { ::imap4::debugmode_info $chan continue } if {[string index $line 0] eq {/}} { catch {eval [string range $line 1 end]} result puts $result } else { ::imap4::request $chan $line if {[catch {::imap4::getresponse $chan} error]} { puts "--- ERROR ---\n$error\n-------------\n" } } } } # Little helper for debugmode command. proc ::imap4::debugmode_info chan { puts "Last sent request: '$imap4::info($chan,lastrequest)'" puts "Last received line: '$imap4::info($chan,lastline)'" puts "" } # Protocol error! Enter the debug mode if ::imap4::debug is true. # Otherwise just raise the error. proc ::imap4::protoerror {chan msg} { if {$::imap4::debug && !$::imap4::debugmode} { ::imap4::debugmode $chan $msg } else { error $msg } } proc ::imap4::me {} { set ::imap4::debugchan } # Other stuff to do in random order... # # proc ::imap4::idle notify-command # proc ::imap4::auth plain ... # proc ::imap4::securestauth user pass # proc ::imap4::store # proc ::imap4::logout (need to clean both msg and mailbox info arrays) # proc ::imap4::create # proc ::imap4::delete # proc ::imap4::list # ::imap4::search $chan or {flags {seen flagged}} {larger 1000} # ::imap4::search $chan from: antirez to: ... ################################################################################ # Example ################################################################################ set ::imap4::debug 0 if {[llength $argv] < 3} { puts "Usage: imap4.tcl ?-debugmode?" exit } if {[llength $argv] > 3} { est ::imap4::debug 1 } foreach {servername username password} $argv break # Star the connection and select the INBOX mailbox set imap [::imap4::open $servername] ::imap4::login $imap $username $password ::imap4::select $imap INBOX # Output all the information about that mailbox foreach info [::imap4::mboxinfo $imap] { puts "$info -> [::imap4::mboxinfo $imap $info]" } # Fetch from: to: and size for all the messages ::imap4::fetch $imap : from: to: size header bodystructure # Show they for {set i 1} {$i <= [::imap4::mboxinfo $imap exists]} {incr i} { puts "$i) To: [::imap4::msginfo $imap $i to: {No To: field}]" set bstruct [::imap4::msginfo $imap $i bodystructure] if {[string toupper [lindex $bstruct 0]] eq {TEXT}} { set bstruct [list $bstruct] } foreach entry $bstruct { puts "\t$entry" } } # Show all the information available about the message ID 1 puts "Available info about message 1: [::imap4::msginfo $imap 1]" # Use the capability stuff ::imap4::capability $imap puts "Is able to idle? [::imap4::isableto $imap idle]" puts "Is able to jump? [::imap4::isableto $imap jump]" puts "Is able to imap4rev1? [::imap4::isableto $imap imap4rev1]" # Show the search feature. ::imap4::search $imap larger 4000 seen puts "Found messages: [::imap4::mboxinfo $imap found]" # Enter the debug mode for fun or development time ::imap4::debugmode $imap # Cleanup ::imap4::cleanup $imap