home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / pop3 / pop3.tcl < prev   
Encoding:
Text File  |  2001-08-17  |  14.8 KB  |  575 lines
  1. # pop3.tcl --
  2. #
  3. #    POP3 mail client package, written in pure Tcl.
  4. #    Some concepts borrowed from "frenchie", a POP3
  5. #    mail client utility written by Scott Beasley.
  6. #
  7. # Copyright (c) 2000 by Ajuba Solutions.
  8. # portions Copyright (c) 2000 by Scott Beasley
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. # 
  13. # RCS: @(#) $Id: pop3.tcl,v 1.13 2001/08/02 17:22:29 andreas_kupries Exp $
  14.  
  15. package require Tcl 8.2
  16. package require cmdline
  17. package provide pop3 1.3
  18.  
  19. namespace eval ::pop3 {
  20.  
  21.     # The state variable remembers information about the open pop3
  22.     # connection. It is indexed by channel id. The information is
  23.     # a keyed list, with keys "msex" and "retr_mode". The value
  24.     # associated with "msex" is boolean, a true value signals that the
  25.     # server at the other end is MS Exchange. The value associated
  26.     # with "retr_mode" is one of {retr, list, slow}.
  27.  
  28.     # The value of "msex" influences how the translation for the
  29.     # channel is set and is determined by the contents of the received
  30.     # greeting. The value of "retr_mode" is initially "retr" and
  31.     # completely determined by the first call to [retr]. For "list" the
  32.     # system will use LIST before RETR to retrieve the message size.
  33.  
  34.     # The state can be influenced by options given to "open".
  35.  
  36.     variable  state
  37.     array set state {}
  38.  
  39. }
  40.  
  41. # pop3::open --
  42. #
  43. #    Opens a connection to a POP3 mail server.
  44. #
  45. # Arguments:
  46. #       args     A list of options and values, possibly empty,
  47. #         followed by the regular arguments, i.e. host, user,
  48. #         passwd and port. The latter is optional.
  49. #
  50. #    host     The name or IP address of the POP3 server host.
  51. #       user     The username to use when logging into the server.
  52. #       passwd   The password to use when logging into the server.
  53. #       port     (optional) The socket port to connect to, defaults
  54. #                to port 110, the POP standard port address.
  55. #
  56. # Results:
  57. #    The connection channel (a socket).
  58. #       May throw errors from the server.
  59.  
  60. proc ::pop3::open {args} {
  61.     variable state
  62.     array set cstate {msex 0 retr_mode retr}
  63.  
  64.     while {[set err [cmdline::getopt args {msex.arg retr-mode.arg} opt arg]]} {
  65.     if {$err < 0} {
  66.         return -code error "::pop3::open : $arg"
  67.     }
  68.     switch -exact -- $opt {
  69.         msex {
  70.         if {![string is boolean $arg]} {
  71.             return -code error \
  72.                 ":pop3::open : Argument to -msex has to be boolean"
  73.         }
  74.         set cstate(msex) $arg
  75.         }
  76.         retr-mode {
  77.         switch -exact -- $arg {
  78.             retr - list - slow {
  79.             set cstate(retr_mode) $arg
  80.             }
  81.             default {
  82.             return -code error \
  83.                 ":pop3::open : Argument to -retr-mode has to be one of retr, list or slow"
  84.             }
  85.         }
  86.         }
  87.         default {# Can't happen}
  88.     }
  89.     }
  90.  
  91.     if {[llength $args] > 4} {
  92.     return -code error "To many arguments to ::pop3::open"
  93.     }
  94.     if {[llength $args] < 3} {
  95.     return -code error "Not enough arguments to ::pop3::open"
  96.     }
  97.     foreach {host user password port} $args break
  98.     if {$port == {}} {
  99.     set port 110
  100.     }
  101.  
  102.     # Argument processing is finally complete, now open the channel
  103.  
  104.     set chan [socket $host $port]
  105.     fconfigure $chan -buffering none
  106.  
  107.     if {$cstate(msex)} {
  108.     # We are talking to MS Exchange. Work around its quirks.
  109.     fconfigure $chan -translation binary
  110.     } else {
  111.     fconfigure $chan -translation {binary crlf}
  112.     }
  113.  
  114.     if {[catch {::pop3::send $chan {}} errorStr]} {
  115.     error "POP3 CONNECT ERROR: $errorStr"
  116.     }
  117.  
  118.     if {0} {
  119.     # -FUTURE- Identify MS Exchange servers
  120.     set cstate(msex) 1
  121.  
  122.     # We are talking to MS Exchange. Work around its quirks.
  123.     fconfigure $chan -translation binary
  124.     }
  125.  
  126.     if {[catch {
  127.         ::pop3::send $chan "user $user"
  128.         ::pop3::send $chan "pass $password"
  129.         } errorStr]} {
  130.     error "POP3 LOGIN ERROR: $errorStr"
  131.     }
  132.  
  133.     # Remember the state.
  134.  
  135.     set state($chan) [array get cstate]
  136.     return $chan
  137. }
  138.  
  139. # ::pop3::status --
  140. #
  141. #    Get the status of the mail spool on the POP3 server.
  142. #
  143. # Arguments:
  144. #    chan      The channel, returned by ::pop3::open
  145. #
  146. # Results:
  147. #    A list containing two elements, {msgCount octetSize},
  148. #       where msgCount is the number of messages in the spool
  149. #       and octetSize is the size (in octets, or 8 bytes) of
  150. #       the entire spool.
  151.  
  152. proc ::pop3::status {chan} {
  153.  
  154.     if {[catch {set statusStr [::pop3::send $chan "STAT"]} errorStr]} {
  155.     error "POP3 STAT ERROR: $errorStr"
  156.     }
  157.  
  158.     # Dig the sent size and count info out.
  159.     set rawStatus [split [string trim $statusStr]]
  160.     
  161.     return [::list [lindex $rawStatus 0] [lindex $rawStatus 1]]
  162. }
  163.  
  164. # ::pop3::last --
  165. #
  166. #    Gets the index of the last email read from the server.
  167. #       Note, some POP3 servers do not support this feature,
  168. #       in which case the value returned may always be zero,
  169. #       or an error may be thrown.
  170. #
  171. # Arguments:
  172. #    chan      The channel, returned by ::pop3::open
  173. #
  174. # Results:
  175. #    The index of the last email message read, which may
  176. #       be zero if none have been read or if the server does
  177. #       not support this feature.
  178. #       Server errors may be thrown, including some cases
  179. #       when the LAST command is not supported.
  180.  
  181. proc ::pop3::last {chan} {
  182.  
  183.     if {[catch {
  184.         set resultStr [::pop3::send $chan "LAST"]
  185.         } errorStr]} {
  186.     error "POP3 LAST ERROR: $errorStr"
  187.     }
  188.     
  189.     return [string trim $resultStr]
  190. }
  191.  
  192. # ::pop3::retrieve --
  193. #
  194. #    Retrieve email message(s) from the server.
  195. #
  196. # Arguments:
  197. #    chan      The channel, returned by ::pop3::open
  198. #       start     The first message to retrieve in the range.
  199. #                 May be "next" (the next message after the last
  200. #                 one seen, see ::pop3::last), "start" (aka 1),
  201. #                 "end" (the last message in the spool, for 
  202. #                 retriving only the last message).
  203. #       end       (optional, defaults to -1) The last message
  204. #                 to retrieve in the range. May be "last"
  205. #                 (the last message viewed), "end" (the last
  206. #                 message in the spool), or "-1" (the default,
  207. #                 any negative number means retrieve only
  208. #                 one message).
  209. #
  210. # Results:
  211. #    A list containing all of the messages retrieved.
  212. #       May throw errors from the server.
  213.  
  214. proc ::pop3::retrieve {chan start {end -1}} {
  215.     variable state
  216.     array set cstate $state($chan)
  217.     
  218.     set count [lindex [::pop3::status $chan] 0]
  219.     set last 0
  220.     catch {set last [::pop3::last $chan]}
  221.  
  222.     if {![string is integer $start]} {
  223.     if {[string match $start "next"]} {
  224.         set start $last
  225.         incr start
  226.     } elseif {$start == "start"} {
  227.         set start 1
  228.     } elseif {$start == "end"} {
  229.         set start $count
  230.     } else {
  231.         error "POP3 Retrieval error: Bad start index $start"
  232.     }
  233.     } 
  234.     if {$start == 0} {
  235.     set start 1
  236.     }
  237.     
  238.     if {![string is integer $end]} {
  239.     if {$end == "end"} {
  240.         set end $count
  241.     } elseif {$end == "last"} {
  242.         set end $last
  243.     } else {
  244.         error "POP3 Retrieval error: Bad end index $end"
  245.     }
  246.     } elseif {$end < 0} {
  247.     set end $start
  248.     }
  249.  
  250.     if {$end > $count} {
  251.     set end $count
  252.     }
  253.     
  254.     set result {}
  255.  
  256.     for {set index $start} {$index <= $end} {incr index} {
  257.     switch -exact -- $cstate(retr_mode) {
  258.         retr {
  259.         set sizeStr [::pop3::send $chan "RETR $index"]
  260.  
  261.         if {[scan $sizeStr {%d %s} size dummy] < 0} {
  262.             # The server did not deliver the size information.
  263.             # Switch our mode to "list" and use the slow
  264.             # method this time. The next call will use LIST before
  265.             # RETR to get the size information. If even that fails
  266.             # the system will fall back to slow mode all the time.
  267.  
  268.             set cstate(retr_mode) list
  269.             set state($chan) [array get cstate]
  270.  
  271.             # Retrieve in slow motion.
  272.             set msgBuffer [RetrSlow $chan]
  273.         } else {
  274.             set msgBuffer [RetrFast $chan $size]
  275.         }
  276.         }
  277.         list {
  278.         set sizeStr [::pop3::send $chan "LIST $index"]
  279.  
  280.         if {[scan $sizeStr {%d %d %s} dummy size dummy] < 0} {
  281.             # Not even LIST generates the necessary size information.
  282.             # Switch to full slow mode and don't bother anymore.
  283.  
  284.             set cstate(retr_mode) slow
  285.             set state($chan) [array get cstate]
  286.  
  287.             # Retrieve in slow motion.
  288.             set msgBuffer [RetrSlow $chan]
  289.         } else {
  290.             # Ignore response of RETR, already know the size
  291.             # through LIST
  292.  
  293.             ::pop3::send $chan "RETR $index"
  294.  
  295.             set msgBuffer [RetrFast $chan $size]
  296.         }
  297.         }
  298.         slow {
  299.         # Retrieve in slow motion.
  300.  
  301.         set msgBuffer [RetrSlow $chan]
  302.         }
  303.     }
  304.     lappend result $msgBuffer
  305.     }
  306.     return $result
  307. }
  308.  
  309. # ::pop3::RetrFast --
  310. #
  311. #    Fast retrieval of a message from the pop3 server.
  312. #    Internal helper to prevent code bloat in "pop3::retrieve"
  313. #
  314. # Arguments:
  315. #    chan    The channel to read the message from.
  316. #
  317. # Results:
  318. #    The text of the retrieved message.
  319.  
  320. proc ::pop3::RetrFast {chan size} {
  321.     set msgBuffer [read $chan $size]
  322.  
  323.     # We might have read not enough because of .-stuffed lines.
  324.     # Read the possible remainder in line by line fashion!
  325.     #            
  326.     # get the terminating "."
  327.     # sometimes the gets returns nothing, 
  328.     # need to get the real terminating "."
  329.  
  330.     while {[set line [gets $chan]] != ".\r"} {
  331.     append msgBuffer $line
  332.     }
  333.  
  334.     # Map both cr+lf and cr to lf to simulate auto EOL translation, then
  335.     # unstuff .-stuffed lines.
  336.  
  337.     return [string map [::list \n.. \n.] [string map [::list \r \n] [string map [::list \r\n \n] $msgBuffer]]]
  338. }
  339.  
  340. # ::pop3::RetrSlow --
  341. #
  342. #    Slow retrieval of a message from the pop3 server.
  343. #    Internal helper to prevent code bloat in "pop3::retrieve"
  344. #
  345. # Arguments:
  346. #    chan    The channel to read the message from.
  347. #
  348. # Results:
  349. #    The text of the retrieved message.
  350.  
  351. proc ::pop3::RetrSlow {chan} {
  352.     set msgBuffer ""
  353.     
  354.     while {1} {
  355.     set line [string trimright [gets $chan] \r]
  356.         
  357.     # End of the message is a line with just "."
  358.     if {$line == "."} {
  359.         break
  360.     } elseif {[string index $line 0] == "."} {
  361.         set line [string range $line 1 end]
  362.     }
  363.         
  364.     append msgBuffer $line "\n"
  365.     }
  366.  
  367.     return $msgBuffer
  368. }
  369.  
  370. # ::pop3::delete --
  371. #
  372. #    Delete messages on the POP3 server.
  373. #
  374. # Arguments:
  375. #    chan      The channel, returned by ::pop3::open
  376. #       start     The first message to delete in the range.
  377. #                 May be "next" (the next message after the last
  378. #                 one seen, see ::pop3::last), "start" (aka 1),
  379. #                 "end" (the last message in the spool, for 
  380. #                 deleting only the last message).
  381. #       end       (optional, defaults to -1) The last message
  382. #                 to delete in the range. May be "last"
  383. #                 (the last message viewed), "end" (the last
  384. #                 message in the spool), or "-1" (the default,
  385. #                 any negative number means delete only
  386. #                 one message).
  387. #
  388. # Results:
  389. #    None.
  390. #       May throw errors from the server.
  391.  
  392. proc ::pop3::delete {chan start {end -1}} {
  393.     
  394.     set count [lindex [::pop3::status $chan] 0]
  395.     set last 0
  396.     catch {set last [::pop3::last $chan]}
  397.  
  398.     if {![string is integer $start]} {
  399.     if {[string match $start "next"]} {
  400.         set start $last
  401.         incr start
  402.     } elseif {$start == "start"} {
  403.         set start 1
  404.     } elseif {$start == "end"} {
  405.         set start $count
  406.     } else {
  407.         error "POP3 Deletion error: Bad start index $start"
  408.     }
  409.     } 
  410.     if {$start == 0} {
  411.     set start 1
  412.     }
  413.     
  414.     
  415.     if {![string is integer $end]} {
  416.     if {$end == "end"} {
  417.         set end $count
  418.     } elseif {$end == "last"} {
  419.         set end $last
  420.     } else {
  421.         error "POP3 Deletion error: Bad end index $end"
  422.     }
  423.     } elseif {$end < 0} {
  424.     set end $start
  425.     }
  426.  
  427.     if {$end > $count} {
  428.     set end $count
  429.     }
  430.     
  431.     for {set index $start} {$index <= $end} {incr index} {
  432.     if {[catch {::pop3::send $chan "DELE $index"} errorStr]} {
  433.         error "POP3 DELETE ERROR: $errorStr"
  434.     }
  435.     }
  436.     return {}
  437. }
  438.  
  439. # ::pop3::close --
  440. #
  441. #    Close the connection to the POP3 server.
  442. #
  443. # Arguments:
  444. #    chan      The channel, returned by ::pop3::open
  445. #
  446. # Results:
  447. #    None.
  448.  
  449. proc ::pop3::close {chan} {
  450.     variable state
  451.     catch {::pop3::send $chan "QUIT"}
  452.     unset state($chan)
  453.     ::close $chan
  454. }
  455.  
  456.         
  457.  
  458. # ::pop3::send --
  459. #
  460. #    Send a command string to the POP3 server.  This is an
  461. #       internal function, but may be used in rare cases.
  462. #
  463. # Arguments:
  464. #    chan        The channel open to the POP3 server.
  465. #       cmdstring   POP3 command string
  466. #
  467. # Results:
  468. #    Result string from the POP3 server, except for the +OK tag.
  469. #       Errors from the POP3 server are thrown.
  470.  
  471. proc ::pop3::send {chan cmdstring} {
  472.    global PopErrorNm PopErrorStr debug
  473.  
  474.    if {$cmdstring != {}} {
  475.       puts $chan $cmdstring
  476.    }
  477.    
  478.    set popRet [string trim [gets $chan]]
  479.  
  480.    if {[string first "+OK" $popRet] == -1} {
  481.        error [string range $popRet 4 end]
  482.    }
  483.  
  484.    return [string range $popRet 3 end]
  485. }
  486.  
  487. # ::pop3::list --
  488. #
  489. #    Returns "scan listing" of the mailbox. If parameter msg
  490. #       is defined, then the listing only for the given message 
  491. #       is returned.
  492. #
  493. # Arguments:
  494. #    chan        The channel open to the POP3 server.
  495. #       msg         The message number (optional).
  496. #
  497. # Results:
  498. #    If msg parameter is not given, Tcl list of scan listings in 
  499. #       the maildrop is returned. In case msg parameter is given,
  500. #       a list of length one containing the specified message listing
  501. #       is returned.
  502.  
  503. proc ::pop3::list {chan {msg ""}} {
  504.     global PopErrorNm PopErrorStr debug
  505.  
  506.     if {$msg == ""} {
  507.     if {[catch {::pop3::send $chan "LIST"} errorStr]} {
  508.         error "POP3 LIST ERROR: $errorStr"
  509.     }
  510.     set msgBuffer {}
  511.     while {1} {
  512.         set line [gets $chan]
  513.  
  514.         # End of the message is a line with just "."
  515.  
  516.         set line [string trimright $line]
  517.  
  518.         if {$line == "."} {
  519.         break
  520.         } elseif {[string index $line 0] == "."} {
  521.         # Use trimright to ge rid of superfluous \r's
  522.         # (we get them due to binary mode)
  523.  
  524.         set line [string range $line 1 end]
  525.         }
  526.  
  527.         lappend msgBuffer $line
  528.     }
  529.     } else {
  530.     # argument msg given, single-line response expected
  531.  
  532.     if {[catch {expr {0 + $msg}}]} {
  533.         error "POP3 LIST ERROR: malformed message number '$msg'"
  534.     } else {
  535.         lappend msgBuffer [string trim [::pop3::send $chan "LIST $msg"]]
  536.     }
  537.     }
  538.     return $msgBuffer
  539. }
  540.  
  541. # ::pop3::top --
  542. #
  543. #       Optional POP3 command (see RFC1939). Retrieves message header
  544. #       and given number of lines from the message body.
  545. #
  546. # Arguments:
  547. #    chan        The channel open to the POP3 server.
  548. #       msg         The message number to be retrieved.
  549. #       n           Number of lines returned from the message body.
  550. #
  551. # Results:
  552. #    Text (with newlines) from the server.
  553. #       Errors from the POP3 server are thrown.
  554.  
  555. proc ::pop3::top {chan msg n} {
  556.     global PopErrorNm PopErrorStr debug
  557.     
  558.     if {[catch {::pop3::send $chan "TOP $msg $n"} errorStr]} {
  559.     error "POP3 TOP ERROR: $errorStr"
  560.     }
  561.  
  562.     while {1} {
  563.     set line [gets $chan]
  564.     # End of the message is a line with just "."
  565.     if {[string trimright $line] == "."} {
  566.         break
  567.     } elseif {[string index $line 0] == "."} {
  568.         # Get rid of traling \r's. We get them due to binary mode.
  569.         set line [string trimright [string range $line 1 end]]
  570.     }
  571.     append msgBuffer "$line\n"
  572.     }
  573.     return $msgBuffer
  574. }
  575.