diff options
Diffstat (limited to 'tcllib/modules/imap4/imap4.tcl')
| -rw-r--r-- | tcllib/modules/imap4/imap4.tcl | 1382 |
1 files changed, 1382 insertions, 0 deletions
diff --git a/tcllib/modules/imap4/imap4.tcl b/tcllib/modules/imap4/imap4.tcl new file mode 100644 index 0000000..460c065 --- /dev/null +++ b/tcllib/modules/imap4/imap4.tcl @@ -0,0 +1,1382 @@ +# IMAP4 protocol pure Tcl implementation. +# +# COPYRIGHT AND PERMISSION NOTICE +# +# Copyright (C) 2004 Salvatore Sanfilippo <antirez@invece.org>. +# Copyright (C) 2013 Nicola Hall <nicci.hall@gmail.com> +# Copyright (C) 2013 Magnatune <magnatune@users.sourceforge.net> +# +# 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. + +# TODO +# - Idle mode +# - Async mode +# - Authentications +# - Literals on file mode +# - fix OR in search, and implement time-related searches +# All the rest... see the RFC + +# History +# 20100623: G. Reithofer, creating tcl package 0.1, adding some todos +# option -inline for ::imap4::fetch, in order to return data as a Tcl list +# isableto without arguments returns the capability list +# implementation of LIST command +# 20100709: Adding suppport for SSL connections, namespace variable +# use_ssl must be set to 1 and package TLS must be loaded +# 20100716: Bug in parsing special leading FLAGS characters in FETCH +# command repaired, documentation cleanup. +# 20121221: Added basic scope, expunge and logout function +# 20130212: Added basic copy function +# 20130212: Missing chan parameter added to all imaptotcl* procs -ger + +package require Tcl 8.5 +package provide imap4 0.5.3 + +namespace eval imap4 { + variable debugmode 0 ;# inside debug mode? usually not. + variable folderinfo + variable mboxinfo + variable msginfo + variable info + + # if set to 1 tls::socket must be loaded + variable use_ssl 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 0 + + # Version + variable version "2013-02-12" + + # 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. + array set folderinfo {} ;# list of folders. + array set mboxinfo {} ;# selected mailbox info. + array set msginfo {} ;# messages info. + array set info {} ;# general connection state info. + + # Return the next tag to use in IMAP requests. + proc tag {chan} { + variable info + incr info($chan,curtag) + } + + # Assert that the channel is one of the specified states + # by the 'states' list. + # otherwise raise an error. + proc requirestate {chan states} { + variable info + if {[lsearch $states $info($chan,state)] == -1} { + error "IMAP channel not in one of the following states: '$states' (current state is '$info($chan,state)')" + } + } + + # Open a new IMAP connection and initalize the handler. + proc open {hostname {port 0}} { + variable info + variable debug + variable use_ssl + if {$debug} { + puts "I: open $hostname $port (SSL=$use_ssl)" + } + + if {$use_ssl} { + if {[info procs ::tls::socket] eq ""} { + error "Package TLS must be loaded for secure connections." + } + if {!$port} { + set port 993 + } + set chan [::tls::socket $hostname $port] + } else { + if {!$port} { + set port 143 + } + set chan [socket $hostname $port] + } + fconfigure $chan -encoding binary -translation binary + # Intialize the connection state array + initinfo $chan + # Get the banner + processline $chan + # Save the banner + set info($chan,banner) [lastline $chan] + return $chan + } + + # Initialize the info array for a new connection. + proc initinfo {chan} { + variable info + set info($chan,curtag) 0 + set info($chan,state) NOAUTH + set info($chan,folders) {} + 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) {} + } + + # Destroy an IMAP connection and free the used space. + proc cleanup {chan} { + variable info + variable folderinfo + variable mboxinfo + variable msginfo + + ::close $chan + + array unset folderinfo $chan,* + array unset mboxinfo $chan,* + array unset msginfo $chan,* + array unset info $chan,* + + return $chan + } + + # STARTTLS + # This is a new procc added to runs the STARTTLS command. Use + # this when tasked with connecting to an unsecure port which must + # be changed to a secure port prior to user login. This feature + # is known as STARTTLS. + + proc starttls {chan} { + #puts "Starting TLS" + request $chan "STARTTLS" + if {[getresponse $chan]} { + #puts "error sending STARTTLS" + return 1 + } + + #puts "TLS import" + set chan [::tls::import $chan -tls1 1] + #puts "TLS handshake" + set chan [::tls::handshake $chan] + return 0 + } + + # Returns the last error code received. + proc lastcode {chan} { + variable info + return $info($chan,lastcode) + } + + # Returns the last line received from the server. + proc lastline {chan} { + variable info + return $info($chan,lastline) + } + + # Process an IMAP response line. + # This function trades semplicity 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. + # + # Returns the line's tag. + proc processline {chan} { + variable info + variable debug + variable mboxinfo + variable folderinfo + + 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 info($chan,lastline) $line + + if {$debug} { + puts "S: $line" + } + + # Extract the tag. + set idx [string first { } $line] + if {$idx <= 0} { + 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 <= 0} { + 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 info($chan,lastcode) $code + } + + # Extract information from the line + set dirty 0 + switch -glob -- $line { + {*\[READ-ONLY\]*} {set mboxinfo($chan,perm) READ-ONLY; incr dirty} + {*\[READ-WRITE\]*} {set mboxinfo($chan,perm) READ-WRITE; incr dirty} + {*\[TRYCREATE\]*} {set mboxinfo($chan,perm) TRYCREATE; incr dirty} + {LIST *(*)*} { + # regexp not secure enough ... delimiters must be PLAIN SPACES (see RFC) + # set res [regexp {LIST (\(.*\))(!?\s)[ ](.*)$} $line => flags delim fname] + # p1| p2| p3| + # LIST (\Noselect) "/" ~/Mail/foo + set p1 [string first "(" $line] + set p2 [string first ")" $line [expr {$p1+1}]] + set p3 [string first " " $line [expr {$p2+2}]] + if {$p1<0||$p2<0||$p3<0} { + protoerror $chan "IMAP: Not a valid RFC822 LIST format in '$line'" + } + set flags [string range $line [expr {$p1+1}] [expr {$p2-1}]] + set delim [string range $line [expr {$p2+2}] [expr {$p3-1}]] + set fname [string range $line [expr {$p3+1}] end] + if {$fname eq ""} { + set folderinfo($chan,delim) [string trim $delim "\""] + } else { + set fflag {} + foreach f [split $flags] { + lappend fflag $f + } + lappend folderinfo($chan,names) $fname + lappend folderinfo($chan,flags) [list $fname $fflag] + if {$delim ne "NIL"} { + set folderinfo($chan,delim) [string trim $delim "\""] + } + } + incr dirty + } + {FLAGS *(*)*} { + regexp {.*\((.*)\).*} $line => flags + set mboxinfo($chan,flags) $flags + incr dirty + } + {*\[PERMANENTFLAGS *(*)*\]*} { + regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags + set mboxinfo($chan,permflags) $flags + incr dirty + } + } + + if {!$dirty && $tag eq {*}} { + switch -regexp -nocase -- $line { + {^[0-9]+\s+EXISTS} { + regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists) + incr dirty + } + {^[0-9]+\s+RECENT} { + regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent) + incr dirty + } + {.*?\[UIDVALIDITY\s+[0-9]+?\]} { + regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,uidval) + incr dirty + } + {.*?\[UNSEEN\s+[0-9]+?\]} { + regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,unseen) + incr dirty + } + {.*?\[UIDNEXT\s+[0-9]+?\]} { + regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,uidnext) + incr dirty + } + {^[0-9]+\s+FETCH} { + processfetchline $chan $line $literals + incr dirty + } + {^CAPABILITY\s+.*} { + regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring + set info($chan,capability) [split [string toupper $capstring]] + incr dirty + } + {^LIST\s*$} { + regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists) + incr dirty + } + {^SEARCH\s*$} { + # Search tag without list of messages. Nothing found + # so we set an empty list. + set mboxinfo($chan,found) {} + } + {^SEARCH\s+.*} { + regexp {^SEARCH\s+(.*)\s*$} $line => foundlist + set mboxinfo($chan,found) $foundlist + incr dirty + } + default { + if {$debug} { + puts "*** WARNING: unprocessed server reply '$line'" + } + } + } + } + + if {[string length [set info($chan,idle)]] && $dirty} { + # ... Notify. + } + + # if debug and no dirty and untagged line... warning: unprocessed IMAP line + return $tag + } + + # Process untagged FETCH lines. + proc processfetchline {chan line literals} { + variable msginfo + regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items + foreach {name val} [imaptotcl $chan 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 { + 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 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} { + 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 msginfo($chan,$msgnum,$fieldname) $fieldval + } + } + default { + set msginfo($chan,$msgnum,$attribname) $val + } + } + #puts "$attribname -> [string range $val 0 20]" + } + # parray msginfo + } + + # 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. + proc imaptotcl {chan datavar literalsvar} { + upvar 1 $datavar data $literalsvar literals + set data [string trim $data] + switch -- [string index $data 0] { + \{ {imaptotcl_literal $chan data literals} + "(" {imaptotcl_list $chan data literals} + "\"" {imaptotcl_quoted $chan data} + 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number $chan data} + \) {imaptotcl_endlist $chan data;# that's a trick to parse lists} + default {imaptotcl_symbol $chan data} + } + } + + # Extract a literal + proc imaptotcl_literal {chan datavar literalsvar} { + upvar 1 $datavar data $literalsvar literals + if {![regexp {{.*?}} $data match]} { + 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 + } + + # Extract a quoted string + proc imaptotcl_quoted {chan datavar} { + upvar 1 $datavar data + if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + return [string range $match 1 end-1] + } + + # Extract a number + proc imaptotcl_number {chan datavar} { + upvar 1 $datavar data + if {![regexp {^[0-9]+} $data match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + return $match + } + + # 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. + proc imaptotcl_symbol {chan datavar} { + upvar 1 $datavar data + # matching patterns: "BODY[HEAEDER.FIELD", + # "HEAEDER.FIELD", "\Answered", "$Forwarded" + set pattern {([\w\.]+\[[^\[]+\]|[\w\.]+|[\\\$]\w+)} + if {![regexp $pattern $data => match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + return $match + } + + # Extract an IMAP list. + proc imaptotcl_list {chan 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 $chan data literals] + if {$ele eq {)}} { + break + } + lappend list $ele + } + return $list + } + + # Just extracts the ")" character alone. + # This is actually part of the list extraction work. + proc imaptotcl_endlist {chan datavar} { + upvar 1 $datavar data + set data [string range $data 1 end] + return ")" + } + + # 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. + proc getresponse {chan} { + variable info + + # Process lines until the tagged one. + while {[set tag [processline $chan]] eq {*} || $tag eq {+}} {} + switch -- [lastcode $chan] { + OK {return 0} + NO { + if {$info($chan,raise_on_NO)} { + error "IMAP error: [lastline $chan]" + } + return 1 + } + BAD { + if {$info($chan,raise_on_BAD)} { + protoerror $chan "IMAP error: [lastline $chan]" + } + return 1 + } + default { + protoerror $chan "IMAP protocol error. Unknown response code '[lastcode $chan]'" + } + } + } + + # Write a request. + proc request {chan request} { + variable debug + variable info + + set t "[tag $chan] [string trim $request]" + if {$debug} { + puts "C: $t" + } + set info($chan,lastrequest) $t + puts -nonewline $chan "$t\r\n" + flush $chan + } + + # Write a multiline request. The 'request' list must contain + # parts of command and literals interleaved. Literals are ad odd + # list positions (1, 3, ...). + proc multiline_request {chan request} { + variable debug + variable info + + lset request 0 "[tag $chan][lindex $request 0]" + set items [llength $request] + foreach {line literal} $request { + # Send the line + if {$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 {[processline $chan] ne {+}} { + protoerror $chan "Expected a command continuation response but got '[lastline $chan]'" + } + + # Send the literal + if {$debug} { + puts "C> $literal" + } + puts -nonewline $chan $literal + flush $chan + incr items -1 + } + set info($chan,lastrequest) $request + } + + # Login using the IMAP LOGIN command. + proc login {chan user pass} { + variable info + + requirestate $chan NOAUTH + request $chan "LOGIN $user $pass" + if {[getresponse $chan]} { + return 1 + } + set info($chan,state) AUTH + return 0 + } + + # Mailbox selection. + proc select {chan {mailbox INBOX}} { + selectmbox $chan SELECT $mailbox + } + + # Read-only equivalent of SELECT. + proc examine {chan {mailbox INBOX}} { + selectmbox $chan EXAMINE $mailbox + } + + # General function for selection. + proc selectmbox {chan cmd mailbox} { + variable info + variable mboxinfo + + 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 mboxinfo $chan,*] + array unset mboxinfo $chan,* + request $chan "$cmd $mailbox" + if {[getresponse $chan]} { + array set mboxinfo $savedmboxinfo + return 1 + } + + set info($chan,state) SELECT + # Set the new name as mbox->current. + set mboxinfo($chan,current) $mailbox + return 0 + } + + # 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. + proc 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 [mboxinfo $chan exists] + } + if {![string is integer $start] || ![string is integer $end]} { + error "Invalid range" + } + } + default { + error "Invalid range" + } + } + } + + # Fetch a number of attributes from messages + proc fetch {chan range opt args} { + if {$opt eq "-inline"} { + set inline 1 + } else { + set inline 0 + set args [linsert $args 0 $opt] + } + requirestate $chan SELECT + 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 + request $chan "FETCH $start:$end ([join $items])" + if {[getresponse $chan]} { + if {$inline} { + # Should we throw an error here? + return "" + } + return 1 + } + + if {!$inline} { + return 0 + } + + # -inline procesing begins here + set mailinfo {} + for {set i $start} {$i <= $end} {incr i} { + set mailrec {} + foreach {h} $args { + lappend mailrec [msginfo $chan $i $h ""] + } + lappend mailinfo $mailrec + } + return $mailinfo + } + + # 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. + proc 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 "msginfo called with bad number of arguments! Try 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) + } + } + + # 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. + proc mboxinfo {chan {info {}}} { + variable mboxinfo + + # Handle the missing info case + if {![string length $info]} { + set list [array names mboxinfo $chan,*] + set availinfo {} + foreach l $list { + lappend availinfo [string range $l \ + [string length $chan,] end] + } + return $availinfo + } + + set info [string tolower $info] + if {[string index $info end] eq {?}} { + set info [string range $info 0 end-1] + return [info exists mboxinfo($chan,$info)] + } else { + if {![info exists mboxinfo($chan,$info)]} { + error "No such information '$info' available for the current mailbox" + } + return $mboxinfo($chan,$info) + } + } + + # Get information on the last folders list. + # If the 'info' argument is omitted or a null string, the full list + # of information available for the folders 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. + proc folderinfo {chan {info {}}} { + variable folderinfo + + # Handle the missing info case + if {![string length $info]} { + set list [array names folderinfo $chan,*] + set availinfo {} + foreach l $list { + lappend availinfo [string range $l \ + [string length $chan,] end] + } + return $availinfo + } + + set info [string tolower $info] + if {[string index $info end] eq {?}} { + set info [string range $info 0 end-1] + return [info exists folderinfo($chan,$info)] + } else { + if {![info exists folderinfo($chan,$info)]} { + error "No such information '$info' available for the current folders" + } + return $folderinfo($chan,$info) + } + } + + + # Get capabilties + proc capability {chan} { + request $chan "CAPABILITY" + if {[getresponse $chan]} { + return 1 + } + return 0 + } + + # Get the current state + proc state {chan} { + variable info + return $info($chan,state) + } + + # Test for capability. Use the capability command + # to ask the server if not already done by the user. + proc isableto {chan {capa ""}} { + variable info + + set result 0 + if {![llength $info($chan,capability)]} { + set result [capability $chan] + } + + if {$capa eq ""} { + if {$result} { + # We return empty string on error + return "" + } + return $info($chan,capability) + } + + set capa [string toupper $capa] + expr {[lsearch -exact $info($chan,capability) $capa] != -1} + } + + # NOOP command. May get information as untagged data. + proc noop {chan} { + simplecmd $chan NOOP {NOAUTH AUTH SELECT} {} + } + + # CHECK. Flush to disk. + proc check {chan} { + simplecmd $chan CHECK SELECT {} + } + + # Close the mailbox. Permanently removes \Deleted messages and return to + # the AUTH state. + proc close {chan} { + variable info + + if {[simplecmd $chan CLOSE SELECT {}]} { + return 1 + } + + set info($chan,state) AUTH + return 0 + } + + # Create a new mailbox. + proc create {chan mailbox} { + simplecmd $chan CREATE {AUTH SELECT} $mailbox + } + + # Delete a mailbox + proc delete {chan mailbox} { + simplecmd $chan DELETE {AUTH SELECT} $mailbox + } + + # Rename a mailbox + proc rename {chan oldname newname} { + simplecmd $chan RENAME {AUTH SELECT} $oldname $newname + } + + # Subscribe to a mailbox + proc subscribe {chan mailbox} { + simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox + } + + # Unsubscribe to a mailbox + proc unsubscribe {chan mailbox} { + simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox + } + + # List of folders + proc folders {chan {opt ""} {ref ""} {mbox "*"}} { + variable folderinfo + array unset folderinfo $chan,* + + if {$opt eq "-inline"} { + set inline 1 + } else { + set ref $opt + set mbox $ref + set inline 0 + } + + set folderinfo($chan,match) [list $ref $mbox] + # parray folderinfo + set rv [simplecmd $chan LIST {SELECT AUTH} \"$ref\" \"$mbox\"] + if {$inline} { + set rv {} + foreach f [folderinfo $chan flags] { + set lflags {} + foreach fl [lindex $f 1] { + if {[string is alnum [string index $fl 0]]} { + lappend lflags [string tolower $fl] + } else { + lappend lflags [string tolower [string range $fl 1 end]] + } + } + lappend rv [list [lindex $f 0] $lflags] + } + } + # parray folderinfo + return $rv + } + + # This a general implementation for a simple implementation + # of an IMAP command that just requires to call ::imap4::request + # and ::imap4::getresponse. + proc simplecmd {chan command validstates args} { + requirestate $chan $validstates + + set req "$command" + foreach arg $args { + append req " $arg" + } + + request $chan $req + if {[getresponse $chan]} { + return 1 + } + + return 0 + } + + # Search command. + proc search {chan args} { + if {![llength $args]} { + error "missing arguments. Usage: search chan arg ?arg ...?" + } + + requirestate $chan SELECT + set imapexpr [convert_search_expr $args] + multiline_prefix_command imapexpr "SEARCH" + multiline_request $chan $imapexpr + if {[getresponse $chan]} { + return 1 + } + + return 0 + } + + # Creates an IMAP octect-count. + # Used to send literals. + proc literalcount {string} { + return "{[string length $string]}" + } + + # Append a command part to a multiline request + proc multiline_append_command {reqvar cmd} { + upvar 1 $reqvar req + + if {[llength $req] == 0} { + lappend req {} + } + + lset req end "[lindex $req end] $cmd" + } + + # Append a literal to a multiline request. Uses a quoted + # string in simple cases. + proc multiline_append_literal {reqvar lit} { + upvar 1 $reqvar req + + if {![string is alnum $lit]} { + lset req end "[lindex $req end] [literalcount $lit]" + lappend req $lit {} + } else { + multiline_append_command req "\"$lit\"" + } + } + + # Prefix a multiline request with a command. + proc multiline_prefix_command {reqvar cmd} { + upvar 1 $reqvar req + + if {![llength $req]} { + lappend req {} + } + + lset req 0 " $cmd[lindex $req 0]" + } + + # Concat an already created search expression to a multiline request. + proc 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])" + } + + # 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). + proc convert_search_expr {expr} { + set result {} + + while {[llength $expr]} { + switch -glob -- [string toupper [set token [lpop expr]]] { + *: { + set wanted [lpop expr] + multiline_append_command result "HEADER [string range $token 0 end-1]" + multiline_append_literal result $wanted + } + + ANSWERED - DELETED - DRAFT - FLAGGED - RECENT - + SEEN - NEW - OLD - UNANSWERED - UNDELETED - + UNDRAFT - UNFLAGGED - UNSEEN - + ALL {multiline_append_command result [string toupper $token]} + + BODY - CC - FROM - SUBJECT - TEXT - KEYWORD - + BCC { + set wanted [lpop expr] + multiline_append_command result "$token" + multiline_append_literal result $wanted + } + + OR { + set first [convert_search_expr [lpop expr]] + set second [convert_search_expr [lpop expr]] + multiline_append_command result "OR" + multiline_concat_expr result $first + multiline_concat_expr result $second + } + + NOT { + set e [convert_search_expr [lpop expr]] + multiline_append_command result "NOT" + multiline_concat_expr result $e + } + + SMALLER - + LARGER { + set len [lpop expr] + if {![string is integer $len]} { + error "Invalid integer follows '$token' in IMAP search" + } + 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 + } + + # Pop an element from the list inside the named variable and return it. + # If a list is empty, raise an error. The error is specific for the + # search command since it's the only one calling this function. + proc lpop {listvar} { + upvar 1 $listvar l + + if {![llength $l]} { + error "Bad syntax for search expression (missing argument)" + } + + set res [lindex $l 0] + set l [lrange $l 1 end] + return $res + } + + # 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 debugmode {chan {errormsg {None}}} { + variable debugmode 1 + variable debugchan $chan + variable version + variable folderinfo + variable mboxinfo + variable msginfo + variable info + + 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 'info' to see information about the connection" \ + "Type 'help' to display this information" \ + "" \ + "Last error: '$errormsg'" \ + "IMAP library version: '$version'" \ + "" \ + ] + foreach l $welcometext { + puts $l + } + + 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}} { + debugmode_info $chan + continue + } + if {$line eq {help}} { + foreach l $welcometext { + if {$l eq ""} break + puts $l + } + continue + } + if {[string index $line 0] eq {/}} { + catch {eval [string range $line 1 end]} result + puts $result + continue + } + # Let's send the request to imap server + request $chan $line + if {[catch {getresponse $chan} error]} { + puts "--- ERROR ---\n$error\n-------------\n" + } + } + } + + # Little helper for debugmode command. + proc debugmode_info {chan} { + variable info + puts "Last sent request: '$info($chan,lastrequest)'" + puts "Last received line: '$info($chan,lastline)'" + puts "" + } + + # Protocol error! Enter the debug mode if ::imap4::debug is true. + # Otherwise just raise the error. + proc protoerror {chan msg} { + variable debug + variable debugmode + + if {$debug && !$debugmode} { + debugmode $chan $msg + } else { + error $msg + } + } + + proc me {} { + variable debugchan + set 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) + + # Amend the flags of a message to be updated once CLOSE/EXPUNGE is initiated + proc store {chan range key values} { + set valid_keys { + FLAGS + FLAGS.SILENT + +FLAGS + +FLAGS.SILENT + -FLAGS + -FLAGS.SILENT + } + if {$key ni $valid_keys} { + error "Invalid data item: $key. Must be one of [join $valid_keys ,]" + } + parserange $chan $range start end + set newflags {} + foreach val $values { + if {[regexp {^\\+(.*?)$} $val]} { + lappend newflags $values + } else { + lappend newflags "\\$val" + } + } + request $chan "STORE $start:$end $key ([join $newflags])" + if {[getresponse $chan]} { + return 1 + } + return 0 + } + + # Logout + proc logout {chan} { + if {[simplecmd $chan LOGOUT SELECT {}]} { + # clean out info arrays + variable info + variable folderinfo + variable mboxinfo + variable msginfo + + array unset folderinfo $chan,* + array unset mboxinfo $chan,* + array unset msginfo $chan,* + array unset info $chan,* + + return 1 + } + return 0 + } + + # Expunge : force removal of any messages with the + # flag \Deleted + proc expunge {chan} { + if {[simplecmd $chan EXPUNGE SELECT {}]} { + return 1 + } + return 0 + } + + # copy : copy a message to a destination mailbox + proc copy {chan msgid mailbox} { + if {[simplecmd $chan COPY SELECT [list $msgid $mailbox]]} { + return 1 + } + return 0 + } + +} + +################################################################################ +# Example and test +################################################################################ +if {[info script] eq $argv0} { + # set imap4::debug 0 + set FOLDER INBOX + set port 0 + if {[llength $argv] < 3} { + puts "Usage: imap4.tcl <server> <user> <pass> ?folder? ?-secure? ?-debug?" + exit + } + + lassign $argv server user pass + if {$argc > 3} { + for {set i 3} {$i<$argc} {incr i} { + set opt [lindex $argv $i] + switch -- $opt { + "-debug" { + set imap4::debug 1 + } + "-secure" { + set imap4::use_ssl 1 + puts "Package TLS [package require tls] loaded" + } + default { + set FOLDER $opt + } + } + } + } + + # open and login ... + set imap [imap4::open $server] + imap4::login $imap $user $pass + + imap4::select $imap $FOLDER + # Output all the information about that mailbox + foreach info [imap4::mboxinfo $imap] { + puts "$info -> [imap4::mboxinfo $imap $info]" + } + set num_mails [imap4::mboxinfo $imap exists] + if {!$num_mails} { + puts "No mail in folder '$FOLDER'" + } else { + set fields {from: to: subject: size} + # fetch 3 records (at most)) inline + set max [expr {$num_mails<=3?$num_mails:3}] + foreach rec [imap4::fetch $imap :$max -inline {*}$fields] { + puts -nonewline "#[incr idx])" + for {set j 0} {$j<[llength $fields]} {incr j} { + puts "\t[lindex $fields $j] [lindex $rec $j]" + } + } + + # Show all the information available about the message ID 1 + puts "Available info about message 1 => [imap4::msginfo $imap 1]" + } + + # Use the capability stuff + puts "Capabilities: [imap4::isableto $imap]" + puts "Is able to imap4rev1? [imap4::isableto $imap imap4rev1]" + if {$imap4::debug} { + imap4::debugmode $imap + } + + # Cleanup + imap4::cleanup $imap +} |