imap4.tcl

Go to the documentation of this file.

/*  IMAP4 protocol pure Tcl implementation.*/
/* */
/*  COPYRIGHT AND PERMISSION NOTICE*/
/*  */
/*  Copyright (C) 2004 Salvatore Sanfilippo <antirez@invece.org>.*/
/*  */
/*  All rights reserved.*/
/*  */
/*  Permission is hereby granted, free of charge, to any person obtaining a*/
/*  copy of this software and associated documentation files (the*/
/*  "Software"), to deal in the Software without restriction, including*/
/*  without limitation the rights to use, copy, modify, merge, publish,*/
/*  distribute, and/or sell copies of the Software, and to permit persons*/
/*  to whom the Software is furnished to do so, provided that the above*/
/*  copyright notice(s) and this permission notice appear in all copies of*/
/*  the Software and that both the above copyright notice(s) and this*/
/*  permission notice appear in supporting documentation.*/
/*  */
/*  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS*/
/*  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF*/
/*  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT*/
/*  OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR*/
/*  HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL*/
/*  INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING*/
/*  FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,*/
/*  NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION*/
/*  WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.*/
/*  */
/*  Except as contained in this notice, the name of a copyright holder*/
/*  shall not be used in advertising or otherwise to promote the sale, use*/
/*  or other dealings in this Software without prior written authorization*/
/*  of the copyright holder.*/
/* */
/*  $Id: imap4.tcl,v 1.2 2004/06/22 17:47:46 mic42 Exp $*/

/*  TODO*/
/*  - option -inline for ::imap4::fetch, in order to return data as a Tcl list.*/
/*  - Idle mode*/
/*  - Async mode*/
/*  - Authentications*/
/*  - Literals on file mode*/
/*  - isableto without arguments should return the capability list.*/
/*  - fix OR in search, and implement time-related searches*/
/*  All the rest... se the RFC*/

package require Tcl 8.4
package require struct::list 1.4

namespace ::imap4 {
    
    /*  This is where we take state of all the IMAP connections.  */
    /*  The following arrays are indexed with the connection channel*/
    /*  to access the per-channel information.*/

    /*  general connection state info    */
    variable info
    array  info =  {}

    /*  selected mailbox info    */
    variable mboxinfo
    array  mboxinfo =  {}

    /*  messages info    */
    variable msginfo
    array  msginfo =  {}

    /*  inside debug mode? default is off*/
    variable debugmode 0

    /*  Debug mode? Don't use it for production! It will print debugging*/
    /*  information to standard output and run a special IMAP debug mode shell*/
    /*  on protocol error.*/
    
    variable debug 1
    
    /*  Version*/
    variable version "2004-03-07"

}

/*  imap4::open --*/
/* */
/*    Open a new IMAP connection and initialize the protocol handler.*/
/* */
/*    Arguments:*/
/*        hostname    Hostname of the IMAP server to use*/
/*        port        Port to use (defaults to 143)*/
/* */
/*    Results:*/
/*        chan        Identifier for IMAP channel*/
/* */
ret  ::imap4::open (type hostname , optional port =143) {
    set chan [socket $hostname $port]
    fconfigure $chan -encoding binary -translation binary
    # Intialize the connection state array
    ::imap4::initinfo $chan
    # Get the banner
    ::imap4::processline $chan
    # Save the banner
    set ::imap4::info($chan,banner) [::imap4::lastline $chan]
    return $chan
}

/*  imap4::cleanup --*/
/* */
/*    Cleanup the internal state and close the IMAP channel. */
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/* */
/*    Results:*/
/*        chan    Identifier for close IMAP channel*/
/* */
ret  ::imap4::cleanup chan (
    type variable , type info
    , type variable , type mboxinfo
    , type variable , type msginfo
    
    , type close $, type chan
    
    , type array , type unset , type info $, type chan,*
    , type array , type unset , type mboxinfo $, type chan,*
    , type array , type unset , type msginfo $, type chan,*
    
    , type return $, type chan
)

# imap4::lastcode --
#
#   Return the last error code for the IMAP channel.
#
#   Arguments:
#       chan    Identifier for IMAP channel
#
#   Results:
#       code    Last error code for the given channel
#
proc ::imap4::lastcode chan {
    variable info
    return $info($chan,lastcode)
}

/*  imap4::lastline --*/
/* */
/*    Return the last line received from the server.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/* */
/*    Results:*/
/*        line    Last line received from the server*/
/* */
ret  ::imap4::lastline chan (
    type variable , type info
    , type return $, type info($, type chan,, type lastline)
)

# imap4::state --
#
#   Get the current state
#
#   Arguments:
#       chan    Identifier for IMAP channel
#   
#   Results:
#       state   Current state of the channel
#
proc ::imap4::state chan {
    variable info
    return $info($chan,state)
}

/*  imap4::isableto --*/
/* */
/*    Test for capability. Use the capability command*/
/*    to ask the server if not already done by the user.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        capa    Capability to check*/
/* */
/*    Results:*/
/*        1/0     1 if supported, 0 otherwise*/
/* */
ret  ::imap4::isableto (type chan , type capa) {
    variable info
    if {![llength $info($chan,capability)]} {
    if {[::imap4::capability $chan]} {
        # mic42 FIXME: This looks strange, 
        # should probably be an error, as this signals the
        # capabilities request failed
        #
        return 1
    }
    }
    set capa [string toupper $capa]
    expr {[lsearch -exact $info($chan,capability) $capa] != -1}
}

/*  imap4::msginfo --*/
/* */
/*    Get information (previously collected using fetch) from a given message.*/
/*    If the 'info' argument is omitted or a null string, the full list*/
/*    of information available for the given message is returned.*/
/* */
/*    If the required information name is suffixed with a ? character,*/
/*    the command requires true if the information is available, or*/
/*    false if it is not.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        msgid   Message identifier*/
/*        info    Type of info (optional)*/
/*        default default value for info*/
/* */
/*    Results:*/
/*        msginfo The message info requested or */
/*                list of all valid info values if info and default*/
/*                are missing.*/
/* */
ret  ::imap4::msginfo (type chan , type msgid , type args) {
    variable msginfo
    
    switch -- [llength $args] {
    0 {
        set info {}
    }
    1 {
        set info [lindex $args 0]
        set use_defval 0
    }
    2 {
        set info [lindex $args 0]
        set defval [lindex $args 1]
        set use_defval 1
    }
    default {
        error "::imap4::msginfo called with bad number of arguments! Try ::imap4::msginfo channel messageid ?info? ?defaultvalue?"
    }
    }
    set info [string tolower $info]
    # Handle the missing info case
    if {![string length $info]} {
    set list [array names msginfo $chan,$msgid,*]
    set availinfo {}
    foreach l $list {
        lappend availinfo [string range $l \
        [string length $chan,$msgid,] end]
    }
    return $availinfo
    }
    if {[string index $info end] eq {?}} {
    set info [string range $info 0 end-1]
    return [info exists msginfo($chan,$msgid,$info)]
    } else {
    if {![info exists msginfo($chan,$msgid,$info)]} {
        if {$use_defval} {
        return $defval
        } else {
        error "No such information '$info' available for message id '$msgid'"
        }
    }
    return $msginfo($chan,$msgid,$info)
    }
}

/*  imap4::mboxinfo --*/
/* */
/*    Get information on the currently selected mailbox.*/
/*    If the 'info' argument is omitted or a null string, the full list*/
/*    of information available for the mailbox is returned.*/
/* */
/*    If the required information name is suffixed with a ? character,*/
/*    the command requires true if the information is available, or*/
/*    false if it is not.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        info    type of info requested, defaults to {}*/
/* */
/*    Results:*/
/*        mboxinfo    Information about the selected mailbox    */
/*    */
ret  ::imap4::mboxinfo (type chan , optional info ={)} {
    set info [string tolower $info]
    # Handle the missing info case
    if {![string length $info]} {
     list =  [array names ::imap4::mboxinfo $chan,*]
     availinfo =  {}
    foreach l $list {
        lappend availinfo [string range $l \
        [string length $chan,] end]
    }
    return $availinfo
    }
    if {[string index $info end] eq {?}} {
     info =  [string range $info 0 end-1]
    return [info exists ::imap4::mboxinfo($chan,$info)]
    } else {
    if {![info exists ::imap4::mboxinfo($chan,$info)]} {
        error "No such information '$info' available for the current mailbox"
    }
    return $::imap4::mboxinfo($chan,$info)
    }
}

/* */
/* */
/*    Helper procs */
/* */
/* */

/*  imap4::initinfo --*/
/* */
/*    Initialize the per connection info array for a new*/
/*    IMAP connection.*/
/* */
/*    Arguments:*/
/*        chan        Identifier for IMAP channel*/
/* */
/*    Results:*/
/*        none  */
ret  ::imap4::initinfo chan (
    type variable , type info
    , type set , type info($, type chan,, type curtag) 0
    , type set , type info($, type chan,, type state) , type NOAUTH
    , type set , type info($, type chan,, type capability) , optional 
    , type set , type info($, type chan,, type raise_, type on_, type NO) 1
    , type set , type info($, type chan,, type raise_, type on_, type BAD) 1
    , type set , type info($, type chan,, type idle) , optional 
    , type set , type info($, type chan,, type lastcode) , optional 
    , type set , type info($, type chan,, type lastline) , optional 
    , type set , type info($, type chan,, type lastrequest) , optional 
    , type return
)

###############################################################################
#
# Implementations of IMAP protocol commands.
#
#
###############################################################################

# imap4::capability --
#
#   Get capabilties, issues a
#   CAPABILITY command to the server.
#
#   Arguments:
#       chan    Identifer for IMAP channel
#    
#   Results:
#       0/1     0 if successful, 1 otherwise
#
proc ::imap4::capability chan {
    ::imap4::request $chan "CAPABILITY"
    if {[::imap4::getresponse $chan]} {
    return 1
    }
    return 0
}

/*  imap4::check --*/
/* */
/*    CHECK. Flush to disk.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*    */
/*    Results:*/
/*        0/1*/
/*    */
ret  ::imap4::check chan (
    ::type imap4::, type simplecmd $, type chan , type CHECK , type SELECT , optional 
)

# imap4::close --
#
#   Close the mailbox. Permanently removes \Deleted messages and return to
#   the AUTH state.
#
#   Arguments:
#       chan    Identifier for IMAP channel
#   
#   Results:
#       0/1     
#   
#   Side Effects:
#       sets the state info
#
proc ::imap4::close chan {
    if {[::imap4::simplecmd $chan CLOSE SELECT {}]} {
    return 1
    }
    set ::imap4::info($chan,state) AUTH
    return 0
}

/*  imap4::create --*/
/* */
/*    Create a new mailbox.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        mailbox Mailbox name*/
/*    */
/*    Results:*/
/*        0/1*/
/* */
ret  ::imap4::create (type chan , type mailbox) {
    ::imap4::simplecmd $chan CREATE {AUTH SELECT} $mailbox
}

/*  imap4::delete --*/
/*  */
/*    Delete a mailbox*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        mailbox Mailbox name*/
/* */
/*    Results:*/
/*        0/1*/
/* */
ret  ::imap4::delete (type chan , type mailbox) {
    ::imap4::simplecmd $chan DELETE {AUTH SELECT} $mailbox
}

/*  imap4::examine --*/
/* */
/*    Read-only equivalent of SELECT, uses the*/
/*    EXAMINE command.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        mailbox Name of the mailbox to examine,*/
/*                defaults to INBOX.*/
/* */
/*    Results:*/
/*        0/1     0 if successful, 1 otherwise*/
/*       */
ret  ::imap4::examine (type chan , optional mailbox =INBOX) {
    ::imap4::selectmbox $chan EXAMINE $mailbox
}


/*  imap4::fetch --*/
/* */
/*    Fetch a number of attributes from messages*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        range   IMAP range to fetch*/
/*        args    list of attributes to fetch*/
/*    */
/*    Results:*/
/*        0/1     0 if successful, 1 otherwise*/
/* */
/*    Side Effects:*/
/*        */
ret  ::imap4::fetch (type chan , type range , type args) {
    ::imap4::requirestate $chan SELECT
    ::imap4::parserange $chan $range start end
    set items {}
    set hdrfields {}
    foreach w $args {
    switch -glob -- [string toupper $w] {
        ALL {lappend items ALL}
        BODYSTRUCTURE {lappend items BODYSTRUCTURE}
        ENVELOPE {lappend items ENVELOPE}
        FLAGS {lappend items FLAGS}
        SIZE {lappend items RFC822.SIZE}
        TEXT {lappend items RFC822.TEXT}
        HEADER {lappend items RFC822.HEADER}
        UID {lappend items UID}
        *: {
        lappend hdrfields $w
        }
        default {
        # Fixme: better to raise an error here?
        lappend hdrfields $w:
        }
    }
    }
    if {[llength $hdrfields]} {
    set item {BODY[HEADER.FIELDS (}
    foreach field $hdrfields {
        append item [string toupper [string range $field 0 end-1]] { }
    }
    set item [string range $item 0 end-1]
    append item {)]}
    lappend items $item
    }
    # Send the request
    ::imap4::request $chan "FETCH $start:$end ([join $items])"
    if {[::imap4::getresponse $chan]} {
    return 1
    }
    return 0
}

/*  imap4::login --*/
/* */
/*    Login using the IMAP LOGIN command.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        user    Username to use for LOGIN*/
/*        pass    Password to use for LOGIN*/
/* */
/*    Results:*/
/*        0/1     0 if successful, 1 otherwise*/
/* */
/*    Side Effects:*/
/*        move channel to AUTH state if successful*/
/* */
ret  ::imap4::login (type chan , type user , type pass) {
    ::imap4::requirestate $chan NOAUTH
    ::imap4::request $chan "LOGIN $user $pass"
    if {[::imap4::getresponse $chan]} {
    return 1
    }
    set ::imap4::info($chan,state) AUTH
    return 0
}

/*  imap4::noop --*/
/* */
/*    NOOP command. May get information as untagged data.*/
/*    Useful for keeping an IMAP connection alive.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/* */
/*    Results:*/
/*        0/1*/
/*    */
/*    Side Effects:*/
/*        may get information as untagged data*/
/* */
ret  ::imap4::noop chan (
    ::type imap4::, type simplecmd $, type chan , type NOOP , optional NOAUTH =AUTH SELECT , optional 
)

# imap4::rename --
#
#   Rename a mailbox
#
#   Arguments:
#       chan    Identifier for IMAP channel
#       oldname Name of mailbox to rename
#       newname New name of mailbox
#
#   Results:
#       0/1
#
proc ::imap4::rename {chan oldname newname} {
    ::imap4::simplecmd $chan RENAME {AUTH SELECT} $oldname $newname
}

/*  imap4::search --*/
/* */
/*    SEARCH command.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        args    search arguments*/
/* */
/*    Results:*/
/*        0/1*/
/* */
ret  ::imap4::search (type chan , type args) {
    if {![llength $args]} {
    error "missing arguments. Usage: ::imap4::search chan arg ?arg ...?"
    }
    ::imap4::requirestate $chan SELECT
    set imapexpr [::imap4::convert_search_expr $args]
    ::imap4::multiline_prefix_command imapexpr "SEARCH"
    ::imap4::multiline_request $chan $imapexpr
    if {[::imap4::getresponse $chan]} {
    return 1
    }
    return 0
}

/*  imap4::select --*/
/* */
/*    Mailbox selection. Performs a SELECT command.*/
/*    */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        mailbox Name of the mailbox to select,*/
/*                defaults to INBOX.*/
/* */
/*    Results:*/
/*        0/1     0 if successful, 1 otherwise*/
/* */
ret  ::imap4::select (type chan , optional mailbox =INBOX) {
    ::imap4::selectmbox $chan SELECT $mailbox
}

/*  imap4::subscribe --*/
/* */
/*    Subscribe to a mailbox*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        mailbox Name of mailbox*/
/*    */
/*    Results:*/
/*        0/1*/
/* */
ret  ::imap4::subscribe (type chan , type mailbox) {
    ::imap4::simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox
}

/*  imap4::unsubscribe --*/
/* */
/*    Unsubscribe to a mailbox*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        mailbox Name of a mailbox*/
/*    */
/*    Results:*/
/*        0/1*/
/* */
ret  ::imap4::unsubscribe (type chan , type mailbox) {
    ::imap4::simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox
}

/* */
/* */
/*    Protocol support functions*/
/* */
/* */

/*  imap4::literalcount --*/
/* */
/*    Creates an IMAP octect-count.*/
/*    Used to send literals.*/
/* */
/*    Arguments:*/
/*        string      string to check*/
/*    */
/*    Results:*/
/*        litcount    IMAP literal octet count*/
/* */
ret  ::imap4::literalcount string (
    type return ", optional [string =length $string]"
)

# imap4::convert_search_expr --
#
#   Helper for the search command. Convert a programmer friendly expression
#   (actually a tcl list) to the IMAP syntax. Returns a list composed of
#   request, literal, request, literal, ... (to be sent with
#   ::imap4::multiline_request).
#
#   Arguments:
#       expr        Expression to use for search expression
#       
#   Results:
#       imapexpr    IMAP search expression
#
proc ::imap4::convert_search_expr expr {
    set result {}
    while {[llength $expr]} {
    switch -glob -- [string toupper [set token [::struct::list shift expr]]] {
        *: {
        set wanted [::struct::list shift expr]
        ::imap4::multiline_append_command result "HEADER [string range $token 0 end-1]"
        ::imap4::multiline_append_literal result $wanted
        }

        ANSWERED - DELETED - DRAFT - FLAGGED - RECENT -
        SEEN - NEW - OLD - UNANSWERED - UNDELETED -
        UNDRAFT - UNFLAGGED - UNSEEN -
        ALL {::imap4::multiline_append_command result [string toupper $token]}

        BODY - CC - FROM - SUBJECT - TEXT - KEYWORD -
        BCC {
        set wanted [::struct::list shift expr]
        ::imap4::multiline_append_command result "$token"
        ::imap4::multiline_append_literal result $wanted
        }

        OR {
        set first [::imap4::convert_search_expr [::struct::list shift expr]]
        set second [::imap4::convert_search_expr [::struct::list shift expr]]
        ::imap4::multiline_append_command result "OR"
        ::imap4::multiline_concat_expr result $first
        ::imap4::multiline_concat_expr result $second
        }

        NOT {
        set e [::imap4::convert_search_expr [::struct::list shift expr]]
        ::imap4::multiline_append_command result "NOT"
        ::imap4::multiline_concat_expr result $e
        }

        SMALLER -
        LARGER {
        set len [::struct::list shift expr]
        if {![string is integer $len]} {
            error "Invalid integer follows '$token' in IMAP search"
        }
        ::imap4::multiline_append_command result "$token $len"
        }

        ON - SENTBEFORE - SENTON - SENTSINCE - SINCE -
        BEFORE {error "TODO"}

        UID {error "TODO"}
        default {
        error "Syntax error in search expression: '... $token $expr'"
        }
    }
    }
    return $result
}

/*  imap4::multiline_append_command --*/
/* */
/*    Append a command part to a multiline request*/
/* */
/*    Arguments:*/
/*        reqvar  Variable storing the request*/
/*        cmd     command to append*/
/* */
/*    Results:*/
/*        none*/
/* */
ret  ::imap4::multiline_append_command (type reqvar , type cmd) {
    upvar 1 $reqvar req
    if {[llength $req] == 0} {
    lappend req {}
    }
    lset req end "[lindex $req end] $cmd"
}

/*  imap4::multiline_append_literal --*/
/* */
/*    Append a literal to a multiline request. Uses a quoted*/
/*    string in simple cases.*/
/* */
/*    Arguments:*/
/*        reqvar  Variable storing the request*/
/*        lit     literal to append*/
/*    */
/*    Results:*/
/*        none*/
/* */
ret  ::imap4::multiline_append_literal (type reqvar , type lit) {
    upvar 1 $reqvar req
    if {![string is alnum $lit]} {
    lset req end "[lindex $req end] [::imap4::literalcount $lit]"
    lappend req $lit {}
    } else {
    ::imap4::multiline_append_command req "\"$lit\""
    }
}

/*  imap4::multiline_prefix_command --*/
/* */
/*    Prefix a multiline request with a command.*/
/* */
/*    Arguments:*/
/*        reqvar  Variable storing the request*/
/*        cmd     Command to prepend*/
/* */
/*    Results:*/
/*        none*/
/* */
ret  ::imap4::multiline_prefix_command (type reqvar , type cmd) {
    upvar 1 $reqvar req
    if {![llength $req]} {
    lappend req {}
    }
    lset req 0 " $cmd[lindex $req 0]"
}

/*  imap4::multiline_concat_expr --*/
/*    */
/*    Concat an already created search expression to a multiline request.*/
/* */
/*    Arguments:*/
/*        reqvar  Variable storing the request*/
/*        expr    expression to append*/
/* */
/*    Results:*/
/*        ?*/
/* */
ret  ::imap4::multiline_concat_expr (type reqvar , type expr) {
    upvar 1 $reqvar req
    lset req end "[lindex $req end] ([string range [lindex $expr 0] 1 end]"
    set req [concat $req [lrange $expr 1 end]]
    lset req end "[lindex $req end])"
}

/*  imap4::simplecmd --*/
/* */
/*    This a general implementation for a simple implementation*/
/*    of an IMAP command that just requires to call ::imap4::request*/
/*    and ::imap4::getresponse.*/
/* */
/*    Arguments:*/
/*        chan        Identifier for IMAP channel*/
/*        command     IMAP command*/
/*        validstates The valid states for this command*/
/*        args        Arguments to the IMAP command*/
/*        */
ret  ::imap4::simplecmd (type chan , type command , type validstates , type args) {
    ::imap4::requirestate $chan $validstates
    set req "$command"
    foreach arg $args {
    append req " $arg"
    }
    ::imap4::request $chan $req
    if {[::imap4::getresponse $chan]} {
    return 1
    }
    return 0
}

/*  imap4::selectmbox --*/
/* */
/*    General function for mailbox selection.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        cmd     IMAP command to use*/
/*        mailbox Name of mailbox to use*/
/* */
/*    Results:*/
/*        0/1     0 if successful, 1 otherwise*/
/* */
/*    Side Effects:*/
/*        move to SELECT state if successful*/
/* */
ret  ::imap4::selectmbox (type chan , type cmd , type mailbox) {
    ::imap4::requirestate $chan AUTH
    
    # Clean info about the previous mailbox if any,
    # but save a copy to restore this info on error.
    set savedmboxinfo [array get ::imap4::mboxinfo $chan,*]
    array unset ::imap4::mboxinfo $chan,*
    ::imap4::request $chan "$cmd $mailbox"
    if {[::imap4::getresponse $chan]} {
    array set ::imap4::mboxinfo $savedmboxinfo
    return 1
    }
    set ::imap4::info($chan,state) SELECT
    # Set the new name as mbox->current.
    set ::imap4::mboxinfo($chan,current) $mailbox
    return 0
}

/*  imap4::tag --*/
/* */
/*    Return the next tag to use in IMAP requests.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/* */
/*    Results:*/
/*        tag     A valid tag for an IMAP request*/
/* */
ret  ::imap4::tag chan (
    type incr ::, type imap4::, type info($, type chan,, type curtag)
)

# imap4::checkstate --
#
#   Check that the channel is in one of the specified states.
#
#   Arguments:
#       chan    Identifier for IMAP channel
#       states  List of states
#
#   Results:
#       bool    Either 1 or 0.
#   
proc ::imap4::checkstate {chan states} {
    expr {[lsearch -exact $states $::imap4::info($chan,state)] == -1}
}

/*  imap4::requirestate --*/
/* */
/*    Asserts that the channel is in one of the specified states.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/*        states  List of states*/
/* */
/*    Results:*/
/*        none*/
/*    */
/*    Side Effects:*/
/*        An error is raised if the channel is not in one*/
/*        of the states in the states list.*/
/* */
ret  ::imap4::requirestate (type chan , type states) {
    if {[checkstate $chan $states]} {
    error "IMAP channel not in one of the following states: '$state' (current state is '$::imap4::info($chan,state)')"
    }
}

/* */
/* */
/*  procs for decoding IMAP responses and general processing*/
/* */
/* */

/*  imap4::processline --*/
/* */
/*    Process an IMAP response line.*/
/*    This function trades simplicity in IMAP commands*/
/*    implementation with monolitic handling of responses.*/
/*    However note that the IMAP server can reply to a command*/
/*    with many different untagged info, so to have the reply*/
/*    processing centralized makes this simple to handle.*/
/* */
/*    Arguments:*/
/*        chan    Identifier for IMAP channel*/
/* */
/*    Results:*/
/*        tag     Tag found on the line*/
/* */
ret  ::imap4::processline chan (
    type set , type literals , optional 
    , type while 1 , optional 
    # =Read a =line
    if ={[gets $chan =buf] == =-1 , optional 
        error ="IMAP unexpected =EOF from =server."
    
    , type append , type line $, type buf
    # , type Remove , type the , type trailing , type CR , type at , type the , type end , type of , type the , type line, , type if , type any.
    , type if , optional [string =index $line =end] eq ="\r" , optional 
        set =line [string =range $line =0 end-1]
    
    # , type Check , type if , type there , type is , type a , type literal , type to , type read, , type and , type read , type it , type if , type any.
    , type if , optional [regexp ={{([0-9]+)\, type s+$) $buf => length]} {
        # puts "Reading $length bytes of literal..."
        lappend literals [read $chan $length]
    } else {
        break
    }
    }
    set ::imap4::info($chan,lastline) $line

    if {$::imap4::debug} {
    puts "S: $line"
    }

    # Extract the tag.
    set idx [string first { } $line]
    if {$idx == -1 || $idx == 0} {
    ::imap4::protoerror $chan "IMAP: malformed response '$line'"
    }
    set tag [string range $line 0 [expr {$idx-1}]]
    set line [string range $line [expr {$idx+1}] end]
    # If it's just a command continuation response, return.
    if {$tag eq {+}} {return +}
    # Extract the error code, if it's a tagged line
    if {$tag ne {*}} {
    set idx [string first { } $line]
    if {$idx == -1 || $idx == 0} {
        ::imap4::protoerror $chan "IMAP: malformed response '$line'"
    }
    set code [string range $line 0 [expr {$idx-1}]]
    set line [string trim [string range $line [expr {$idx+1}] end]]
    set ::imap4::info($chan,lastcode) $code
    }
    # Extract information from the line
    set dirty 0
    switch -glob -- $line {
    {*\[READ-ONLY\]*} {set ::imap4::mboxinfo($chan,perm) READ-ONLY; incr dirty}
    {*\[READ-WRITE\]*} {set ::imap4::mboxinfo($chan,perm) READ-WRITE; incr dirty}
    {*\[TRYCREATE\]*} {set ::imap4::mboxinfo($chan,perm) TRYCREATE; incr dirty}
    {FLAGS *(*)*} {
        regexp {.*\((.*)\).*} $line => flags
         ::imap4 = ::mboxinfo($chan,flags) $flags
        incr dirty
    }
    {*\[PERMANENTFLAGS *(*)*\]*} {
        regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags
         ::imap4 = ::mboxinfo($chan,permflags) $flags
        incr dirty
    }
    }
    if {!$dirty && $tag eq {*}} {
    /*  FIXME: match should be case insensitive.*/
    switch -regexp -- $line {
        {^[0-9]+\s+EXISTS} {
        regexp {^([0-9]+)\s+EXISTS} $line => ::imap4::mboxinfo($chan,exists)
        incr dirty
        }
        {^[0-9]+\s+RECENT} {
        regexp {^([0-9]+)\s+RECENT} $line => ::imap4::mboxinfo($chan,recent)
        incr dirty
        }
        {.*?\[UIDVALIDITY\s+[0-9]+?\]} {
        regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \
            ::imap4::mboxinfo($chan,uidval)
        incr dirty
        }
        {.*?\[UNSEEN\s+[0-9]+?\]} {
        regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \
            ::imap4::mboxinfo($chan,unseen)
        incr dirty
        }
        {.*?\[UIDNEXT\s+[0-9]+?\]} {
        regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \
            ::imap4::mboxinfo($chan,uidnext)
        incr dirty
        }
        {^[0-9]+\s+FETCH} {
        ret essfetchline $chan $line $literals
        incr dirty
        }
        (^type CAPABILITY\, type s+.*) {
        regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring
        set ::imap4::info($chan,capability) [split [string toupper $capstring]]
        incr dirty
        }
        {^SEARCH\s*$} {
        /*  Search tag without list of messages. Nothing found*/
        /*  so we set an empty list.*/
         ::imap4 = ::mboxinfo($chan,found) {}
        }
        {^SEARCH\s+.*} {
        regexp {^SEARCH\s+(.*)\s*$} $line => foundlist
         ::imap4 = ::mboxinfo($chan,found) $foundlist
        incr dirty
        }
        default {
        if {$::imap4::debug} {
            puts "*** WARNING: unret essed server reply '$line'"
        }
        }
    }
    }
    if ([type string , type length [, type set ::, type imap4::, type info($, type chan,, type idle)]] && $, type dirty) {
    # ... Notify.
    }
    /*  if debug and no dirty and untagged line... warning: unprocessed IMAP line*/
    return $tag
}

/*  imap4::processfetchline --*/
/* */
/*    Process untagged FETCH lines.*/
/* */
/*    Arguments:*/
/*        chan        Identifier for IMAP channel*/
/*        line        Line to process*/
/*        literals    IMAP literals (?)*/
/* */
/*    Results:*/
/*        ?*/
/* */
/*    Side Effects:*/
/*        Fills in the msginfo*/
/* */
ret  ::imap4::processfetchline (type chan , type line , type literals) {
    regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items
    foreach {name val} [imaptotcl items literals] {
    set attribname [switch -glob -- [string toupper $name] {
        INTERNALDATE {format internaldate}
        BODYSTRUCTURE {format bodystructure}
        {BODY\[HEADER.FIELDS*\]} {format fields}
        {BODY.PEEK\[HEADER.FIELDS*\]} {format fields}
        {BODY\[*\]} {format body}
        {BODY.PEEK\[*\]} {format body}
        HEADER {format header}
        RFC822.HEADER {format header}
        RFC822.SIZE {format size}
        RFC822.TEXT {format text}
        ENVELOPE {format envelope}
        FLAGS {format flags}
        UID {format uid}
        default {
        ::imap4::protoerror $chan "IMAP: Unknown FETCH item '$name'. Upgrade the software"
        }
    }]
    switch -- $attribname {
        fields {
        set last_fieldname __garbage__
        foreach f [split $val "\n\r"] {
            # Handle multi-line headers. Append to the last header
            # if this line starts with a tab character.
            if {[string is space [string index $f 0]]} {
            append ::imap4::msginfo($chan,$msgnum,$last_fieldname) " [string range $f 1 end]"
            continue
            }
            # Process the line searching for a new field.
            if {![string length $f]} continue
            if {[set fnameidx [string first ":" $f]] == -1} {
            ::imap4::protoerror $chan "IMAP: Not a valid RFC822 field '$f'"
            }
            set fieldname [string tolower [string range $f 0 $fnameidx]]
            set last_fieldname $fieldname
            set fieldval [string trim \
            [string range $f [expr {$fnameidx+1}] end]]
            set ::imap4::msginfo($chan,$msgnum,$fieldname) $fieldval
        }
        }
        default {
            set ::imap4::msginfo($chan,$msgnum,$attribname) $val
        }
    }
    #puts "$attribname -> [string range $val 0 20]"
    }
}

/*  imap4::parserange --*/
/* */
/*    Parse an IMAP range, store 'start' and 'end' in the*/
/*    named vars. If the first number of the range is omitted,*/
/*    1 is assumed. If the second number of the range is omitted,*/
/*    the value of "exists" of the current mailbox is assumed.*/
/* */
/*    So : means all the messages.*/
/* */
/*    Arguments:*/
/*        chan        Identifier for IMAP channel*/
/*        range       range to parse*/
/*        startvar    variable to store the start in*/
/*        endvar      variable to store the end in*/
/* */
/*    Results:*/
/*        none        */
/* */
/*    Side Effects:*/
/*        results are stored in startvar and endvar*/
/* */
ret  ::imap4::parserange (type chan , type range , type startvar , type endvar) {
    upvar $startvar start $endvar end
    set rangelist [split $range :]
    switch -- [llength $rangelist] {
    1 {
        if {![string is integer $range]} {
        error "Invalid range"
        }
        set start $range
        set end $range
    }
    2 {
        foreach {start end} $rangelist break
        if {![string length $start]} {
        set start 1
        }
        if {![string length $end]} {
        set end [::imap4::mboxinfo $chan exists]
        }
        if {![string is integer $start] || ![string is integer $end]} {
        error "Invalid range"
        }
    }
    default {
        error "Invalid range"
    }
    }
}

/*  imap4::imaptotcl --*/
/* */
/*    Convert IMAP data into Tcl data. Consumes the part of the*/
/*    string converted.*/
/*    'literals' is a list with all the literals extracted*/
/*    from the original line, in the same order they appeared.*/
/* */
/*    Arguments:*/
/*        datavar     variable holding the data to parse*/
/*        literalsvar variable holding the literals*/
/* */
/*    Results:*/
/*        ?*/
/*   */
/*    Side Effects:*/
/*        consumes data from datavar*/
/*        */
ret  ::imap4::imaptotcl (type datavar , type literalsvar) {
    upvar 1 $datavar data $literalsvar literals
    set data [string trim $data]
    switch -- [string index $data 0] {
    \{ {imaptotcl_literal data literals}
    "(" {imaptotcl_list data literals}
    "\"" {imaptotcl_quoted data}
    0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number data}
    \) {imaptotcl_endlist data;# that's a trick to parse lists}
    default {imaptotcl_symbol data}
    }
}

# imap4::imaptotcl_literal --
#
#   Extract a literal
#
#   Arguments:
#       datavar     variable holding the data to parse
#       literalsvar variable holding the literals
#
#   Results:
#       ?
#
#   Side Effects:
#       consumes data from datavar
#
proc ::imap4::imaptotcl_literal {datavar literalsvar} {
    upvar 1 $datavar data $literalsvar literals
    if {![regexp {{.*?}} $data match]} {
    ::imap4::protoerror $chan "IMAP data format error: '$data'"
    }
    set data [string range $data [string length $match] end]
    set retval [lindex $literals 0]
    set literals [lrange $literals 1 end]
    return $retval
}

# imap4::imaptotcl_quoted --
#
#   Extract a quoted string
#
#   Arguments:
#       datavar     variable holding the data to parse
#   
#   Results:
#       string      The extracted string
#
#   Side Effects:
#       consumes data from datavar
#
proc ::imap4::imaptotcl_quoted datavar {
    upvar 1 $datavar data
    if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} {
    ::imap4::protoerror $chan "IMAP data format error: '$data'"
    }
    set data [string range $data [string length $match] end]
    return [string range $match 1 end-1]
}

# imap4::imaptotcl_number --
#
#   Extract a number
#
#   Arguments:
#       datavar     variable holding the data to parse
#   
#   Results:
#       number      An integer number
#
#   Side Effects:
#       consumes data from datavar
#
proc imaptotcl_number datavar {
    upvar 1 $datavar data
    if {![regexp {^[0-9]+} $data match]} {
    ::imap4::protoerror $chan "IMAP data format error: '$data'"
    }
    set data [string range $data [string length $match] end]
    return $match
}

# imap4::imaptotcl_symbol --
#
#   Extract a "symbol". Not really exists in IMAP, but there
#   are named items, and this names have a strange unquoted
#   syntax like BODY[HEAEDER.FIELD (From To)] and other stuff
#   like that.
#
#   Arguments:
#       datavar     variable holding the data to parse
#   
#   Results:
#       match       The symbol found
#
#   Side Effects:
#       consume data from datavar
#
proc ::imap4::imaptotcl_symbol datavar {
    upvar 1 $datavar data
    if {![regexp {([\w\.]+\[[^\[]+\]|[\w\.]+)} $data => match]} {
    ::imap4::protoerror $chan "IMAP data format error: '$data'"
    }
    set data [string range $data [string length $match] end]
    return $match
}

# imap4::imaptotcl_list --
#
#   Extract an IMAP list.
#
#   Arguments:
#       datavar     variable holding the data to parse
#       literalsvar variable holding the literals
#
#   Results:
#       ?
#
#   Side Effects:
#       consumes data from datavar
#
proc ::imap4::imaptotcl_list {datavar literalsvar} {
    upvar 1 $datavar data $literalsvar literals
    set list {}
    # Remove the first '(' char
    set data [string range $data 1 end]
    # Get all the elements of the list. May indirectly recurse called
    # by [imaptotcl].
    while {[string length $data]} {
    set ele [imaptotcl data literals]
    if {$ele eq {)}} {
        break
    }
    lappend list $ele
    }
    return $list
}

# imap4::imaptotcl_endlist --
#
#   Just extracts the ")" character alone.
#   This is actually part of the list extraction work.
#
#   Arguments:
#       datavar     variable holding the data to parse
#       
#   Results:
#       char        The character "("
#
#   Side Effects:
#       consumes data from datavar
#
proc ::imap4::imaptotcl_endlist datavar {
    upvar 1 $datavar data
    set data [string range $data 1 end]
    return ")"
}

######################################################################
#
#   procs for communication with server
#
######################################################################

# imap4::request --
#
#   Write a request to the IMAP channel.
#
#   Arguments:
#       chan    Identifier for IMAP channel
#       request Request to send
#
#   Results:
#       none
#
proc ::imap4::request {chan request} {
    set t "[::imap4::tag $chan] $request"
    if {$::imap4::debug} {
    puts "C: $t"
    }
    set ::imap4::info($chan,lastrequest) $t
    puts -nonewline $chan "$t\r\n"
    flush $chan
}

# imap4::multiline_request --
#
#   Write a multiline request. The 'request' list must contain
#   parts of command and literals interleaved. Literals are at odd
#   list positions (1, 3, ...).
#
#   Arguments:
#       chan    Identifier for IMAP channel
#       request request list
#   
#   Results:
#       none
#
proc ::imap4::multiline_request {chan request} {
    lset request 0 "[::imap4::tag $chan][lindex $request 0]"
    set items [llength $request]
    foreach {line literal} $request {
    # Send the line
    if {$::imap4::debug} {
        puts "C: $line"
    }
    puts -nonewline $chan "$line\r\n"
    flush $chan
    incr items -1
    if {!$items} break
    # Wait for the command continuation response
    if {[::imap4::processline $chan] ne {+}} {
        ::imap4::protoerror $chan "Expected a command continuation response but got '[::imap4::lastline $chan]'"
    }
    # Send the literal
    if {$::imap4::debug} {
        puts "C> $literal"
    }
    puts -nonewline $chan $literal
    flush $chan
    incr items -1
    }
    set ::imap4::info($chan,lastrequest) $request
}

# imap4::getresponse --
#
#   Process IMAP responses. If the IMAP channel is not
#   configured to raise errors on IMAP errors, returns 0
#   on OK response, otherwise 1 is returned.
#
#   Arguments:
#       chan    Identifier for IMAP channel
#   
#   Results:
#       0/1     0 for BAD/NO , 1 for OK
#
#   Side Effects:
#       may raise errors
#
proc ::imap4::getresponse chan {
    # Process lines until the tagged one.
    while {[set tag [::imap4::processline $chan]] eq {*} || $tag eq {+}} {}
    switch -- [::imap4::lastcode $chan] {
    OK {return 0}
    NO {
        if {$::imap4::info($chan,raise_on_NO)} {
        error "IMAP error: [::imap4::lastline $chan]"
        }
        return 1
    }
    BAD {
        if {$::imap4::info($chan,raise_on_BAD)} {
        ::imap4::protoerror $chan "IMAP error: [::imap4::lastline $chan]"
        }
        return 1
    }
    default {
        ::imap4::protoerror $chan "IMAP protocol error. Unknown response code '[::imap4::lastcode $chan]'"
    }
    }
}


########################################################################################
#
#   Debug and example code
#
########################################################################################



# Debug mode.
# This is a developers mode only that pass the control to the
# programmer. Every line entered is sent verbatim to the
# server (after the addition of the request identifier).
# The ::imap4::debug variable is automatically set to '1' on enter.
#
# It's possible to execute Tcl commands starting the line
# with a slash.

proc ::imap4::debugmode {chan {errormsg {None}}} {
    set ::imap4::debugmode 1
    set ::imap4::debugchan $chan
    set welcometext [list \
    "------------------------ IMAP DEBUG MODE --------------------" \
    "IMAP Debug mode usage: Every line typed will be sent" \
    "verbatim to the IMAP server prefixed with a unique IMAP tag." \
    "To execute Tcl commands prefix the line with a / character." \
    "The current debugged channel is returned by the \[me\] command." \
    "Type ! to exit" \
    "Type help for more information" \
    "Type info to see information about the connection" \
    "" \
    "Last error: '$errormsg'" \
    "IMAP library version: '$imap4::version'" \
    "" \
    ]
    foreach l $welcometext {
    puts $l
    }
    ::imap4::debugmode_info $chan
    while 1 {
    puts -nonewline "imap debug> "
    flush stdout
    gets stdin line
    if {![string length $line]} continue
    if {$line eq {!}} exit
    if {$line eq {info}} {
        ::imap4::debugmode_info $chan
        continue
    }
    if {[string index $line 0] eq {/}} {
        catch {eval [string range $line 1 end]} result
        puts $result
    } else {
        ::imap4::request $chan $line
        if {[catch {::imap4::getresponse $chan} error]} {
        puts "--- ERROR ---\n$error\n-------------\n"
        }
    }
    }
}

# Little helper for debugmode command.
proc ::imap4::debugmode_info chan {
    puts "Last sent request: '$imap4::info($chan,lastrequest)'"
    puts "Last received line: '$imap4::info($chan,lastline)'"
    puts ""
}

# Protocol error! Enter the debug mode if ::imap4::debug is true.
# Otherwise just raise the error.
proc ::imap4::protoerror {chan msg} {
    if {$::imap4::debug && !$::imap4::debugmode} {
    ::imap4::debugmode $chan $msg
    } else {
    error $msg
    }
}

proc ::imap4::me {} {
    set ::imap4::debugchan
}

# Other stuff to do in random order...
#
# proc ::imap4::idle notify-command
# proc ::imap4::auth plain ...
# proc ::imap4::securestauth user pass
# proc ::imap4::store
# proc ::imap4::logout (need to clean both msg and mailbox info arrays)
# proc ::imap4::create
# proc ::imap4::delete
# proc ::imap4::list
# ::imap4::search $chan or {flags {seen flagged}} {larger 1000}
# ::imap4::search $chan from: antirez to: ...

################################################################################
# Example
################################################################################

set ::imap4::debug 0
if {[llength $argv] < 3} {
    puts "Usage: imap4.tcl <servername> <username> <password> ?-debugmode?"
    exit
}
if {[llength $argv] > 3} {
    est ::imap4::debug 1
}
foreach {servername username password} $argv break

# Star the connection and select the INBOX mailbox
set imap [::imap4::open $servername]
::imap4::login $imap $username $password
::imap4::select $imap INBOX

# Output all the information about that mailbox
foreach info [::imap4::mboxinfo $imap] {
    puts "$info -> [::imap4::mboxinfo $imap $info]"
}

# Fetch from: to: and size for all the messages
::imap4::fetch $imap : from: to: size header bodystructure

# Show they
for {set i 1} {$i <= [::imap4::mboxinfo $imap exists]} {incr i} {
    puts "$i) To: [::imap4::msginfo $imap $i to: {No To: field}]"
    set bstruct [::imap4::msginfo $imap $i bodystructure]
    if {[string toupper [lindex $bstruct 0]] eq {TEXT}} {
    set bstruct [list $bstruct]
    }
    foreach entry $bstruct {
    puts "\t$entry"
    }
}

# Show all the information available about the message ID 1
puts "Available info about message 1: [::imap4::msginfo $imap 1]"

# Use the capability stuff
::imap4::capability $imap
puts "Is able to idle? [::imap4::isableto $imap idle]"
puts "Is able to jump? [::imap4::isableto $imap jump]"
puts "Is able to imap4rev1? [::imap4::isableto $imap imap4rev1]"

# Show the search feature.
::imap4::search $imap larger 4000 seen
puts "Found messages: [::imap4::mboxinfo $imap found]"

# Enter the debug mode for fun or development time
::imap4::debugmode $imap

# Cleanup
::imap4::cleanup $imap