Attachment "pop3.tcl" to
ticket [1385688fff]
added by
nobody
2005-12-20 07:28:17.
# pop3.tcl --
#
# POP3 mail client package, written in pure Tcl.
# Some concepts borrowed from "frenchie", a POP3
# mail client utility written by Scott Beasley.
#
# Copyright (c) 2000 by Ajuba Solutions.
# portions Copyright (c) 2000 by Scott Beasley
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pop3.tcl,v 1.33 2005/09/30 05:36:39 andreas_kupries Exp $
package require Tcl 8.2
package require cmdline
package require log
#package provide pop3 1.6.3
package provide pop3 1.7
# Alex Hisen ([email protected]) 2005-12-18:
# In order to provide support for the new tofile retrieval method
# we need a way to generate temporary file paths/names.
# We first try to use an AOLserver command if available.
# If not we try to see if our version of Tcl supports
# the file tempfile subcommand (see TIP #210:
# http://www.tcl.tk/cgi-bin/tct/tip/210.html )
# Finally we fallback to the tcllib fileutil package.
# Note that our package require fileutil is caught, so even
# if you don't have any of the three methods, this package
# will work fine as long as you don't use tofile retrieval.
#
# The Tempfile proc we create in our namespace operates
# the way TIP #210 prescribes - it opens the file for write,
# returns the open file channel, and sets the supplied variable
# to the full path and name of the created temporary file.
if {[string equal ns_tmpnam [info commands ns_tmpnam]]} {
namespace eval ::pop3 {
proc Tempfile {filenameVar} {
upvar 1 $filenameVar filename
return [::open [set filename [ns_tmpnam]] w]
}
}
} elseif {[catch {file nosuchoption} errMsg] && [string first "tempfile" $errMsg] != -1} {
# the check is a bit of hack - would be nice to have an info subcommands command instead
# we don't just try to execute [file tempfile] as this would actually create and open a temp file
namespace eval ::pop3 {
proc Tempfile {filenameVar} {
upvar 1 $filenameVar filename
return [file tempfile "" filename]
}
}
} else {
# not sure which version of fileutil the tempfile command appeared in
catch {package require fileutil 1.8}
namespace eval ::pop3 {
proc Tempfile {filenameVar} {
upvar 1 $filenameVar filename
return [::open [set filename [::fileutil::tempfile] w]
}
}
}
namespace eval ::pop3 {
# The state variable remembers information about the open pop3
# connection. It is indexed by channel id. The information is
# a keyed list, with keys "msex" and "retr_mode". The value
# associated with "msex" is boolean, a true value signals that the
# server at the other end is MS Exchange. The value associated
# with "retr_mode" is one of {retr, list, slow}.
# The value of "msex" influences how the translation for the
# channel is set and is determined by the contents of the received
# greeting. The value of "retr_mode" is initially "retr" and
# completely determined by the first call to [retrieve]. For "list"
# the system will use LIST before RETR to retrieve the message size.
# The state can be influenced by options given to "open".
variable state
array set state {}
}
# ::pop3::config --
#
# Retrieve configuration of pop3 connection
#
# Arguments:
# chan The channel, returned by ::pop3::open
#
# Results:
# A serialized array.
proc ::pop3::config {chan} {
variable state
return $state($chan)
}
# ::pop3::close --
#
# Close the connection to the POP3 server.
#
# Arguments:
# chan The channel, returned by ::pop3::open
#
# Results:
# None.
proc ::pop3::close {chan} {
variable state
catch {::pop3::send $chan "QUIT"}
unset state($chan)
::close $chan
}
# ::pop3::delete --
#
# Delete messages on the POP3 server.
#
# Arguments:
# chan The channel, returned by ::pop3::open
# start The first message to delete in the range.
# May be "next" (the next message after the last
# one seen, see ::pop3::last), "start" (aka 1),
# "end" (the last message in the spool, for
# deleting only the last message).
# end (optional, defaults to -1) The last message
# to delete in the range. May be "last"
# (the last message viewed), "end" (the last
# message in the spool), or "-1" (the default,
# any negative number means delete only
# one message).
#
# Results:
# None.
# May throw errors from the server.
proc ::pop3::delete {chan start {end -1}} {
variable state
array set cstate $state($chan)
set count $cstate(limit)
set last 0
catch {set last [::pop3::last $chan]}
if {![string is integer $start]} {
if {[string match $start "next"]} {
set start $last
incr start
} elseif {$start == "start"} {
set start 1
} elseif {$start == "end"} {
set start $count
} else {
error "POP3 Deletion error: Bad start index $start"
}
}
if {$start == 0} {
set start 1
}
if {![string is integer $end]} {
if {$end == "end"} {
set end $count
} elseif {$end == "last"} {
set end $last
} else {
error "POP3 Deletion error: Bad end index $end"
}
} elseif {$end < 0} {
set end $start
}
if {$end > $count} {
set end $count
}
for {set index $start} {$index <= $end} {incr index} {
if {[catch {::pop3::send $chan "DELE $index"} errorStr]} {
error "POP3 DELETE ERROR: $errorStr"
}
}
return {}
}
# ::pop3::last --
#
# Gets the index of the last email read from the server.
# Note, some POP3 servers do not support this feature,
# in which case the value returned may always be zero,
# or an error may be thrown.
#
# Arguments:
# chan The channel, returned by ::pop3::open
#
# Results:
# The index of the last email message read, which may
# be zero if none have been read or if the server does
# not support this feature.
# Server errors may be thrown, including some cases
# when the LAST command is not supported.
proc ::pop3::last {chan} {
if {[catch {
set resultStr [::pop3::send $chan "LAST"]
} errorStr]} {
error "POP3 LAST ERROR: $errorStr"
}
return [string trim $resultStr]
}
# ::pop3::list --
#
# Returns "scan listing" of the mailbox. If parameter msg
# is defined, then the listing only for the given message
# is returned.
#
# Arguments:
# chan The channel open to the POP3 server.
# msg The message number (optional).
#
# Results:
# If msg parameter is not given, Tcl list of scan listings in
# the maildrop is returned. In case msg parameter is given,
# a list of length one containing the specified message listing
# is returned.
proc ::pop3::list {chan {msg ""}} {
global PopErrorNm PopErrorStr debug
if {$msg == ""} {
if {[catch {::pop3::send $chan "LIST"} errorStr]} {
error "POP3 LIST ERROR: $errorStr"
}
set msgBuffer [RetrSlow $chan]
} else {
# argument msg given, single-line response expected
if {[catch {expr {0 + $msg}}]} {
error "POP3 LIST ERROR: malformed message number '$msg'"
} else {
set msgBuffer [string trim [::pop3::send $chan "LIST $msg"]]
}
}
return $msgBuffer
}
# pop3::open --
#
# Opens a connection to a POP3 mail server.
#
# Arguments:
# args A list of options and values, possibly empty,
# followed by the regular arguments, i.e. host, user,
# passwd and port. The latter is optional.
#
# host The name or IP address of the POP3 server host.
# user The username to use when logging into the server.
# passwd The password to use when logging into the server.
# port (optional) The socket port to connect to, defaults
# to port 110, the POP standard port address.
#
# Results:
# The connection channel (a socket).
# May throw errors from the server.
proc ::pop3::open {args} {
variable state
array set cstate {msex 0 retr_mode retr limit {}}
log::log debug "pop3::open | [join $args]"
while {[set err [cmdline::getopt args {msex.arg retr-mode.arg} opt arg]]} {
if {$err < 0} {
return -code error "::pop3::open : $arg"
}
switch -exact -- $opt {
msex {
if {![string is boolean $arg]} {
return -code error \
":pop3::open : Argument to -msex has to be boolean"
}
set cstate(msex) $arg
}
retr-mode {
switch -exact -- $arg {
tofile - retr - list - slow {
set cstate(retr_mode) $arg
}
default {
return -code error \
":pop3::open : Argument to -retr-mode has to be one of tofile, retr, list or slow"
}
}
}
default {# Can't happen}
}
}
if {[llength $args] > 4} {
return -code error "To many arguments to ::pop3::open"
}
if {[llength $args] < 3} {
return -code error "Not enough arguments to ::pop3::open"
}
foreach {host user password port} $args break
if {$port == {}} {
set port 110
}
log::log debug "pop3::open | protocol, connect to $host $port"
# Argument processing is finally complete, now open the channel
set chan [socket $host $port]
fconfigure $chan -buffering none
log::log debug "pop3::open | connect on $chan"
if {$cstate(msex)} {
# We are talking to MS Exchange. Work around its quirks.
fconfigure $chan -translation binary
} else {
fconfigure $chan -translation {binary crlf}
}
log::log debug "pop3::open | wait for greeting"
if {[catch {::pop3::send $chan {}} errorStr]} {
::close $chan
error "POP3 CONNECT ERROR: $errorStr"
}
if {0} {
# -FUTURE- Identify MS Exchange servers
set cstate(msex) 1
# We are talking to MS Exchange. Work around its quirks.
fconfigure $chan -translation binary
}
log::log debug "pop3::open | authenticate $user (*password not shown*)"
if {[catch {
::pop3::send $chan "USER $user"
::pop3::send $chan "PASS $password"
} errorStr]} {
::close $chan
error "POP3 LOGIN ERROR: $errorStr"
}
# [ 833486 ] Can't delete messages one at a time ...
# Remember the number of messages in the maildrop at the beginning
# of the session. This gives us the highest possible number for
# message ids later. Note that this number must not be affected
# when deleting mails later. While the number of messages drops
# down the limit for the message id's stays the same. The messages
# are not renumbered before the session actually closed.
set cstate(limit) [lindex [::pop3::status $chan] 0]
# Remember the state.
set state($chan) [array get cstate]
log::log debug "pop3::open | ok ($chan)"
return $chan
}
# ::pop3::retrieve --
#
# Retrieve email message(s) from the server.
#
# Arguments:
# chan The channel, returned by ::pop3::open
# start The first message to retrieve in the range.
# May be "next" (the next message after the last
# one seen, see ::pop3::last), "start" (aka 1),
# "end" (the last message in the spool, for
# retrieving only the last message).
# end (optional, defaults to -1) The last message
# to retrieve in the range. May be "last"
# (the last message viewed), "end" (the last
# message in the spool), or "-1" (the default,
# any negative number means retrieve only
# one message).
#
# Results:
# A list containing all of the messages retrieved.
# May throw errors from the server.
proc ::pop3::retrieve {chan start {end -1}} {
variable state
array set cstate $state($chan)
set count $cstate(limit)
set last 0
catch {set last [::pop3::last $chan]}
if {![string is integer $start]} {
if {[string match $start "next"]} {
set start $last
incr start
} elseif {$start == "start"} {
set start 1
} elseif {$start == "end"} {
set start $count
} else {
error "POP3 Retrieval error: Bad start index $start"
}
}
if {$start == 0} {
set start 1
}
if {![string is integer $end]} {
if {$end == "end"} {
set end $count
} elseif {$end == "last"} {
set end $last
} else {
error "POP3 Retrieval error: Bad end index $end"
}
} elseif {$end < 0} {
set end $start
}
if {$end > $count} {
set end $count
}
set result {}
::log::log debug "pop3 $chan retrieve $start -- $end"
for {set index $start} {$index <= $end} {incr index} {
switch -exact -- $cstate(retr_mode) {
tofile {
# Retrieve one line at a time and save to a file
# Return value will be filename
::pop3::send $chan "RETR $index"
set msgBuffer [RetrToFile $chan]
}
retr {
set sizeStr [::pop3::send $chan "RETR $index"]
::log::log debug "pop3 $chan retrieve ($sizeStr)"
if {[scan $sizeStr {%d %s} size dummy] < 1} {
# The server did not deliver the size information.
# Switch our mode to "list" and use the slow
# method this time. The next call will use LIST before
# RETR to get the size information. If even that fails
# the system will fall back to slow mode all the time.
::log::log debug "pop3 $chan retrieve - no size information, go slow"
set cstate(retr_mode) list
set state($chan) [array get cstate]
# Retrieve in slow motion.
set msgBuffer [RetrSlow $chan]
} else {
::log::log debug "pop3 $chan retrieve - size information present, use fast mode"
set msgBuffer [RetrFast $chan $size]
}
}
list {
set sizeStr [::pop3::send $chan "LIST $index"]
if {[scan $sizeStr {%d %d %s} dummy size dummy] < 2} {
# Not even LIST generates the necessary size information.
# Switch to full slow mode and don't bother anymore.
set cstate(retr_mode) slow
set state($chan) [array get cstate]
::pop3::send $chan "RETR $index"
# Retrieve in slow motion.
set msgBuffer [RetrSlow $chan]
} else {
# Ignore response of RETR, already know the size
# through LIST
::pop3::send $chan "RETR $index"
set msgBuffer [RetrFast $chan $size]
}
}
slow {
# Retrieve in slow motion.
::pop3::send $chan "RETR $index"
set msgBuffer [RetrSlow $chan]
}
}
lappend result $msgBuffer
}
return $result
}
# ::pop3::RetrFast --
#
# Fast retrieval of a message from the pop3 server.
# Internal helper to prevent code bloat in "pop3::retrieve"
#
# Arguments:
# chan The channel to read the message from.
#
# Results:
# The text of the retrieved message.
proc ::pop3::RetrFast {chan size} {
set msgBuffer [read $chan $size]
# JCR - added logging check, no point in splitting huge message
# if we aren't going to do anything about it
if {![::log::lvIsSuppressed debug]} {
foreach line [split $msgBuffer \n] {
::log::log debug "pop3 $chan fast <$line>"
}
}
# There is a small discrepance in counting octets we have to be
# aware of. 'size' is #octets before transmission, i.e. can be
# with one eol character, CR or LF. The channel system in binary
# mode counts every character, and the protocol specified CRLF as
# eol, so for every line in the message we read that many
# characters _less_. Another factor which can cause a miscount is
# the ".-stuffing performed by the sender. I.e. what we got now is
# not necessarily the complete message. We have to perform slow
# reads to get the remainder of the message. This has another
# complication. We cannot simply check for a line containing the
# terminating signature, simply because the point where the
# message was broken in two might just be in between the dots of a
# "\r\n..\r\n" sequence. We have to make sure that we do not
# misinterpret the second part of this sequence as terminator.
# Another possibility: "\r\n.\r\n" is broken just after the dot.
# Then we have to ensure to not to miss the terminator entirely.
# Sometimes the gets returns nothing, need to get the real
# terminating "." / "
if {[string equal [string range $msgBuffer end-3 end] "\n.\r\n"]} {
# Complete terminator found. Remove it from the message buffer.
::log::log debug "pop3 $chan /5__"
set msgBuffer [string range $msgBuffer 0 end-3]
} elseif {[string equal [string range $msgBuffer end-2 end] "\n.\r"]} {
# Complete terminator found. Remove it from the message buffer.
# Also perform an empty read to remove the missing '\n' from
# the channel. If we don't do this all following commands will
# run into off-by-one (character) problems.
::log::log debug "pop3 $chan /4__"
set msgBuffer [string range $msgBuffer 0 end-2]
while {[read $chan 1] != "\n"} {}
} elseif {[string equal [string range $msgBuffer end-1 end] "\n."]} {
# \n. at the end of the fast buffer.
# Can be \n.\r\n = Terminator
# or \n..\r\n = dot-stuffed single .
log::log debug "pop3 $chan /check for cut .. or terminator sequence"
# Idle until non-empty line encountered.
while {[set line [gets $chan]] == ""} {}
if {"$line" == "\r"} {
# Terminator already found. Note that we have to
# remove the partial terminator sequence from the
# message buffer.
::log::log debug "pop3 $chan /3__ <$line>"
set msgBuffer [string range $msgBuffer 0 end-1]
} else {
# Append line and look for the real terminator
append msgBuffer $line
::log::log debug "pop3 $chan ____ <$line>"
while {[set line [gets $chan]] != ".\r"} {
::log::log debug "pop3 $chan ____ <$line>"
append msgBuffer $line
}
::log::log debug "pop3 $chan /2__ <$line>"
}
} elseif {[string equal [string index $msgBuffer end] \n]} {
# Line terminator (\n) found. The remainder of the mail has to
# consist of true lines we can read directly.
while {![string equal [set line [gets $chan]] ".\r"]} {
::log::log debug "pop3 $chan ____ <$line>"
append msgBuffer $line
}
::log::log debug "pop3 $chan /1__ <$line>"
} else {
# Incomplete line at the end of the buffer. We complete it in
# a single read, and then handle the remainder like the case
# before, where we had a complete line at the end of the
# buffer.
set line [gets $chan]
::log::log debug "pop3 $chan /1a_ <$line>"
append msgBuffer $line
::log::log debug "pop3 $chan /1b_"
while {![string equal [set line [gets $chan]] ".\r"]} {
::log::log debug "pop3 $chan ____ <$line>"
append msgBuffer $line
}
::log::log debug "pop3 $chan /1c_ <$line>"
}
::log::log debug "pop3 $chan done"
# Map both cr+lf and cr to lf to simulate auto EOL translation, then
# unstuff .-stuffed lines.
return [string map [::list \n.. \n.] [string map [::list \r \n] [string map [::list \r\n \n] $msgBuffer]]]
}
# ::pop3::RetrSlow --
#
# Slow retrieval of a message from the pop3 server.
# Internal helper to prevent code bloat in "pop3::retrieve"
#
# Arguments:
# chan The channel to read the message from.
#
# Results:
# The text of the retrieved message.
proc ::pop3::RetrSlow {chan} {
set msgBuffer ""
while {1} {
set line [string trimright [gets $chan] \r]
::log::log debug "pop3 $chan slow $line"
# End of the message is a line with just "."
if {$line == "."} {
break
} elseif {[string index $line 0] == "."} {
set line [string range $line 1 end]
}
append msgBuffer $line "\n"
}
return $msgBuffer
}
# ::pop3::RetrToFile --
#
# Slow save of a message from the pop3 server to a file.
# Internal helper to prevent code bloat in "pop3::retrieve"
#
# Arguments:
# chan The channel to read the message from.
#
# Results:
# The filename of the message file.
proc ::pop3::RetrToFile {chan} {
set fchan [Tempfile filename]
while {1} {
set line [string trimright [gets $chan] \r]
# End of the message is a line with just "."
if {$line == "."} {
break
} elseif {[string index $line 0] == "."} {
set line [string range $line 1 end]
}
::puts $fchan $line
}
::close $fchan
return $filename
}
# ::pop3::send --
#
# Send a command string to the POP3 server. This is an
# internal function, but may be used in rare cases.
#
# Arguments:
# chan The channel open to the POP3 server.
# cmdstring POP3 command string
#
# Results:
# Result string from the POP3 server, except for the +OK tag.
# Errors from the POP3 server are thrown.
proc ::pop3::send {chan cmdstring} {
global PopErrorNm PopErrorStr debug
if {$cmdstring != {}} {
::log::log debug "pop3 $chan >>> $cmdstring"
puts $chan $cmdstring
}
set popRet [string trim [gets $chan]]
::log::log debug "pop3 $chan <<< $popRet"
if {[string first "+OK" $popRet] == -1} {
error [string range $popRet 4 end]
}
return [string range $popRet 3 end]
}
# ::pop3::status --
#
# Get the status of the mail spool on the POP3 server.
#
# Arguments:
# chan The channel, returned by ::pop3::open
#
# Results:
# A list containing two elements, {msgCount octetSize},
# where msgCount is the number of messages in the spool
# and octetSize is the size (in octets, or 8 bytes) of
# the entire spool.
proc ::pop3::status {chan} {
if {[catch {set statusStr [::pop3::send $chan "STAT"]} errorStr]} {
error "POP3 STAT ERROR: $errorStr"
}
# Dig the sent size and count info out.
set rawStatus [split [string trim $statusStr]]
return [::list [lindex $rawStatus 0] [lindex $rawStatus 1]]
}
# ::pop3::top --
#
# Optional POP3 command (see RFC1939). Retrieves message header
# and given number of lines from the message body.
#
# Arguments:
# chan The channel open to the POP3 server.
# msg The message number to be retrieved.
# n Number of lines returned from the message body.
#
# Results:
# Text (with newlines) from the server.
# Errors from the POP3 server are thrown.
proc ::pop3::top {chan msg n} {
global PopErrorNm PopErrorStr debug
if {[catch {::pop3::send $chan "TOP $msg $n"} errorStr]} {
error "POP3 TOP ERROR: $errorStr"
}
return [RetrSlow $chan]
}
# ::pop3::uidl --
#
# Returns "uid listing" of the mailbox. If parameter msg
# is defined, then the listing only for the given message
# is returned.
#
# Arguments:
# chan The channel open to the POP3 server.
# msg The message number (optional).
#
# Results:
# If msg parameter is not given, Tcl list of uid listings in
# the maildrop is returned. In case msg parameter is given,
# a list of length one containing the uid of the specified
# message listing is returned.
proc ::pop3::uidl {chan {msg ""}} {
if {$msg == ""} {
if {[catch {::pop3::send $chan "UIDL"} errorStr]} {
error "POP3 UIDL ERROR: $errorStr"
}
set msgBuffer [RetrSlow $chan]
} else {
# argument msg given, single-line response expected
if {[catch {expr {0 + $msg}}]} {
error "POP3 UIDL ERROR: malformed message number '$msg'"
} else {
set msgBuffer [string trim [::pop3::send $chan "UIDL $msg"]]
}
}
return $msgBuffer
}
