pop3.tcl

Go to the documentation of this file.

/*  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

namespace ::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  state =  {}

}

/*  ::pop3::config --*/
/* */
/*  Retrieve configuration of pop3 connection*/
/* */
/*  Arguments:*/
/*  chan      The channel, returned by ::pop3::open*/
/* */
/*  Results:*/
/*  A serialized array.*/

ret  ::pop3::config (type 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.*/

ret  ::pop3::close (type 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.*/

ret  ::pop3::delete (type chan , type start , optional 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.*/

ret  ::pop3::last (type 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.*/

ret  ::pop3::list (type chan , optional 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.*/

ret  ::pop3::open (type 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 {
            retr - list - slow {
            set cstate(retr_mode) $arg
            }
            default {
            return -code error \
                ":pop3::open : Argument to -retr-mode has to be one of 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.*/

ret  ::pop3::retrieve (type chan , type start , optional 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) {
        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.*/

ret  ::pop3::RetrFast (type chan , type size) {
    set msgBuffer [read $chan $size]

    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.*/

ret  ::pop3::RetrSlow (type 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::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.*/

ret  ::pop3::send (type chan , type 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.*/

ret  ::pop3::status (type 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.*/

ret  ::pop3::top (type chan , type msg , type 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.*/

ret  ::pop3::uidl (type chan , optional 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
}