jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
363 Commits
1 Branch
1 Tag
226 MiB
 
 
 
 
 
 
Tree: ba5a381c07
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'ba5a381c07'
${ noResults }
punkshell/src/modules/punk/imap4-999999.0a1.0.tm

4432 lines
177 KiB
Raw Blame History

# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# IMAP4 protocol pure Tcl implementation.
#
# COPYRIGHT AND PERMISSION NOTICE
#
# Copyright (C) 2025 Julian Noble <julian@precisium.com.au>
# Copyright (C) 2004 Salvatore Sanfilippo <antirez@invece.org>
# Copyright (C) 2013 Nicola Hall <nicci.hall@gmail.com>
# Copyright (C) 2013 Magnatune <magnatune@users.sourceforge.net>
#
# All rights reserved.
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, and/or sell copies of the Software, and to permit persons
# to whom the Software is furnished to do so, provided that the above
# copyright notice(s) and this permission notice appear in all copies of
# the Software and that both the above copyright notice(s) and this
# permission notice appear in supporting documentation.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
# OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
# HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL
# INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING
# FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
# WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
# Except as contained in this notice, the name of a copyright holder
# shall not be used in advertising or otherwise to promote the sale, use
# or other dealings in this Software without prior written authorization
# of the copyright holder.
# TODO
# - Idle mode
# - Async mode
# - More Authentications (currently AUTH_LOGIN AUTH_PLAIN)
# - handle [OVERQUOTA] response
# - Literals on file mode
# - fix OR in search, and implement time-related searches
# All the rest... see the RFCs
#JN TODO
#rfc4551 CONDSTORE - (MODSEQ,NOMODSEQ,HIGHESTMODSEQ)
#rfc2117 IDLE
# History
# 20100623: G. Reithofer, creating tcl package 0.1, adding some todos
# option -inline for ::imap4::fetch, in order to return data as a Tcl list
# isableto without arguments returns the capability list
# implementation of LIST command
# 20100709: Adding suppport for SSL connections, namespace variable
# use_ssl must be set to 1 and package TLS must be loaded
# 20100716: Bug in parsing special leading FLAGS characters in FETCH
# command repaired, documentation cleanup.
# 20121221: Added basic scope, expunge and logout function
# 20130212: Added basic copy function
# 20130212: Missing chan parameter added to all imaptotcl* procs -ger
# 20250223: J. Noble - fork for punk::imap4
# Argument parsing and documentation with punk::args
# Change from use_ssl and debug vars in base namespace to options -security and -debug on OPEN command
# This enables support of simultaneous Imap connections with different values of tls/debug
# Default to either TLS or STARTSSL unless user specifically requests -security none
# API reorg into namespaces, and capitalisation of commands that use the IMAP protocol vs lowercase for operations on already
# retrieved state.
# showlog command to see cli/svr conversation - todo! - disable by default and limit storage.
# Addition of AUTH_PLAIN SASL authentication mechanism
# change isableto -> has_capability (to better reflect capabilities such as LOGINDISABLED)
# 202503 J. Noble - API changes, add more argument parsing/documentation
# Change IMAP API commands that take msgid or range to accept IMAP protocol style sequence-sets
# composed of seq-ranges.
# ie - no longer accept tcllib IMAP4 style range consisting of incomplete colon based ranges such as : :x x:
# Instead we accept the full comma delimited sequence sets and require use of the special * operator in ranges
# e.g 1:* 3,4,10:* etc
# The equivalent of tcllib IMAP's : would be 1:*
# Added GETACL,SETACL,MYRIGHTS,LISTRIGHTS commands.
# Added initial RETURN handling for SEARCH (not yet handling ESEARCH responses)
# Changed OPEN to CONNECT
# (slightly better clarity for API because the IMAP CLOSE command is not the opposite of OPEN)
#
# @@ Meta Begin
# Application punk::imap4 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::imap4 0 999999.0a1.0]
#[copyright "2025"]
#[titledesc {IMAP4 client}] [comment {-- Name section and table of contents description --}]
#[moddesc {IMAP4 client}] [comment {-- Description at end of page heading --}]
#[require punk::imap4]
#[keywords module mail imap imap4 client mailclient]
#[description]
#[para] An implementation of IMAP4 (rev1+?) client protocol
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::imap4
#[subsection Concepts]
#[para] -
tcl::namespace::eval punk::imap4 {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id "(package)punk::imap4"
@package -name "punk::imap4"\
-title "IMAP4 client library"\
-description "An implementation of IMAP4 (rev1+?) client protocol."\
-copyright "2025"
}]
if {[info exists ::argv0] && [info script] eq $::argv0} {
#assert? - if argv0 exists and is same as [info script] - we're not in a safe interp
#when running a tm module as an app - we should calculate the corresponding tm path
#based on info script and the namespace of the package being provided here
#and add that to the tm list if not already present.
#(auto-cater for any colocated dependencies)
set scr [file normalize [info script]]
set ns [namespace current]
#puts "scr:--$scr--"
#puts "ns: --$ns--"
set scriptdir [file dirname $scr]
set mapped [string map {:: \u0FFF} [string trimleft $ns :]]
set nsparts [split $mapped \u0FFF]
set nsprefix [lrange $nsparts 0 end-1]
if {![llength $nsprefix]} {
#current script dir is a tm root
if {$scriptdir ni [tcl::tm::list]} {
tcl::tm::add $scriptdir
}
} else {
set pathparts [file split $scriptdir]
set count_match 0
set i 0
foreach ns_seg [lreverse $nsprefix] path_seg [lreverse $pathparts] {
if {[string tolower $ns_seg] eq [string tolower $path_seg]} {
incr count_match
}
incr i
if {$i >= [llength $nsprefix]} {break}
}
if {$count_match == [llength $nsprefix]} {
set tmparts [lrange $pathparts 0 end-$count_match]
set tmpath [file join {*}$tmparts]
#puts "--adding tmpath $tmpath --"
if {$tmpath ni [tcl::tm::list]} {
tcl::tm::add $tmpath
}
}
}
#app at tail of script
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::imap4
#[list_begin itemized]
package require Tcl 8.6.2-
package require punk::args
package require punk::lib
#*** !doctools
#[item] [package {Tcl 8.6.2-}]
#[item] [package {punk::args}]
#[item] [package {punk::lib}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
tcl::namespace::eval punk::imap4::system {
variable conlog
set conlog [dict create] ;#client/server chat log. keyed on $chan. Members {side c|s type line|chunk data "..."}
proc add_conlog {chan side request_tag type datalist} {
if {$side ni {c s}} {
error "add_conlog side must be c or s"
}
if {$type ni {line literal chunk}} {
error "add_conlog type must be line literal or chunk"
}
variable conlog
set records [list]
foreach d $datalist {
dict lappend conlog $chan [dict create side $side request $request_tag type $type data $d]
}
return [llength $datalist]
}
proc get_conlog {chan {tag *}} {
variable conlog
if {$tag eq "*"} {
return [dict get $conlog $chan]
} else {
#retrieve
set loglist [dict get $conlog $chan]
#review - the relevant loglines should all be tagged with the 'request' key even if response line was a *
return [lsearch -all -inline -index 3 $loglist $tag]
#set result [list]
#set first [lsearch -index 3 $loglist $tag]
#if {$first > -1} {
# set last [lsearch -index 3 -start $first+1 $loglist $tag]
# if {$last > -1} {
# set result [lrange $loglist $first $last]
# } else {
# set result [lrange $loglist $first end] ;#review
# }
#}
#return $result
}
}
}
tcl::namespace::eval punk::imap4::stringprep {
#https://core.tcl-lang.org/tcllib/doc/tcllib-1-18/embedded/www/tcllib/files/modules/stringprep/stringprep.html#3
#RFC3454 - table definitions
#IMAP stringprep Profiles for Usernames RFC4314 RFC5738
#IMAP stringprep Profiles for Passwords RFC5738
#RFC4013 SASLprep: Stringprep Profile for User Names and Passwords
#Prohibited Output
# - Non-ASCII space characters [StringPrep, C.1.2]
# - ASCII control characters [StringPrep, C.2.1]
# - Non-ASCII control characters [StringPrep, C.2.2]
# - Private Use characters [StringPrep, C.3]
# - Non-character code points [StringPrep, C.4]
# - Surrogate code points [StringPrep, C.5]
# - Inappropriate for plain text characters [StringPrep, C.6]
# - Inappropriate for canonical representation characters
# [StringPrep, C.7]
# - Change display properties or deprecated characters
# [StringPrep, C.8]
# - Tagging characters [StringPrep, C.9]
set prohibited_sets {A.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9}
#This profile specifies:
# - non-ASCII space characters [StringPrep, C.1.2] that can be
# mapped to SPACE (U+0020), and
# - the "commonly mapped to nothing" characters [StringPrep, B.1]
# that can be mapped to nothing.
#Unassigned Code points - [STRINGPREP, A.1]
package require stringprep
#Mapping C.1.2 ??
#we only have it in -prohibited - but it seems to be mapped to space, which is what we want - but why?
::stringprep::register saslprep -mapping {B.1} -prohibited $prohibited_sets -normalization KC -prohibitedBidi 1
proc normal_userpass {input} {
#set input [map_to_space $input] ;#C.1.2 non-ascii spaces mapped to space
set normalised [::stringprep::stringprep saslprep $input]
}
#probably unneeded - see command above re mapping C.1.2
proc map_to_space {input} {
#C.1.2 Non-ASCII space characters
#----- Start Table C.1.2 -----
#00A0; NO-BREAK SPACE
#1680; OGHAM SPACE MARK
#2000; EN QUAD
#2001; EM QUAD
#2002; EN SPACE
#2003; EM SPACE
#2004; THREE-PER-EM SPACE
#2005; FOUR-PER-EM SPACE
#2006; SIX-PER-EM SPACE
#2007; FIGURE SPACE
#2008; PUNCTUATION SPACE
#2009; THIN SPACE
#200A; HAIR SPACE
#200B; ZERO WIDTH SPACE
#202F; NARROW NO-BREAK SPACE
#205F; MEDIUM MATHEMATICAL SPACE
#3000; IDEOGRAPHIC SPACE
#----- End Table C.1.2 -----
set map [list \u00A0 " " \u1680 " " \u2000 " " \u2001 " " \u2002 " " \u2003 " " \u2004 " " \u2005 " " \u2006 " " \u2007 " "\
\u2007 " " \u2008 " " \u2009 " " \u200A " " \u200b " " \u202F " " \u205F " " \u3000 " "\
]
return [string map $map $input]
}
}
tcl::namespace::eval punk::imap4::proto {
variable PUNKARGS
variable coninfo
namespace export {[a-z]*}
proc is_imap_number {n} {
return [expr {[string is integer -strict $n] && $n >= 0 && $n <= 4294967296}]
}
proc is_imap_number64 {n} {
return [expr {[string is integer -strict $n] && $n >= 0 && $n <= 9223372036854775807}]
}
proc is_imap_nznumber {n} {
return [expr {[string is integer -strict $n] && $n > 0 && $n <= 4294967296}]
}
proc is_imap_nznumber64 {n} {
return [expr {[string is integer -strict $n] && $n > 0 && $n <= 9223372036854775807}]
}
#JMN 2025 - rename to pop0 to make clear distinction between this and tcl9 builtin lpop
# Pop an element from the list inside the named variable and return it.
# If a list is empty, raise an error. The error is specific for the
# search command since it's the only one calling this function.
if {[info commands ::lpop] ne ""} {
proc pop0 {listvar} {
upvar 1 $listvar l
if {![llength $l]} {
error "Bad syntax for search expression (missing argument)"
}
lpop l 0
}
} else {
proc pop0 {listvar} {
upvar 1 $listvar l
if {![llength $l]} {
error "Bad syntax for search expression (missing argument)"
}
set res [lindex $l 0]
set l [lrange $l 1 end]
return $res
}
}
### connection/protocol state
array set info {} ;# general connection state info.
set coninfo [dict create] ;# connection properties info. keyed on $chan. Members {hostname <host> port <port> debug 0|1 security None|TLS/SSL|STARTSSL}
# Initialize the info array for a new connection.
proc initinfo {chan} {
variable info
set info($chan,curtag) 0
set info($chan,state) NOAUTH
set info($chan,folders) {}
set info($chan,capability) {}
set info($chan,raise_on_NO) 0
set info($chan,raise_on_BAD) 1
set info($chan,idle) {}
set info($chan,lastcode) {}
set info($chan,lastline) {}
set info($chan,lastrequest) {}
#set idle as timestamp of when started?
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::proto::tag
@cmd -name punk::imap4::proto::tag -help\
"Return the next tag to use in IMAP requests."
@leaders -min 0 -max 0
@values -min 1 -max 1
chan -optional 0 -help\
"existing channel for an open IMAP connection"
}]
proc tag {chan} {
variable info
incr info($chan,curtag)
}
# ------------------------------------------------
# used primarily by client api namespace ::punk::imap4 with simple wrappers
# proto functions can access info directly
# ------------------------------------------------
# Returns the last error code received.
proc lastcode {chan} {
variable info
return $info($chan,lastcode)
}
# Returns the last line received from the server.
proc lastline {chan} {
variable info
return $info($chan,lastline)
}
proc lastrequest {chan} {
variable info
return $info($chan,lastrequest)
}
proc lastrequesttag {chan} {
variable info
set lastrequest $info($chan,lastrequest)
#we aren't assuming all request formats are valid Tcl lists
return [punk::imap4::lib::firstword $lastrequest]
}
#experimental
proc resync_tag {chan} {
set last_request_tag [lastrequesttag $chan]
set last_line [lastline $chan]
#word0
set last_response_tag [punk::imap4::lib::firstword $last_line]
puts stderr "last request tag: $last_request_tag"
puts stderr "last response tag: $last_response_tag"
if {$last_response_tag < $last_request_tag} {
set diff [expr {$last_request_tag - $last_response_tag}]
puts stderr "Reading $diff responses to catch up.."
set servertag $last_response_tag
for {set i 0} {$i < $diff} {incr i} {
#JMN
set is_err [catch {getresponse $chan [incr servertag]} getresponse_result]
if {!$is_err} {
if {$getresponse_result == 0} {
puts stderr "READ read number: $i result: $getresponse_result"
} else {
puts stderr "READPROBLEM read number: $i result: $getresponse_result"
}
} else {
puts stderr "READERROR read number: $i"
puts stderr " error: $getresponse_result"
}
}
#todo retest?
puts stderr "Done - view log using 'showlog $chan'"
} elseif {$last_response_tag > $last_request_tag} {
set synctag [expr {$last_response_tag + 1}]
puts stderr "Updating client curtag to $synctag"
upvar ::punk::imap4::proto::info info
set info($chan,curtag) $synctag
puts stderr "calling NOOP"
punk::imap4::NOOP $chan
#todo - retest?
puts stderr "Done"
} else {
puts stderr "resync_tag - OK No difference detected"
}
}
# Get the current state
proc state {chan} {
variable info
return $info($chan,state)
}
# Test for capability. Use the capability command
# to ask the server if not already done by the user.
lappend PUNKARGS [list {
@id -id ::punk::imap4::proto::has_capability
@cmd -name punk::imap4::proto::has_capability -help\
"Return a list of the server capabilities last received,
or a boolean indicating if a particular capability was
present."
@leaders -min 1 -max 1
chan -optional 0 -help\
"existing channel for an open IMAP connection"
@values -min 0 -max 1
capability -type string -default "" -help\
"The name of a capability to look for
in the cached response."
}]
proc has_capability {chan {capability ""}} {
variable info
#REVIEW - do we want this command to re-hit the server?
#Under what circumstances is there nothing cached for the channel?
#set resultcode 0
#if {![llength $info($chan,capability)]} {
# set resultcode [punk::imap4::CAPABILITY $chan] ;#review should unwrap - proto shouldn't depend on cli API namespace ?
#}
if {$capability eq ""} {
#if {$resultcode != 0} {
# # We return empty string on error
# return ""
#}
return $info($chan,capability)
}
set capability [string toupper $capability]
expr {[lsearch -exact $info($chan,capability) $capability] != -1}
}
#requires the listed caps are in the latest capabilities set received..
proc requirecaps {chan requiredcaps} {
variable info
#if {![llength $info($chan,capability)]} {
# punk::imap4::CAPABILITY $chan ;#review should unwrap - proto shouldn't depend on cli API namespace ?
#}
if {![llength $requiredcaps]} {
return
}
set requiredcaps [string toupper $requiredcaps]
set missing [list]
foreach c $requiredcaps {
if {[lsearch $info($chan,capability) $c] == -1} {
lappend missing $c
}
}
if {[llength $missing]} {
if {[llength $missing] == 1} {
set cap [lindex $missing 0]
error "IMAP SERVER has NOT advertised the capability '$cap' in the current protocol state."
} else {
error "IMAP SERVER has NOT advertised the capabilities '$missing' in the current protocol state."
}
}
}
# ------------------------------------------------
# Assert that the channel is one of the specified states
# by the 'states' list.
# otherwise raise an error.
proc requirestate {chan states} {
variable info
if {"*" in $states} {return}
if {[lsearch $states $info($chan,state)] == -1} {
error "IMAP channel not in one of the following states: '$states' (current state is '$info($chan,state)')"
}
}
# This a general implementation for a simple implementation
# of an IMAP command that just requires to call ::imap4::request
# and ::imap4::getresponse.
lappend PUNKARGS [list {
@id -id ::punk::imap4::proto::simplecmd
@cmd -name punk::imap4::proto::simplecmd -help\
"This is a general implementation for a simple
implementation of an IMAP command that is
composed of a a ::punk::imap4::request followed
by a punk::imap4::response"
@leaders -min 1 -max 1
chan -optional 0 -help\
"existing channel for an open IMAP connection"
@opts
-validstates -default * -help\
"A list of valid states from which this
command can be called"
@values -min 1 -max -1
command -type string
arg -multiple 1 -optional 1 -help\
{Each argument for the command must be
supplied in a way that preserved the form
expected by an IMAP server.
For example, if an argument has spaces it
may need to be in double quotes and so need
to be explicitly specified with quotes and a
protecting set of braces.
e.g
simplecmd EXAMINE {"mailbox name with spaces"}
If Tcl variable substitution is required, escapes
within a quoted string could be used, or string map.
e.g
simplecmd $ch SETMETADATA $b "($ann \"$val\")"
}
}]
proc simplecmd {args} {
set argd [punk::args::parse $args withid ::punk::imap4::proto::simplecmd]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set validstates [dict get $opts -validstates]
set command [dict get $values command]
set arglist [list]
if {[dict exists $received arg]} {
set arglist [dict get $values arg]
}
requirestate $chan $validstates
set req "$command"
foreach arg $arglist {
append req " $arg"
}
#let 'request' store the command
set clitag [request $chan $req]
if {[getresponse $chan $clitag] != 0} {
return 1
}
return 0
}
# Write a request. - this risks getting our local state out of sync
proc request {chan request} {
variable info
variable coninfo
#variable pipeline ;#todo??
set clitag [tag $chan]
set t "$clitag [string trim $request]"
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])C: $t"
}
set info($chan,lastrequest) $t
puts -nonewline $chan "$t\r\n"
flush $chan
::punk::imap4::system::add_conlog $chan c $clitag line [list $t]
return $clitag
}
# Process IMAP responses. If the IMAP channel is not
# configured to raise errors on IMAP errors, returns 0
# on OK response, otherwise 1 is returned.
proc getresponse {chan {clitag *}} {
variable info
#todo pipeline - not lastrequest
#this is just an IDLE initial test
set lastcmd [punk::imap4::lib::secondword [lastrequest $chan]]
switch -- $lastcmd {
IDLE {
while {[set responsetag [processline $chan $clitag]] eq {*}} {}
}
default {
# Process lines until the tagged one.
while {[set responsetag [processline $chan $clitag]] eq {*} || $responsetag eq {+}} {}
}
}
switch -- [lastcode $chan] {
OK {
#
return 0
}
NO {
if {$info($chan,raise_on_NO)} {
error "IMAP error: [lastline $chan]"
}
return 1
}
BAD {
if {$info($chan,raise_on_BAD)} {
protoerror $chan "IMAP error: [lastline $chan]"
}
return 1
}
+ {
if {$lastcmd eq "IDLE"} {
#todo - verify '+ idling' case?
set info($chan,idle) [clock seconds]
} else {
#assert - can't happen
}
return 1
}
default {
protoerror $chan "IMAP protocol error. Unknown response code '[lastcode $chan]'"
}
}
}
# Process an IMAP response 'logical' line.
# This function trades simplicity in IMAP commands
# implementation with monolithic handling of responses.
# However note that the IMAP server can reply to a command
# with many different untagged responses, so to have the reply
# processing centralized makes this simple to handle.
#
# Returns the line's tag.
proc processline {chan request_tag} {
variable info ;#state info
variable coninfo ;#general server/connection info vs state info
#upvar ::punk::imap4::mboxinfo mboxinfo
upvar ::punk::imap4::folderinfo folderinfo
#consider the following FETCH response lines with literals
#This entire sequence is what we process as a 'line' here
#* 53 FETCH (RFC822.HEADER {4215}\r\n
#<4215 bytes>
#BODY[] {5150}\r\n
#<5150 bytes>
#)\r\n
chan conf $chan -blocking 1
set literals {}
set line ""
while {1} {
# Read a physical line - which may be only part of the logical line if there is a 'literal' specifier
if {[gets $chan buf] == -1} {
error "([dict get $coninfo $chan hostname])IMAP unexpected EOF from server."
}
# Remove the trailing CR at the end of the buf, if any.
if {[string index $buf end] eq "\r"} {
set buf [string range $buf 0 end-1]
}
::punk::imap4::system::add_conlog $chan s $request_tag line [list $buf] ;#
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])S: $buf"
}
append line $buf
# Check if there is a literal specified.
# It will always occur at the end of a line - followed by the data to read
if {[regexp {{([0-9]+)}\s*$} $buf => length]} {
# puts "Reading $length bytes of literal..."
set chunk [read $chan $length]
lappend literals $chunk
#add_conlog $chan $side $type <datalist>
::punk::imap4::system::add_conlog $chan s $request_tag literal [list [dict create length $length lines [llength [split $chunk \n]]]]
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])s: <$length bytes>"
::punk::imap4::system::add_conlog $chan s $request_tag chunk [list [list length $length chunk $chunk]]
}
} else {
#We are at the end of a single line,
#or a sequence of 1 or more physical lines which had trailing literal specifiers {nnn} followed by data we have read.
break
}
}
set info($chan,lastline) $line
# Extract the tag.
set idx [string first { } $line]
if {$idx <= 0} {
protoerror $chan "IMAP: malformed response '$line'"
}
set tag [string range $line 0 $idx-1]
set line [string range $line $idx+1 end]
# If it's just a command continuation response, return. REVIEW
#except for IDLE (others?)
if {$tag eq {+}} {return +}
# Extract the error code, if it's a tagged line
if {$tag ne "*"} {
set idx [string first { } $line]
if {$idx <= 0} {
protoerror $chan "IMAP: malformed response '$line'"
}
set code [string range $line 0 $idx-1]
set line [string trim [string range $line $idx+1 end]]
set info($chan,lastcode) $code
}
set dirty 0 ;#review - naming as 'dirty' seems odd
#This seems to just indicate we've already matched a result as the implementation
#splits the scanning into two switch statements.
# Extract information from the line
switch -glob -- $line {
{*\[READ-ONLY\]*} {::punk::imap4::_set_mboxinfo $chan perm READ-ONLY; incr dirty}
{*\[READ-WRITE\]*} {::punk::imap4::_set_mboxinfo $chan perm READ-WRITE; incr dirty}
{*\[TRYCREATE\]*} {::punk::imap4::_set_mboxinfo $chan perm TRYCREATE; incr dirty}
{LIST *(*)*} {
# regexp not secure enough ... delimiters must be PLAIN SPACES (see RFC)
# set res [regexp {LIST (\(.*\))(!?\s)[ ](.*)$} $line => flags delim fname]
# p1| p2| p3|
# LIST (\Noselect) "/" ~/Mail/foo
set p1 [string first "(" $line]
set p2 [string first ")" $line $p1+1]
set p3 [string first " " $line $p2+2]
if {$p1<0||$p2<0||$p3<0} {
protoerror $chan "IMAP: Not a valid RFC822 LIST format in '$line'"
}
set flags [string range $line $p1+1 $p2-1]
set delim [string range $line $p2+2 $p3-1]
set fname [string range $line $p3+1 end]
if {$fname eq ""} {
set folderinfo($chan,delim) [string trim $delim "\""]
} else {
set fflag {}
foreach f [split $flags] {
lappend fflag $f
}
lappend folderinfo($chan,names) $fname
lappend folderinfo($chan,flags) [list $fname $fflag]
if {$delim ne "NIL"} {
set folderinfo($chan,delim) [string trim $delim "\""]
}
}
incr dirty
}
{FLAGS *(*)*} {
regexp {.*\((.*)\).*} $line => flags
#set mboxinfo($chan,flags) $flags
::punk::imap4::_set_mboxinfo $chan flags $flags
incr dirty
}
{*\[PERMANENTFLAGS *(*)*\]*} {
regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags
#set mboxinfo($chan,permflags) $flags
::punk::imap4::_set_mboxinfo $chan permflags $flags
incr dirty
}
{*\[CAPABILITY *\]*} {
#can appear in tagged responses to LOGIN or AUTHENTICATE
#e.g
#cli> 1 LOGIN user pass
#svr> 1 OK [CAPABILITY IMAP4rev1 ... ] User logged in SESSIONID=<server.example.com-xxx-xxxx-x-xxx>
regexp {.*\[CAPABILITY\s+(.*)\]\s*(.*)$} $line => capstring tailstring
#consider the capability: RIGHTS=kxten
#Probably inappropriate to convert to uppercase, standard rights are defined as lowercase.
#(no uppercase rights currently allowed - but perhaps that may change?)
# Unknown if there are other capabilities with lowercase values.
#set info($chan,capability) [split [string toupper $capstring]]
set info($chan,capability) [split $capstring]
incr dirty
if {$tailstring ne ""} {
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])*** WARNING: unprocessed TAIL after CAPABILITY '$line'"
}
}
}
}
#If tag eq * - we could still have an OK not stripped from line above
#e.g initial connection response
#REVIEW -
if {!$dirty && $tag eq {*}} {
switch -regexp -nocase -- $line {
{^[0-9]+\s+EXISTS} {
#regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists)
regexp {^([0-9]+)\s+EXISTS} $line => val
punk::imap4::_set_mboxinfo $chan exists $val
incr dirty
}
{^[0-9]+\s+RECENT} {
#DEPRECATED response for imaprev2 - should ignore?
#regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent)
regexp {^([0-9]+)\s+RECENT} $line => val
punk::imap4::_set_mboxinfo $chan recent $val
incr dirty
}
{.*?\[UIDVALIDITY\s+[0-9]+?\]} {
#regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \
# mboxinfo($chan,uidval)
regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => val
punk::imap4::_set_mboxinfo $chan uidval $val
incr dirty
}
{.*?\[UNSEEN\s+[0-9]+?\]} {
#regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \
# mboxinfo($chan,unseen)
regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => val
punk::imap4::_set_mboxinfo $chan unseen $val
incr dirty
}
{.*?\[UIDNEXT\s+[0-9]+?\]} {
#regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \
# mboxinfo($chan,uidnext)
regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => val
punk::imap4::_set_mboxinfo $chan uidnext $val
incr dirty
}
{^[0-9]+\s+FETCH} {
processfetchline $chan $request_tag $line $literals
incr dirty
}
{^METADATA} {
#e.g
#* METADATA test1 ("/private/specialuse" NIL)
# or
#* METADATA Drafts ("/private/specialuse" {7}
# \Drafts
#)
processmetadataline $chan $request_tag $line $literals
#incr dirty ;#??? review
}
{^MYRIGHTS\s+} {
#line eg: MYRIGHTS INBOX lrswipkxtecdan
#puts stderr "line: $line"
set words [punk::imap4::lib::imapwords $line 3]
if {[dict size $words] == 3} {
set mbox [dict get $words 1 value]
set myrights [dict get $words 2 value]
#set folderinfo($chan,myrights)
} else {
puts stderr "processline unable to make sense of MYRIGHTS response: $line"
puts stderr "words:$words"
}
}
{^CAPABILITY\s+.*} {
#direct response to a CAPABILITY request
#e.g
# cli> 2 CAPABILITY
# svr> * CAPABILITY IMAP4rev1 LITERAL+ ...
# svr> 2 OK Completed
regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring
set info($chan,capability) [split [string toupper $capstring]]
incr dirty
}
{^OK\s+.*} - {^PREAUTH\s+.*} {
#initial * OK or * PREAUTH response - can contain CAPABILITY list
if {[regexp {.*\s+\[CAPABILITY\s+(.*)\]\s*(.*)$} $line => capstring tailstring]} {
#e.g greeting: * OK [CAPABILITY X Y Z ...] server.example.com server ready
set info($chan,capability) [split [string toupper $capstring]]
incr dirty
if {$tailstring ne ""} {
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])*** WARNING: unprocessed TAIL after CAPABILITY '$line'"
}
}
}
}
{^LIST\s*$} {
#regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists)
regexp {^([0-9]+)\s+EXISTS} $line => val
punk::imap4::_set_mboxinfo $chan exists $val
incr dirty
}
{^SEARCH\s*$} {
# Search tag without list of messages. Nothing found
# so we set an empty list.
#set mboxinfo($chan,found) {}
::punk::imap4::_set_mboxinfo $chan found {}
}
{^SEARCH\s+.*} {
regexp {^SEARCH\s+(.*)\s*$} $line => foundlist
#set mboxinfo($chan,found) $foundlist
::punk::imap4::_set_mboxinfo $chan found $foundlist
incr dirty
}
default {
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])*** WARNING: unprocessed server reply '$line'"
}
}
}
}
if {[string length [set info($chan,idle)]] && $dirty} {
# ... Notify.
puts stderr "idle is [set info($chan,idle)]"
}
# if debug and no dirty and untagged line... warning: unprocessed IMAP line
return $tag
}
proc processmetadataline {chan request_tag line literals} {
#our lines here have had the literals separated out
#so we get complete lines where the literal acts as a placeholder
#e.g METADATA Junk ("/private/specialuse" {5})
#puts stderr "processmetadataline: $line"
set words [punk::imap4::lib::imapwords $line]
set msgbox [dict get $words 1 value]
set resultlist [dict get $words 2 value]
if {[string index $resultlist 0] ne "("} {
protoerror $chan "IMAP: METADATA malformed response '$line'"
}
set itemwords [punk::imap4::lib::imapwords [string range $resultlist 1 end-1]] ;#strip () and process contents
set items [list]
#use lib::imapwords_resolved?
dict for {w wordinfo} $itemwords {
if {[dict get $wordinfo type] eq "literal"} {
set lit [dict get $wordinfo value]
set litinner [string range $lit 1 end-1]
set litinner [string map {+ "" - ""} $litinner] ;#review
set val [::lpop literals 0]
if {[string is integer -strict $litinner] && [string length $val] == $litinner} {
lappend items $val
} else {
protoerror $chan "IMAP: METADATA malformed response ($lit mismatch size of literal [string length $val]) '$line'"
}
} else {
lappend items [dict get $wordinfo value]
}
}
puts stderr "msgbox: $msgbox items: $items"
foreach {annotation val} $items {
#todo -cache? where?
#folderinfo is for last LIST command
#
puts stderr "msgbox: $msgbox annotation: $annotation value: $val"
}
#set match [regexp -nocase {METADATA\s+(\S+){1}\s+(\(.*\))} $line => msgbox items]
#review - can we ever get more than one annotation/val for a metadata request?
#foreach {annotation val} [imaptotcl $chan items literals] {
#}
}
# Process untagged FETCH lines.
proc processfetchline {chan request_tag line literals} {
regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items
foreach {name val} [imaptotcl $chan items literals] {
set attribname [switch -glob -- [string toupper $name] {
INTERNALDATE {string cat INTERNALDATE}
BODY {string cat BODY}
BODYSTRUCTURE {string cat BODYSTRUCTURE}
{BODY\[HEADER.FIELDS*\]} {string cat fields}
{BODY.PEEK\[HEADER.FIELDS*\]} {string cat fields}
{BODY\[*\]} {string cat $name}
{BODY.PEEK\[*\]} {string cat $name}
HEADER {string cat HEADER}
RFC822.HEADER {
#deprecated in rfc9051
string cat RFC822.HEADER
}
RFC822.TEXT {
string cat RFC822.TEXT
}
RFC822.SIZE {string cat RFC822.SIZE}
ENVELOPE {string cat ENVELOPE}
FLAGS {string cat FLAGS}
UID {string cat UID}
default {
#protoerror $chan "IMAP: Unknown FETCH item '$name'. Upgrade the software"
#use the raw query as an atribute name
string cat $name
}
}]
switch -- $attribname {
fields {
set last_fieldname __garbage__
set parts [list]
set startline 0
set nextcrlf [string first \r\n $val]
while {$nextcrlf >= 0} {
lappend parts [string range $val $startline $nextcrlf-1]
set startline [expr {$nextcrlf+2}]
set nextcrlf [string first \r\n $val $startline]
}
lappend parts [string range $val $startline end]
foreach f $parts {
#RFC5322 - folding continuation lines cannot contain only white space
if {![string length $f]} continue ;#review
# Handle multi-line headers. Append to the last header
# if this line starts with a tab character.
if {[string is space [string index $f 0]]} {
#append msginfo($chan,$msgnum,$last_fieldname) " [string range $f 1 end]"
#RFC5322 - modern unfolding involves simply removing any CRLF that is immediately followed by whitespace - not adding an additional space or collapsing leading whitespace.
#This is different to RFC822 unfolding
punk::imap4::_append_msginfo_field $chan $msgnum $request_tag $last_fieldname $f
continue
}
# Process the line searching for a new field.
if {[set fnameidx [string first ":" $f]] == -1} {
protoerror $chan "IMAP: Not a valid RFC822 field '$f'"
}
set fieldname [string tolower [string range $f 0 $fnameidx]]
set last_fieldname $fieldname
set fieldval [string trim \
[string range $f $fnameidx+1 end]]
#NOTE we can have repeated headers. e.g the old-school Received: header
# or more modern trace headers.
punk::imap4::_set_msginfo_field $chan $msgnum $request_tag $fieldname $fieldval
}
}
default {
#set msginfo($chan,$msgnum,$attribname) $val
punk::imap4::_set_msginfo_field $chan $msgnum $request_tag $attribname $val
}
}
#puts "$attribname -> [string range $val 0 20]"
}
# punk::imap4::_display_msginfo $chan
}
# Write a multiline request. The 'request' list must contain
# parts of command and literals interleaved. Literals are at odd
# list positions (1, 3, ...).
proc multiline_request {chan request} {
variable info
variable coninfo
set request_tag [tag $chan]
lset request 0 "$request_tag [lindex $request 0]"
set items [llength $request]
foreach {line literal} $request {
# Send the line
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])C: $line"
}
puts -nonewline $chan "$line\r\n"
flush $chan
set info($chan,lastrequest) "$line"
::punk::imap4::system::add_conlog $chan c $request_tag line [list $line]
incr items -1
if {!$items} break
# Wait for the command continuation response
if {[processline $chan $request_tag] ne {+}} {
protoerror $chan "Expected a command continuation response but got '[lastline $chan]'"
}
# Send the literal
if {[dict get $coninfo $chan debug]} {
puts "([dict get $coninfo $chan hostname])C> $literal"
}
puts -nonewline $chan $literal
flush $chan
incr items -1
#REVIEW
::punk::imap4::system::add_conlog $chan c $request_tag chunk [list [list length [string length $literal] chunk $literal]]
}
}
# Convert IMAP data into Tcl data. Consumes the part of the
# string converted.
# 'literals' is a list with all the literals extracted
# from the original line, in the same order they appeared.
proc imaptotcl {chan datavar literalsvar} {
upvar 1 $datavar data $literalsvar literals
set data [string trim $data]
#don't use backslash esc in switch statement - still wrecks jump table optimisation in Tcl 8.6,9
switch -- [string index $data 0] {
"{" {imaptotcl_literal $chan data literals}
"(" {imaptotcl_list $chan data literals}
{"} {imaptotcl_quoted $chan data}
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number $chan data}
")" {
imaptotcl_endlist $chan data;# that's a trick to parse lists
}
"}" -
default {imaptotcl_symbol $chan data}
}
}
# Extract a literal
proc imaptotcl_literal {chan datavar literalsvar} {
upvar 1 $datavar data $literalsvar literals
if {![regexp {{.*?}} $data match]} {
protoerror $chan "IMAP data format error: '$data'"
}
set data [string range $data [string length $match] end]
# ------
#set retval [::lpop literals 0]
set retval [lindex $literals 0]
set literals [lrange $literals 1 end]
# ------
return $retval
}
# Extract a quoted string
proc imaptotcl_quoted {chan datavar} {
upvar 1 $datavar data
if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} {
protoerror $chan "IMAP data format error: '$data'"
}
set data [string range $data [string length $match] end]
return [string range $match 1 end-1]
}
# Extract a number
proc imaptotcl_number {chan datavar} {
upvar 1 $datavar data
if {![regexp {^[0-9]+} $data match]} {
protoerror $chan "IMAP data format error: '$data'"
}
set data [string range $data [string length $match] end]
return $match
}
# Extract a "symbol". Not really exists in IMAP, but there
# are named items, and this names have a strange unquoted
# syntax like BODY[HEADER.FIELD (From To)] and other stuff
# like that.
proc imaptotcl_symbol {chan datavar} {
upvar 1 $datavar data
# matching patterns: "BODY[HEADER.FIELD",
# "HEADER.FIELD", "\Answered", "$Forwarded"
#set pattern {([\w\.]+\[[^\[]+\]|[\w\.]+|[\\\$]\w+)}
#some examples that should also match:
# BODY[]
# BODY[]<0.100> ;#first 100 bytes
# BINARY.PEEK[1]<100.200>
set pattern {([\w\.]+\[[^\[]*\](?:\<[^\>]*\>)*|[\w\.]+|[\\\$]\w+)}
if {![regexp $pattern $data => match]} {
protoerror $chan "IMAP data format error: '$data'"
}
set data [string range $data [string length $match] end]
return $match
}
# Extract an IMAP list.
proc imaptotcl_list {chan datavar literalsvar} {
upvar 1 $datavar data $literalsvar literals
set list {}
# Remove the first '(' char
set data [string range $data 1 end]
# Get all the elements of the list. May indirectly recurse called
# by [imaptotcl].
while {[string length $data]} {
set ele [imaptotcl $chan data literals]
if {$ele eq {)}} {
break
}
lappend list $ele
}
return $list
}
# Just extracts the ")" character alone.
# This is actually part of the list extraction work.
proc imaptotcl_endlist {chan datavar} {
upvar 1 $datavar data
set data [string range $data 1 end]
return ")"
}
# Creates an IMAP octect-count.
# Used to send literals.
proc literalcount {string} {
return "{[string length $string]}"
}
# Append a command part to a multiline request
proc multiline_append_command {reqvar cmd} {
upvar 1 $reqvar req
if {[llength $req] == 0} {
lappend req {}
}
lset req end "[lindex $req end] $cmd"
}
# Append a literal to a multiline request. Uses a quoted
# string in simple cases.
proc multiline_append_literal {reqvar lit} {
upvar 1 $reqvar req
if {![string is alnum $lit]} {
lset req end "[lindex $req end] [literalcount $lit]"
lappend req $lit {}
} else {
multiline_append_command req "\"$lit\""
}
}
# Prefix a multiline request with a command.
proc multiline_prefix_command {reqvar cmd} {
upvar 1 $reqvar req
if {![llength $req]} {
lappend req {}
}
#Extra space between tag and command can cause NULL command error on at least some servers (cyrus)
#lset req 0 " $cmd[lindex $req 0]"
lset req 0 "$cmd[lindex $req 0]"
}
# Concat an already created search expression to a multiline request.
proc multiline_concat_expr {reqvar expr} {
upvar 1 $reqvar req
lset req end "[lindex $req end] ([string range [lindex $expr 0] 1 end]"
set req [concat $req [lrange $expr 1 end]]
lset req end "[lindex $req end])"
}
# Helper for the search command. Convert a programmer friendly expression
# (actually a tcl list) to the IMAP syntax. Returns a list composed of
# request, literal, request, literal, ... (to be sent with
# ::imap4::multiline_request).
proc convert_search_expr {expr} {
set result {}
while {[llength $expr]} {
switch -glob -- [string toupper [set token [pop0 expr]]] {
ANSWERED - DELETED - DRAFT - FLAGGED - RECENT -
SEEN - NEW - OLD - UNANSWERED - UNDELETED -
UNDRAFT - UNFLAGGED -
UNSEEN {
multiline_append_command result [string toupper $token]
}
BODY - CC - FROM - SUBJECT - TEXT - KEYWORD -
BCC {
set wanted [pop0 expr]
multiline_append_command result "$token"
multiline_append_literal result $wanted
}
OR {
set first [convert_search_expr [pop0 expr]]
set second [convert_search_expr [pop0 expr]]
multiline_append_command result "OR"
multiline_concat_expr result $first
multiline_concat_expr result $second
}
ALL {
#ALL messages in the mailbox: the default inital key for ANDing
#also RETURN ALL - trigger ESEARCH response code?
multiline_append_command result [string toupper $token]
}
FUZZY {
#RFC6203
set argset [convert_search_expr [pop0 expr]]
multiline_append_command result "FUZZY"
multiline_concat_expr result $argset
}
RETURN {
set options [convert_search_expr [pop0 expr]]
multiline_append_command result "RETURN"
multiline_concat_expr result $options
}
COUNT - MIN - MAX - SAVE {
multiline_append_command result [string toupper $token]
}
NOT {
set e [convert_search_expr [pop0 expr]]
multiline_append_command result "NOT"
multiline_concat_expr result $e
}
SMALLER -
LARGER {
set len [pop0 expr]
if {![string is integer $len]} {
error "Invalid integer follows '$token' in IMAP search"
}
multiline_append_command result "$token $len"
}
ON - SENTBEFORE - SENTON - SENTSINCE - SINCE -
BEFORE {error "TODO"}
UID {error "TODO"}
default {
#*: {
#}
if {[string index $token end] eq ":"} {
set wanted [pop0 expr]
multiline_append_command result "HEADER [string range $token 0 end-1]"
multiline_append_literal result $wanted
} else {
error "Syntax error in search expression: '... $token $expr'"
}
}
}
}
return $result
}
# ------------------------------------------------------------------------------------------------------
#RFC2086
set rights_2086 [dict create\
l "lookup (mailbox i- s visible to LIST/LSUB commands)"\
r "read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL, SEARCH, COPY from mailbox)"\
s "keep seen/unseen information across sessions (STORE SEEN flag)"\
w "write (STORE flags other than SEEN and DELETED)"\
i "insert (perform APPEND, COPY into mailbox)"\
p "post (send mail to submission address for mailbox, not enforced by IMAP4 itself)"\
c "create (CREATE new sub-mailboxes in any implementation-defined hierarchy)"\
d "delete (STORE DELETED flag, perform EXPUNGE)"\
a "administer (perform SETACL)"\
]
#c and d in 2086 have ambiguity
#RFC4314 'obsoleted' them but reclassified them as 'virtual rights'
#For backwards compatibility with clients - more modern servers MUST still include c and d in ACL/MYRIGHTS responses when appropriate.
#RFC4314
set rights_4314 [dict create\
l {lookup (mailbox is visible to LIST/LSUB commands, SUBSCRIBE mailbox)}\
r {read (SELECT the mailbox, perform STATUS)}\
s {keep seen/unseen information across sessions (set or clear \SEEN flag via STORE, also set \SEEN during APPEND/COPY/FETCH BODY[...])}\
w {write (set or clear flags other than \SEEN and \DELETED via STORE, also set them during APPEND/COPY)}\
i {insert (perform APPEND, COPY into mailbox)}\
p {post (send mail to submission address for mailbox, not enforced by IMAP4 itself)}\
k {create mailboxes (CREATE new sub-mailboxes in any implementation-defined hierarchy, parent mailbox for the new mailbox name in RENAME)}\
x {delete mailbox (DELETE mailbox, old mailbox name in RENAME)}\
t {delete messages (set or clear \DELETED flag via STORE, set \DELETED flag during APPEND/COPY)}\
e {perform EXPUNGE and expunge as a part of CLOSE}\
a {administer (perform SETACL/DELETEACL/GETACL/LISTRIGHTS)}\
]
#some servers chose 2086 "c" to control the DELETE command
set rights_1 [dict create\
create {k x}\
delete {e t}\
]
#some servers chose 2086 "d" to control the DELETE command
set rights_2 [dict create\
create {k}\
delete {e t x}\
]
# "n" right? RFC?
set virtual_rights [dict create\
d delete\
c create\
]
#TODO
proc rights_info {} {
}
# ------------------------------------------------------------------------------------------------------
# Protocol error! Enter the debug mode if ::imap4::debug is true.
# Otherwise just raise the error.
proc protoerror {chan msg} {
variable coninfo
upvar ::punk::imap4::debugmode debugmode
if {[dict get $coninfo $chan debug] && !$debugmode} {
#todo - cater for async/idle etc -
punk::imap4::debugmode $chan $msg
} else {
error $msg
}
}
# Little helper for debugmode command.
proc debugmode_info {chan} {
variable coninfo
set h [dict get $coninfo $chan hostname]
puts "($h)Last sent request : '[lastrequest $chan]'"
puts "($h)Last received line: '[lastline $chan]'"
puts ""
}
}
tcl::namespace::eval punk::imap4 {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::imap4}]
#[para] Core API functions for punk::imap4
#[list_begin definitions]
variable PUNKARGS
variable debugmode 0 ;# inside debug mode? usually not.
variable folderinfo
variable mboxinfo
variable msginfo
# 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 [dict create]
# Version
variable version "2025-02-25"
# 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.
### client cached state
array set folderinfo {} ;# list of folders.
set mboxinfo [dict create] ;# selected mailbox info.
set msginfo [dict create] ;#messages info.
lappend PUNKARGS [list {
@id -id ::punk::imap4::CONNECT
@cmd -name punk::imap4::CONNECT -help\
"Open a new IMAP connection and initialise the handler.
Returns the Tcl channel to use in subsequent calls to
the API. Other API commands will return zero on success.
e.g
${[punk::args::tclcore::argdoc::example {
% set chan [CONNECT mail.example.com]
sock123aaa456789
% AUTH_PLAIN $chan user pass
0
... EXAMINE/CLOSE mailboxes, SEARCH, FETCH etc ...
% LOGOUT $chan
0}]}"
@leaders -min 0 -max 0
-debug -type boolean -default 0 -help\
"Display some of the cli/server interaction on stdout
during commands. This can be set or queried using
the 'debugchan $chan ?bool?' command."
-security -nocase 1 -choices {None TLS/SSL STARTTLS} -help\
"Connection security.
TLS/SSL is recommended (implicit TLS).
If port is 143 and -security is omitted, then it will
default to STARTTLS.
For any other port, or omitted port, the default for
-security is TLS/SSL.
ie if no channel security is wanted, then -security
should be explicitly set to None."
@values -min 1 -max 2
hostname -optional 0 -help\
"Host/IP Address of server.
port may optionally be specified at tail of hostname
after a colon, but not if the following optional port
argument to the command is also supplied and is non-zero.
e.g
server.example.com:143
[::1]::993
"
port -optional 1 -type integer -help\
"Port to connect to.
If port is omitted:
defaults to 143 when -security None or STARTTLS
defaults to 993 when -security TLS/SSL or -security is omitted."
}]
proc CONNECT {args} {
set argd [punk::args::parse $args withid ::punk::imap4::CONNECT]
lassign [dict values $argd] leaders opts values received
set hostname [dict get $values hostname]
if {[dict exists $received -security]} {
set opt_security [dict get $opts -security]
} else {
set opt_security unspecified
}
lassign [punk::imap4::lib::parse_address_port $hostname] address addrport
if {![dict exists $received port] || ([dict exists $received port] && [dict get $values port] == 0)} {
set arg_port 0
}
if {$arg_port != 0 && $addrport != 0} {
puts stderr "Cannot specify port both in port argument as well as in hostname"
puts stderr [punk::args::usage -scheme error ::punk::imap4::CONNECT]
return
}
if {$addrport != 0} {
set specified_port $addrport
} else {
set specified_port $arg_port ;#may still be 0
}
if {$specified_port == 0} {
#port unspecified - set based on what/whether -security is specified
switch -- $opt_security {
None - STARTTLS {
set port 143
}
TLS/SSL - unspecified {
set port 993
set opt_security TLS/SSL
}
}
} else {
#port is specified and not 0
set port $specified_port
if {$port == 143} {
if {$opt_security eq "unspecified"} {
set opt_security STARTTLS
}
} else {
#assume any other port is TLS/SSL by default if user didn't specify
if {$opt_security eq "unspecified"} {
set opt_security TLS/SSL
}
}
}
set opt_debug [dict get $opts -debug]
upvar ::punk::imap4::proto::info info
upvar ::punk::imap4::proto::coninfo coninfo
#variable use_ssl
if {$opt_debug} {
puts "I: open $address $port (SECURITY=$opt_security)"
}
switch -- $opt_security {
None {
#insecure
set chan [socket $address $port]
}
STARTTLS {
set connected 0
#if {"windows" eq $::tcl_platform(platform)} {
# package require twapi
# set insecure_chan [socket $address $port]
# set chan [twapi::starttls $insecure_chan -peersubject mail.11email.com]
# set connected 1
#}
if {!$connected} {
catch {package require tls} ;#review
if {[info procs ::tls::socket] eq ""} {
error "Package TLS must be loaded for STARTTLS connections."
}
set insecure_chan [::socket $address $port]
chan configure $insecure_chan -translation binary
dict set coninfo $insecure_chan [dict create hostname $address port $port debug $opt_debug security $opt_security]
punk::imap4::proto::initinfo $insecure_chan
punk::imap4::proto::processline $insecure_chan *
set info($insecure_chan,banner) [lastline $insecure_chan]
#return $insecure_chan
####
if {[STARTTLS $insecure_chan] == 0} {
set chan $insecure_chan; #upgraded
#processline $chan
puts "--> [lastline $chan]"
#get new caps response?
return $chan
} else {
puts stderr "STARTTLS failed"
return
}
}
}
TLS/SSL {
catch {package require tls} ;#review
if {[info procs ::tls::socket] eq ""} {
error "Package TLS must be loaded for implicit TLS connections."
}
#implicit TLS - preferred
set chan [::tls::socket $address $port]
}
}
chan configure $chan -translation binary
dict set coninfo $chan [dict create hostname $address port $port debug $opt_debug security $opt_security]
# Intialize the connection state array
punk::imap4::proto::initinfo $chan
# Get the banner
punk::imap4::proto::processline $chan *
# Save the banner
set info($chan,banner) [lastline $chan]
return $chan
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::CLEANUP
@cmd -name punk::imap4::CLEANUP -help\
"Destroy an IMAP connection and free the used space."
@values -min 1 -max 1
chan
}]
proc CLEANUP {chan} {
upvar ::punk::imap4::proto::info info
upvar ::punk::imap4::proto::coninfo coninfo
variable folderinfo
variable mboxinfo
variable msginfo
::close $chan
array unset folderinfo $chan,*
dict unset mboxinfo $chan
dict unset msginfo $chan
array unset info $chan,*
dict unset coninfo $chan
return $chan
}
# STARTTLS
# This is a new proc added to runs the STARTTLS command. Use
# this when tasked with connecting to an unsecure port which must
# be changed to a secure port prior to user login. This feature
# is known as STARTTLS.
# (implicit TLS on a dedicated port is the modern preference,
# but this should be supported in the client API even if many servers
# move away from it)
proc STARTTLS {chan} {
package require tls
#puts "Starting TLS"
punk::imap4::proto::requirecaps $chan STARTTLS
set clitag [punk::imap4::proto::request $chan STARTTLS]
if {[punk::imap4::proto::getresponse $chan $clitag] != 0} {
#puts "error sending STARTTLS"
return 1
}
#puts "TLS import"
set chan [::tls::import $chan]
#puts "TLS handshake"
#tls::handshake
#returns 0 if handshake still in progress (non-blocking)
#returns 1 if handshake was successful
#throws error if the handshake fails
#REVIEW - should we be calling handshake just once and using tls:status?
#blocking vs non-blocking?
set lim 80
set i 0
if {[catch {
while {![::tls::handshake $chan]} {
incr i
if {$i >= 80} {
puts stderr "starttls - client gave up on handshake"
return 1
}
after 25
}
if {$i > 0} {
#see if the loop is ever required
puts "called tls::handshake $i times"
}
} errM]} {
puts "err during tls::handshake: $errM"
return 1
} else {
#Client SHOULD issue capability command after change in TLS status
set capresult [CAPABILITY $chan] ;#updates our capability cache
if {$capresult != 0} {
#generally shouldn't happen - but what is the proper behaviour if it does?
#for now we'll annoy the client - REVIEW
puts stderr "starttls successful - but failed to retrieve new CAPABILITY list"
}
return 0
}
}
# -----------------------------------------------------------
# simple wrappers of proto info
# -----------------------------------------------------------
# Returns the last error code received.
#proc lastcode {chan} {
# punk::imap4::proto::lastcode $chan
#}
# Returns the last line received from the server.
#proc lastline {chan} {
# punk::imap4::proto::lastline $chan
#}
#proc lastrequest {chan} {
# punk::imap4::proto::lastrequest $chan
#}
# Get the current state
#proc state {chan} {
# punk::imap4::proto::state $chan
#}
namespace import ::punk::imap4::proto::has_capability
namespace import ::punk::imap4::proto::state
namespace import ::punk::imap4::proto::lastline
namespace import ::punk::imap4::proto::lastcode
namespace import ::punk::imap4::proto::lastrequest
namespace import ::punk::imap4::proto::lastrequesttag
# -----------------------------------------------------------
proc showlog {chan {tag *}} {
set loglines [punk::imap4::system::get_conlog $chan $tag]
set result ""
foreach info $loglines {
set side [dict get $info side]
switch -- [dict get $info type] {
line {
if {$side eq "c"} {
append result "cli [dict get $info data]" \n
} else {
append result "svr [dict get $info data]" \n
}
}
literal {
if {$side eq "c"} {
append result "cli (lit) [dict get $info data length] bytes [dict get $info data lines] lines" \n
} else {
append result "svr (lit) [dict get $info data length] bytes [dict get $info data lines] lines" \n
}
}
chunk {
package require punk::ansi
set chunkview [punk::ansi::ansistring VIEW -lf 2 [dict get $info data chunk]]
set chunklines [split $chunkview \n]
set paddedview ""
set indent [string repeat " " [string length "cli (chunk) "]]
foreach cl $chunklines {
append paddedview $indent$cl \n
}
if {[string index $paddedview end] eq "\n"} {
set paddedview [string range $paddedview 0 end-1]
}
if {$side eq "c"} {
append result "cli (chunk) [dict get $info data length] bytes\n$paddedview" \n
} else {
append result "svr (chunk) [dict get $info data length] bytes\n$paddedview" \n
}
}
}
append result
}
return $result
}
#protocol callbacks to api cache namespace
#msginfo
#we need request_tag to determine when we have multiple values for a field - versus subsequent requests which will overwrite
#msgnum is sequence-set?
# todo UIDs separate variable?
#some headers have multiple values (SMTP traces)
#also consider the somewhat contrived use of partials:
# FETCH (BODY[]<0.100> BODY[]<0.10>)
#These are returned in the FETCH response as "BODY[]<0> {100}" and "BODY[]<0> {10}"
#This results in us having a msginfo key of "BODY[]<0>" with 2 values.
#
proc _set_msginfo_field {chan msgnum request_tag field value} {
variable msginfo
if {![dict exists $msginfo $chan $msgnum]} {
set msgdata [dict create]
} else {
set msgdata [dict get $msginfo $chan $msgnum]
}
if {![dict exists $msgdata $field]} {
set fieldinfo [dict create count 1 values [list $value] request $request_tag]
} else {
#update field info for msgnum
set prev_fieldinfo [dict get $msgdata $field]
set prev_request [dict get $prev_fieldinfo request]
if {$prev_request ne $request_tag} {
#new request - can overwrite
set fieldinfo [dict create count 1 values [list $value] request $request_tag]
} else {
#same request - duplicate header/field e.g Received: header - we need to store all.
set fieldinfo $prev_fieldinfo
dict incr fieldinfo count
dict lappend fieldinfo values $value
}
}
dict set msgdata $field $fieldinfo
dict set msginfo $chan $msgnum $msgdata
#set msginfo($chan,$msgnum,$field) $value
}
proc _append_msginfo_field {chan msgnum request_tag field value} {
variable msginfo
if {![dict exists $msginfo $chan $msgnum $field]} {
error "_append_msginfo_field record for chan:$chan msgnum:$msgnum field:$field not found"
}
set fieldinfo [dict get $msginfo $chan $msgnum $field]
set prev_request [dict get $fieldinfo request]
if {$prev_request ne $request_tag} {
#attempt to append with differing request.. should have been _set_msginfo_field call beforehand..
error "_append_msginfo_field wrong-request $request_tag for chan:$chan msgnum:$msgnum field:$field with existing request $prev_request"
}
set values [dict get $fieldinfo values]
set lastv [lindex $values end]
append lastv $value
lset values end $lastv
#no change to count or request fields
dict set fieldinfo values $values
dict set msginfo $chan $msgnum $field $fieldinfo
#append msginfo($chan,$msgnum,$field) $value
}
proc _display_msginfo {chan} {
variable msginfo
set chandata [dict get $msginfo $chan]
set out ""
dict for {msgseq mdata} $chandata {
dict for {prop propdata} $mdata {
#append out "$msgseq $prop [dict get $propdata values]"
set count [dict get $propdata count]
for {set i 0} {$i < $count} {incr i} {
append out "$msgseq $prop [lindex [dict get $propdata values] $i]"
}
}
}
return $out
}
proc _set_mboxinfo {chan prop value} {
variable mboxinfo
dict set mboxinfo $chan $prop $value
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::AUTH_LOGIN
@cmd -name punk::imap4::AUTH_LOGIN -help\
"Login using the IMAP LOGIN command.
"
@leaders -min 1 -max 1
chan -optional 0
@opts
-ignorestate -type none -help\
"Send the LOGIN even if protocol state is not appropriate"
-ignorelogindisabled -type none -help\
"Ignore the LOGINDISABLED capability
from the server and send LOGIN anyway.
(There should be no need to use this
except for server testing purposes)"
@values -min 2 -max 2
username
password
}]
proc AUTH_LOGIN {args} {
upvar ::punk::imap4::proto::info info
set argd [punk::args::parse $args withid ::punk::imap4::AUTH_LOGIN]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set opt_ignorestate [dict exists $received -ignorestate]
set opt_ignorelogindisabled [dict exists $received -ignorelogindisabled]
set username [dict get $values username]
set username [punk::imap4::stringprep::normal_userpass $username]
set password [dict get $values password]
set password [punk::imap4::stringprep::normal_userpass $password]
if {!$opt_ignorelogindisabled} {
if {[punk::imap4::proto::has_capability $chan LOGINDISABLED]} {
error "IMAP SERVER has advertised the capability LOGINDISABLED. Try another mechanism, or ensure TLS or STARTTLS is being used."
}
}
if {!$opt_ignorestate} {
punk::imap4::proto::requirestate $chan NOAUTH
}
set rtag [punk::imap4::proto::request $chan [list LOGIN $username $password]]
if {[punk::imap4::proto::getresponse $chan $rtag] != 0} {
return 1
}
set info($chan,state) AUTH
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::AUTH_PLAIN
@cmd -name punk::imap4::AUTH_PLAIN -help\
"PLAIN SASL Authentication mechanism.
This uses the 'initial response' to send
the base64 encoded authzn authn password
in the same line as AUTHENTICATE PLAIN.
It does not support the negotiation version
of PLAIN where AUTHENTICATE PLAIN is sent,
and the client sends the credentials after
getting a continuation (+) from the server."
@leaders -min 1 -max 1
chan -optional 0
@opts
-ignorestate -type none -help\
"Send the AUTHENTICATE even if protocol state is not appropriate"
-authorization -type string -default "" -help\
"authorization identity (identity to act as)
Usually it is not necessary to provide an
authorization identity - as it will be derived
from the credentials. ie from the
'authentication identity' which is the username.
"
@values -min 2 -max 2
username -help\
"Authentication identity"
password
}]
proc AUTH_PLAIN {args} {
upvar ::punk::imap4::proto::info info
set argd [punk::args::parse $args withid ::punk::imap4::AUTH_PLAIN]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set opt_ignorestate [dict exists $received -ignorestate]
set opt_authorization [dict get $opts -authorization]
if {$opt_ignorestate} {
set allowstates *
} else {
set allowstates NOAUTH
}
set username [dict get $values username]
set username [punk::imap4::stringprep::normal_userpass $username]
set password [dict get $values password]
set password [punk::imap4::stringprep::normal_userpass $password]
package require base64
set b64_creds [base64::encode $opt_authorization\0$username\0$password]
if {[punk::imap4::proto::simplecmd $chan -validstates $allowstates AUTHENTICATE PLAIN $b64_creds]} {
return 1
}
set info($chan,state) AUTH
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::MYRIGHTS
@cmd -name punk::imap4::MYRIGHTS -help\
"Get the set of rights that the current user
has to the mailbox.
incomplete
Currently need debug mode or showlog
to see results"
@leaders -min 1 -max 1
chan
@values -min 0 -max 1
mailbox -default INBOX
}]
proc MYRIGHTS {args} {
set argd [punk::args::parse $args withid ::punk::imap4::MYRIGHTS]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
if {[punk::imap4::proto::simplecmd $chan MYRIGHTS $mailbox] != 0} {
return 1
}
#todo - store in appropriate cache - retrieve if -inline specified?
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::GETACL
@cmd -name punk::imap4::GETACL -help\
"Get ACL for a mailbox.
The current user must have permission to administer
the mailbox (the \"a\" right) to perform ACL commands
ie SETACL/GETACL/DELETEACL/LISTRIGHTS
As opposed to MYRIGHTS, GETACL will return info
about other users' rights on the mailbox
(including current user)
incomplete
Currently need debug mode or showlog
to see results"
@leaders -min 1 -max 1
chan
@values -min 0 -max 1
mailbox -default INBOX
}]
proc GETACL {args} {
set argd [punk::args::parse $args withid ::punk::imap4::GETACL]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
if {[punk::imap4::proto::simplecmd $chan GETACL $mailbox] != 0} {
return 1
}
#todo - store in appropriate cache - retrieve if -inline specified?
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::SETACL
@cmd -name punk::imap4::SETACL -help\
"Set ACL for a specified user on a mailbox.
The current user must have permission to administer
the mailbox (the \"a\" right) to perform ACL commands
ie SETACL/GETACL/DELETEACL/LISTRIGHTS"
@leaders -min 1 -max 1
chan
@values -min 3 -max 3
mailbox
user
rights -help\
"A rights string consisting of zero or more rights
characters (lowercase) optionally beginning with a
\"+\" or \"-\"
e.g SETACL projectfolder other.user +cda
If the string starts with a plus, the following
rights are added to any existing rights for the
specified user.
If the string starts with a minus, the following
rights are removed from any existing rights for
the specified user.
If the string does not start with a plus or minus,
the rights replace any existing rights for the
specified user.
"
}]
proc SETACL {args} {
set argd [punk::args::parse $args withid ::punk::imap4::SETACL]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
set user [dict get $values user]
set rights [dict get $values rights]
if {[punk::imap4::proto::simplecmd $chan SETACL $mailbox $user $rights] != 0} {
return 1
}
#todo - update appropriate cache?
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::LISTRIGHTS
@cmd -name punk::imap4::LISTRIGHTS -help\
"Get information about the required rights
and the optional rights for a specified user
on this mailbox.
The required rights (a possibly empty string)
are the rights that will always be granted to that
user in the mailbox.
The optional rights are rights that CAN be granted.
incomplete
Currently need debug mode or showlog
to see results"
@leaders -min 1 -max 1
chan
@values -min 0 -max 2
mailbox -default INBOX
user -default anyone
}]
proc LISTRIGHTS {args} {
set argd [punk::args::parse $args withid ::punk::imap4::LISTRIGHTS]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
set user [dict get $values user]
if {[punk::imap4::proto::simplecmd $chan LISTRIGHTS $mailbox $user] != 0} {
return 1
}
#todo - store in appropriate cache - retrieve if -inline specified?
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::SELECT
@cmd -name punk::imap4::SELECT -help\
{Selects a mailbox so that messages in the mailbox can be
accessed.
Only one mailbox can be selected at a time in a connection.
This is termed a "session".
Simultaneous access to multiple mailboxes requires multiple
connections. The SELECT command automatically deselects any
currently selected mailbox before attempting the new
selection. Consequently, if a mailbox is selected and a
SELECT command that fails is attempted, no mailbox is
selected.
}
@leaders -min 1 -max 1
chan
@values -min 0 -max 1
mailbox -default INBOX -help\
{To supply a mailbox name with spaces
The value will need to be enclosed with
double quotes - and these quotes need to
be sent to the server. Enclose in curly
braces to ensure this.
e.g
SELECT $ch {"Deleted Items"}
}
}]
proc SELECT {args} {
set argd [punk::args::parse $args withid ::punk::imap4::SELECT]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
selectmbox $chan SELECT $mailbox
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::EXAMINE
@cmd -name punk::imap4::EXAMINE -help\
{The EXAMINE command is identical to SELECT and returns the
same output; however, the selected mailbox is identified as
read-only. No changes to the permanent state of the mailbox,
including per-user state, are permitted.}
@leaders -min 1 -max 1
chan
@values -min 0 -max 1
#todo - share argdefs more!
mailbox -default INBOX -help\
{To supply a mailbox name with spaces
The value will need to be enclosed with
double quotes - and these quotes need to
be sent to the server. Enclose in curly
braces to ensure this.
e.g
SELECT $ch {"Deleted Items"}
}
}]
proc EXAMINE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::EXAMINE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
selectmbox $chan EXAMINE $mailbox
}
# General function for selection.
proc selectmbox {chan cmd mailbox} {
upvar ::punk::imap4::proto::info info
variable mboxinfo
variable msginfo
punk::imap4::proto::requirestate $chan {AUTH SELECT}
# Clean info about the previous mailbox if any,
# but save a copy to restore this info on error.
#set savedmboxinfo [array get mboxinfo $chan,*]
#array unset mboxinfo $chan,*
dict unset mboxinfo $chan
#msginfo is based on seq-number - which is per mailbox, so we have to clear it for now.
#todo - keep cache of per mailbox msginfo even when based on seq-number?
dict unset msginfo $chan
#review - keep cache of uid based msginfo - where?
set rtag [punk::imap4::proto::request $chan "$cmd $mailbox"]
if {[punk::imap4::proto::getresponse $chan $rtag] != 0} {
#array set mboxinfo $savedmboxinfo
set info($chan,state) AUTH
return 1
}
#TODO - state SELECT vs EXAMINE?
set info($chan,state) SELECT
# Set the new name as mbox->current.
#set mboxinfo($chan,current) $mailbox
_set_mboxinfo $chan current $mailbox
return 0
}
#parse_seq-range - parse a seq-range from a sequence-set
#sequence-set
#Example: a message sequence number set of
# ; 2,4:7,9,12:* for a mailbox with 15 messages is
# ; equivalent to 2,4,5,6,7,9,12,13,14,15
#parse_seq-range should be used primarily for examining sequence-set members
#when we want to determine the applicable ranges e.g to lookup cached info for each message
#When sending a sequence-set to the server, we can use parse_seq-range to check for errors,
#but we shouldn't be 'expanding' a valid sequence-set being sent to the server.
#We don't accept the : or :n or n: syntax accepted by the tcllib imap4 library
# - because the more explicit syntax specified in the IMAP RFCs is preferred
#(with possible * special value)
proc parse_seq-range {chan range} {
if {[string first , $range] >=0} {
error "parse_seq_range supplied value '$range' appears to be a sequence-set, not a seq-range or seq-number"
}
set rangelist [split $range :]
switch -- [llength $rangelist] {
1 {
if {$range eq "*"} {
set start [mboxinfo $chan exists]
set end $start
} else {
set start $range
set end $range
}
if {![punk::imap4::proto::is_imap_nznumber $start] || ![punk::imap4::proto::is_imap_nznumber $end]} {
error "parse_seq-range Invalid range '$range'"
}
}
2 {
lassign $rangelist start end
if {$start eq "*" && $end eq "*"} {
set end [mboxinfo $chan exists]
set start $end
} elseif {$start eq "*"} {
set start [mboxinfo $chan exists]
} elseif {$end eq "*"} {
set end [mboxinfo $chan exists]
}
if {![punk::imap4::proto::is_imap_nznumber $start] || ![punk::imap4::proto::is_imap_nznumber $end]} {
error "parse_seq-range Invalid range '$range'"
}
}
default {
error "parse_seq-range Invalid range '$range'"
}
}
return [list $start $end]
}
#old_parse_seq-range
# Parse an IMAP seq-range, store 'start' and 'end' in the
# named vars. If the first number of the range is omitted,
# 1 is assumed. If the second number of the range is omitted,
# the value of "exists" of the current mailbox is assumed.
#
# So : means all the messages.
proc old_parse_seq-range {chan range startvar endvar} {
upvar $startvar start $endvar end
set rangelist [split $range :]
switch -- [llength $rangelist] {
1 {
if {![string is integer $range]} {
error "Invalid range"
}
set start $range
set end $range
}
2 {
foreach {start end} $rangelist break
if {![string length $start]} {
set start 1
}
if {![string length $end]} {
set end [mboxinfo $chan exists]
}
if {![string is integer $start] || ![string is integer $end]} {
error "Invalid range"
}
}
default {
error "Invalid range"
}
}
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::FETCH
@cmd -name punk::imap4::FETCH -help\
"Fetch a number of attributes from messages.
A mailbox must be SELECTed first and an appropriate
sequence-set supplied for the message(s) of interest."
@leaders -min 1 -max 1
chan
@opts
-inline -type none
@values -min 2 -max -1
#todo - use same sequence-set definition across argdefs
sequence-set -help\
"Message sequence set.
1 is the lowest valid sequence number.
* represents the maximum message sequence number
in the mailbox.
e.g
1
2:2
1:3
3,5,9:10
1,10:*
*:5
*
"
queryitems -default {} -help\
"Some common FETCH queries are shown here, but
this list isn't exhaustive."\
-multiple 1 -optional 0 -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices {
ALL FAST FULL BODY BODYSTRUCTURE ENVELOPE FLAGS INTERNALDATE
SIZE RFC822.SIZE
UID
TEXT HEADER BODY[] BINARY[] BINARY.SIZE[]
} -choicelabels {
ALL\
" Macro equivalent to:
(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE)
This is only valid by itself.
No other queryitems should be provided"
FAST\
" Macro equivalent to:
(FLAGS INTERNALDATE RFC822.SIZE)
This is only valid by itself.
No other queryitems should be provided"
FULL\
" Macro equivalent to:
(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY)
This is only valid by itself.
No other queryitems should be provided."
BODY\
" Non-extensible form of BODYSTRUCTURE"
BODYSTRUCTURE\
" A parenthesized list that describes the MIME-IMB
body structure of a message."
{BODY[]}\
{ This retrieves the entire body including headers.
(RFC5322 expression of the entire message)
This implicitly sets the \Seen flag, as do other
FETCH BODY[...] operations. Ensure the mailbox is
opened using EXAMINE, or use BODY.PEEK[...] to avoid
this.}
{BINARY[]}\
{ Requests that the specified section be transmitted
after performing decoding of the section's
Content-Transfer-Encoding.
Like BODY[...] it will set the \Seen flag and also
has a BINARY.PEEK[...] alternate form.
Can only be requested for leaf body parts: those that
have media types other than multipart/*,
message/rfc822, or message/global.}
{BINARY.SIZE[]}\
{ Requests the decoded size fo the section (i.e , the
size to expect in response to the corresponding
FETCH BINARY request).
Only available for leaf body parts.
Can be an expensive operation on some servers.
}
RFC822.SIZE\
{ Number of octets in the message when the message
is expressed in RFC5322 format. SHOULD match the
result of a "FETCH BODY[]" command. Some servers
may store with different internal format and store
the size to avoid recalculation.}
SIZE\
{ Client-side alias for RFC822.SIZE for consistency
with tcllib IMAP4. Consider deprecating.}
ENVELOPE\
" The envelope structure of the message.
Computed by the server by parsing the RFC5322
header defaulting various fields as necessary"
INTERNALDATE\
" The internal date of the message.
(Suitable as date arg for APPEND if copying a msg
from one server to another)"
}
}]
proc FETCH {args} {
variable msginfo
set argd [punk::args::parse $args withid ::punk::imap4::FETCH]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set opt_inline [dict exists $received -inline]
set sequenceset [dict get $values sequence-set]
set query_items [dict get $values queryitems]
punk::imap4::proto::requirestate $chan SELECT
#parse each seqrange to give it a chance to raise error for bad values
foreach seqrange [split $sequenceset ,] {
parse_seq-range $chan $seqrange
}
set items {}
set hdrfields {}
#3 macros that should be used on own, not in conjunction with other macros
# or data items:
#ALL - equiv to (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE)
#FAST - equiv to (FLAGS INTERNALDATE RFC822.SIZE)
#FULL - equiv to (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY)
#todo "$" data-item ?
foreach data_item $query_items {
set DATA_ITEM [string toupper $data_item]
switch -- $DATA_ITEM {
ALL - FAST - FULL {lappend items $DATA_ITEM}
BODY -
BODYSTRUCTURE -
ENVELOPE -
FLAGS -
INTERNALDATE -
RFC822.SIZE -
UID {lappend items $DATA_ITEM}
SIZE {
#Alias in this client only - compat with tcllib::imap4
lappend items RFC822.SIZE
}
TEXT {
#IMAP4rev2 deprecated
lappend items RFC822.TEXT
}
HEADER {
#IMAP4rev2 deprecated
lappend items RFC822.HEADER
}
default {
if {[string index $data_item end] eq ":"} {
#*: {lappend hdrfields $w}
lappend hdrfields $data_item
} else {
# Fixme: better to raise an error here?
#lappend hdrfields $data_item:
#pass through
lappend items $data_item
}
}
}
}
if {[llength $hdrfields]} {
#set item {BODY[HEADER.FIELDS (} ;#will set /seen flag
set item {BODY.PEEK[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
}
#The server-side macros ALL FAST FULL (at least on cyrus server) can't be bracketed and must appear alone
#if we detect any of these, take the first and - override any other entries
foreach m {ALL FAST FULL} {
if {$m in $query_items} {
set items $m
break
}
}
# Send the request
if {[llength $items] == 1} {
#if {[lindex $items 0] in {ALL FAST FULL}} {}
#pass as is - not bracketed list
#the 3 macros are known NOT to be understood as (ALL) (FAST) (FULL) on cyrus at least
#Other single atoms such as INTERNALDATE,ENVELOPE,FLAGS etc can be passed as e.g (INTERNALDATE) or INTERNALDATE
#from RFC9051:
#----------------
#fetch = "FETCH" SP sequence-set SP (
# "ALL" / "FULL" / "FAST" /
# fetch-att / "(" fetch-att *(SP fetch-att) ")")
#fetch-att = "ENVELOPE" / "FLAGS" / "INTERNALDATE" /
# "RFC822.SIZE" /
# "BODY" ["STRUCTURE"] / "UID" /
# "BODY" section [partial] /
# "BODY.PEEK" section [partial] /
# "BINARY" [".PEEK"] section-binary [partial] /
# "BINARY.SIZE" section-binary
#----------------
#
#don't wrap a single element in brackets - it may already be bracketed by the caller
#for ALL FAST FULL - which can only occur on their own, bracketing is not allowed anyway.
set request_tag [punk::imap4::proto::request $chan "FETCH $sequenceset [lindex $items 0]"]
} else {
set request_tag [punk::imap4::proto::request $chan "FETCH $sequenceset ([join $items])"]
}
if {[punk::imap4::proto::getresponse $chan $request_tag] != 0} {
if {$opt_inline} {
# Should we throw an error here?
return ""
}
return 1
}
if {!$opt_inline} {
return 0
}
# -inline processing begins here
#The fetch queries can be serverside-macros or even custom compound
#queries such as:
# {BODY[HEADER.FIELDS (SUBJECT TO ...)]}
# {BINARY[1]}
#We should base our -inline response on the returned fields - not one per input query element.
#This is divergent from tcllib::imap4 which returned untagged lists that the client would match
#based on assumed simple value queries such as specific properties and headers that are individually specified.
set fetchresult [dict create]
for {set i $start} {$i <= $end} {incr i} {
set flagdict [dict get $msginfo $chan $i]
#extract the fields that were added for this request_tag only
dict for {f finfo} $flagdict {
if {[dict get $finfo request] eq $request_tag} {
#lappend msgrecord [list $f $finfo]
dict set fetchresult $f $finfo
}
}
}
return $fetchresult
#return $mailinfo
set mailinfo {}
set fields [list]
#todo - something better
foreach itm $items {
if {$itm ni {ALL FAST FULL}} {
lappend fields $itm
}
}
#lappend fields {*}$hdrfields
set fields [list {*}$fields {*}$hdrfields]
for {set i $start} {$i <= $end} {incr i} {
set mailrec [list]
foreach {f} $fields {
#lappend mailrec [msginfo $chan $i $f ""]
set finfo [msginfo $chan $i $f ""]
if {$finfo eq ""} {
lappend mailrec "count 0 field $f values {} request $request_tag"
} else {
set count [dict get $finfo count]
if {$count == 1} {
lappend mailrec [lindex [dict get $finfo values] 0]
} else {
#review
set values [dict get $finfo values]
lappend mailrec [list items $count values $values]
}
}
#lappend mailrec [dict get $finfo values]
}
lappend mailinfo $mailrec
}
return $mailinfo
}
# Get information (previously collected using fetch) from a given message.
# If the 'info' argument is omitted or a null string, the full list
# of information available for the given message is returned.
#
# If the required information name is suffixed with a ? character,
# the command requires true if the information is available, or
# false if it is not.
proc msginfo {chan msgid args} {
variable msginfo
switch -- [llength $args] {
0 {
set info {}
}
1 {
set info [lindex $args 0]
set use_defval 0
}
2 {
set info [lindex $args 0]
set defval [lindex $args 1]
set use_defval 1
}
default {
error "msginfo called with bad number of arguments! Try msginfo channel messageid ?info? ?defaultvalue?"
}
}
#set info [string tolower $info]
# Handle the missing info case
if {![string length $info]} {
set minfo [dict get $msginfo $chan $msgid]
return [dict keys $minfo]
}
if {[string index $info end] eq {?}} {
return [dict exists $msginfo $chan $msgid [string range $info 0 end-1]]
#set info [string range $info 0 end-1]
#return [info exists msginfo($chan,$msgid,$info)]
} else {
if {![dict exists $msginfo $chan $msgid $info]} {
if {$use_defval} {
return $defval
} else {
error "No such information '$info' available for message id '$msgid'"
}
}
set fieldinfo [dict get $msginfo $chan $msgid $info]
return $fieldinfo
#return $msginfo($chan,$msgid,$info)
}
}
# Get information on the currently selected mailbox.
# If the 'info' argument is omitted or a null string, the full list
# of information available for the mailbox is returned.
#
# If the required information name is suffixed with a ? character,
# the command requires true if the information is available, or
# false if it is not.
proc mboxinfo {chan {info {}}} {
variable mboxinfo
# Handle the missing info case
if {![string length $info]} {
#set list [array names mboxinfo $chan,*]
set minfo [dict get $mboxinfo $chan]
return [dict keys $minfo]
}
set info [string tolower $info]
set minfo [dict get $mboxinfo $chan]
if {[string index $info end] eq {?}} {
return [dict exists $minfo [string range $info 0 end-1]]
} else {
if {![dict exists $minfo $info]} {
error "No such information '$info' available for the current mailbox"
}
return [dict get $minfo $info]
}
}
# Get information on the last folders list.
# If the 'info' argument is omitted or a null string, the full list
# of information available for the folders is returned.
#
# If the required information name is suffixed with a ? character,
# the command requires true if the information is available, or
# false if it is not.
proc folderinfo {chan {info {}}} {
variable folderinfo
# Handle the missing info case
if {![string length $info]} {
set list [array names folderinfo $chan,*]
set availinfo {}
foreach l $list {
lappend availinfo [string range $l \
[string length $chan,] end]
}
return $availinfo
}
set info [string tolower $info]
if {[string index $info end] eq {?}} {
set info [string range $info 0 end-1]
return [info exists folderinfo($chan,$info)]
} else {
if {![info exists folderinfo($chan,$info)]} {
error "No such information '$info' available for the current folders"
}
return $folderinfo($chan,$info)
}
}
#namespace import ::punk::imap4::proto::CAPABILITY
lappend PUNKARGS [list {
@id -id ::punk::imap4::CAPABILITY
@cmd -name punk::imap4::CAPABILITY -help\
"send CAPABILITY command to the server.
The cached results can be checked with
the punk::imap4::has_capability command."
@leaders -min 1 -max 1
chan -optional 0
@opts
@values -min 0 -max 0
}]
# Get capabilties
proc CAPABILITY {args} {
set argd [punk::args::parse $args withid ::punk::imap4::CAPABILITY]
set chan [dict get $argd leaders chan]
set rtag [punk::imap4::proto::request $chan "CAPABILITY"]
if {[punk::imap4::proto::getresponse $chan $rtag]} {
return 1
}
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::NOOP
@cmd -name punk::imap4::NOOP -help\
"NOOP command. May get information as untagged data.
The NOOP command always succeeds. It does nothing.
Since any command can return a status update as untagged data,
the NOOP command can be used as a periodic poll for new messages
or message status updates during a period of inactivity
(The IDLE command should be used instead of NOOP if real-time
updates to mailbox state are desirable).
The NOOP command can also be used to reset any inactivity
autologout timer on the server.
"
@leaders -min 1 -max 1
chan -optional 0
@opts
@values -min 0 -max 0
}]
proc NOOP {args} {
set argd [punk::args::parse $args withid ::punk::imap4::NOOP]
set chan [dict get $argd leaders chan]
punk::imap4::proto::simplecmd $chan NOOP
}
# CHECK. Flush to disk.
lappend PUNKARGS [list {
@id -id ::punk::imap4::CHECK
@cmd -name punk::imap4::CHECK -help\
"OBSOLETED in RFC9051.
NOOP should generally be used instead.
The CHECK command requests a checkpoint of the currently
selected mailbox.
This was for implementation dependent housekeeping associated
with the mailbox.
"
@leaders -min 1 -max 1
chan -optional 0
@opts
@values -min 0 -max 0
}]
proc CHECK {args} {
set argd [punk::args::parse $args withid ::punk::imap4::CHECK]
set chan [dict get $argd leaders chan]
punk::imap4::proto::simplecmd $chan -validstates {SELECT} CHECK
}
# Close the mailbox. Permanently removes \Deleted messages and return to
# the AUTH state.
lappend PUNKARGS [list {
@id -id ::punk::imap4::CLOSE
@cmd -name punk::imap4::CLOSE -help\
{The CLOSE command permanently removes all messages that have the
\Deleted flag set from the currently selected mailbox, and it returns
to the authenticated state from the selected state. No untagged
EXPUNGE responses are sent.
No messages are removed, and no error is given, if the mailbox is
selected by an EXAMINE command or is otherwise selected as read-only.
Even if a mailbox is selected, a SELECT, EXAMINE, or LOGOUT command
MAY be issued without previously issuing a CLOSE command. The
SELECT, EXAMINE, and LOGOUT commands implicitly close the currently
selected mailbox without doing an expunge. However, when many
messages are deleted, a CLOSE-LOGOUT or CLOSE-SELECT sequence is
considerably faster than an EXPUNGE-LOGOUT or EXPUNGE-SELECT because
no untagged EXPUNGE responses (which the client would probably
ignore) are sent.}
@leaders -min 1 -max 1
chan -optional 0
@opts
@values -min 0 -max 0
}]
proc CLOSE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::CLOSE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
upvar ::punk::imap4::proto::info info
variable mboxinfo
if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT} CLOSE]} {
return 1
}
#array set mboxinfo {} ;#JMN
set mboxinfo [dict create]
set info($chan,state) AUTH
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::UNSELECT
@cmd -name punk::imap4::UNSELECT -help\
"Sends UNSELECT command to server.
Similar to CLOSE - but doesn't expunge messages with the \Deleted flag.
IMAP RFC9051
------------------------------------------------------------------------
Arguments: none
Responses: no specific responses for this command
Result:
OK - unselect completed, now in authenticated state
BAD - no mailbox selected, or argument supplied but none permitted
The UNSELECT command frees a session's resources associated with the
selected mailbox and returns the server to the authenticated state.
This command performs the same actions as CLOSE, except that no messages
are permanently removed from the currently selected mailbox.
Example:
C: A342 UNSELECT
S: A342 OK Unselect completed
------------------------------------------------------------------------
see also RFC3691 - IMAP UNSELECT command
"
@leaders -min 1 -max 1
chan -optional 0
@opts
-ignorestate -type none -help\
"Send the UNSELECT even if protocol state is not appropriate"
@values -min 0 -max 0
}]
proc UNSELECT {args} {
upvar ::punk::imap4::proto::info info
variable mboxinfo
set argd [punk::args::parse $args withid ::punk::imap4::UNSELECT]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set opt_ignorestate [dict exists $received -ignorestate]
if {$opt_ignorestate} {
set allowstates *
} else {
set allowstates SELECT
}
if {![punk::imap4::proto::has_capability $chan UNSELECT]} {
error "IMAP SERVER has NOT advertised the capability UNSELECT. Try CLOSE instead."
}
#todo - limit to imap4 rev2+?
if {[punk::imap4::proto::simplecmd $chan -validstates $allowstates UNSELECT]} {
return 1
}
#array set mboxinfo {} ;#JMN
set mboxinfo [dict create]
set info($chan,state) AUTH
return 0
}
proc NAMESPACE {chan} {
punk::imap4::proto::simplecmd $chan NAMESPACE
}
# Create a new mailbox.
#todo - allow creation with specialuse metadata if
# CREATE-SPECIAL-USE capability is present
lappend PUNKARGS [list {
@id -id "::punk::imap4::CREATE"
@cmd -name "punk::imap4::CREATE" -help\
"Create a mailbox with the given name.
It is an error to attempt to create INBOX
or a name that refers to an existing mailbox.
Servers will generally allow creation of a
hierarchy of mailboxes if the mailbox separator
is within the name."
@leaders -min 1 -max 1
chan
@opts
@values -min 1 -max 1
mailbox
}]
proc CREATE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::CREATE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT} CREATE $mailbox
}
# RFC 5464 The IMAP METADATA Extension
# ------------------------------------------------------------
# - RFC6154 IMAP LIST Extension for Special-use Mailboxes
# - other mailbox 'annotations' ?
# - relevant CAPS: SPECIAL-USE CREATE-SPECIAL-USE LIST-EXTENDED
# ------------------------------------------------------------
lappend PUNKARGS [list {
@id -id "::punk::imap4::GETMETADATA"
@cmd -name "punk::imap4::GETMETDATA" -help\
"Get metadata on named mailbox, or server annotations
if empty-string provided instead of mailbox name."
@leaders -min 1 -max 1
chan
@opts
@values -min 2 -max 2
mailbox -help\
{Mailbox name or empty string {""} for server annotations}
annotation -choicerestricted 0 -help\
"May include glob character *"\
-choices {
/private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment
/private/expire /private/news2mail /private/pop3showafter
} -help\
"Annotation is a string beginning with /private/ or /shared/
Check specific server for supported mailbox annotations.
"
}]
proc GETMETADATA {args} {
#on cyrus at least, annotation must begin with /shared or /private
#e.g /private/specialuse
#C: <tag> GETMETDATA "Foldername" /private/specialuse
#S: * METADATA "Foldername" (/private/specialuse NIL)
#S: <tag> OK Completed
#or
#C: <tag> GETMETDATA "Junk" /private/specialuse
#S: * METADATA "Foldername" (/private/specialuse {5}
#S: \Junk
#S: )
#S: <tag> OK Completed
set argd [punk::args::parse $args withid ::punk::imap4::GETMETADATA]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
set annotation [dict get $values annotation]
set annotation [string trim $annotation]
if {![string match "/private/?*" $annotation] && ![string match "/shared/?*" $annotation]} {
#cyrus IMAP enforces this anyway.. others? can we ever send just the following? GETMETADATA name *
error "GETMETADATA annotation must begin with /shared/ or /private/"
}
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} GETMETADATA $mailbox $annotation
}
lappend PUNKARGS [list {
@id -id "::punk::imap4::SETMETADATA"
@cmd -name "punk::imap4::SETMETDATA" -help\
"Set metadata on mailbox name.
If an empty string is provided instead of the
mailbox name - the annotation is applied at
the server level. Users may be able to set
/private or /shared annotations at the server
level depending on how the server restricts
them."
@leaders -min 1 -max 1
chan
@opts
-ignorestate -type none
@values -min 3 -max 3
mailbox
annotation -choicerestricted 0 -choices {
/private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment
/private/expire /private/news2mail /private/pop3showafter
} -help\
"Annotation is a string beginning with /private/ or /shared/
Check specific server for supported mailbox annotations.
"
value -help\
"Pass the empty string or NIL to unset/delete the annotation"
}]
proc SETMETADATA {args} {
set argd [punk::args::parse $args withid ::punk::imap4::SETMETADATA]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
if {[dict exists $received -ignorestate]} {
set ignorestate 1
} else {
set ignorestate 0
}
set mailbox [dict get $values mailbox]
set annotation [dict get $values annotation]
set value [dict get $values value]
set annotation [string trim $annotation]
if {![string match /private/?* $annotation] && ![string match /shared/?* $annotation]} {
error "SETMETADATA annotation must begin with /shared/ or /private/"
}
if {$ignorestate} {
set validstates *
} else {
set validstates {AUTH SELECT EXAMINE}
}
if {$value in [list "" NIL]} {
punk::imap4::proto::simplecmd $chan -validstates $validstates SETMETADATA $mailbox "($annotation NIL)"
} else {
punk::imap4::proto::simplecmd $chan -validstates $validstates SETMETADATA $mailbox "($annotation \"$value\")"
}
}
# ------------------------------------------------------------
lappend PUNKARGS [list {
@id -id "::punk::imap4::DELETE"
@cmd -name "punk::imap4::DELETE" -help\
"Permanently delete the mailbox with the
given name.
Server behaviour may vary with regards
to when/if mailboxes with sub-boxes can
be deleted.
If the mailbox is successfully deleted,
all messages in that mailbox are removed.
Todo - document more."
@leaders -min 1 -max 1
chan
@opts
@values -min 1 -max 1
mailbox
}]
proc DELETE {chan mailbox} {
set argd [punk::args::parse $args withid ::punk::imap4::DELETE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} DELETE $mailbox
}
lappend PUNKARGS [list {
@id -id "::punk::imap4::RENAME"
@cmd -name "punk::imap4::RENAME" -help\
"Rename a mailbox.
It is an error to attempt to rename from a mailbox
name that does not exist or to a mailbox name that
already exists.
Some servers will allow renaming INBOX - but with
special behaviour - moving all messages in INBOX
to a folder with the given name, leaving INBOX
empty - except that submailboxes of INBOX (if any)
are not moved."
@leaders -min 1 -max 1
chan
@opts
@values -min 2 -max 2
oldname
newname
}]
proc RENAME {args} {
set argd [punk::args::parse $args withid ::punk::imap4::SUBSCRIBE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set oldname [dict get $values oldname]
set newname [dict get $values newname]
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} RENAME $oldname $newname
}
lappend PUNKARGS [list {
@id -id "::punk::imap4::SUBSCRIBE"
@cmd -name "punk::imap4::SUBSCRIBE" -help\
"Add the specified mailbox name to the server's set
of \"active\" or \"subscribed\" mailboxes as returned
by the LIST (SUBSCRIBED) command.
Some servers may maintain a mailbox name in its
subscribed list even if the mailbox doesn't always
exist. e.g a system-alerts mailbox that is created
and removed as necessary.
"
@leaders -min 1 -max 1
chan
@opts
@values -min 1 -max 1
mailbox
}]
proc SUBSCRIBE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::SUBSCRIBE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} SUBSCRIBE $mailbox
}
lappend PUNKARGS [list {
@id -id "::punk::imap4::UNSUBSCRIBE"
@cmd -name "punk::imap4::UNSUBSCRIBE" -help\
"Unsubscribe to a mailbox"
@leaders -min 1 -max 1
chan
@opts
@values -min 1 -max 1
mailbox
}]
proc UNSUBSCRIBE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::UNSUBSCRIBE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} UNSUBSCRIBE $mailbox
}
#TODO
proc IDLE {chan} {
if {[punk::imap4::proto::has_capability $chan IDLE]} {
punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} IDLE
} else {
error "IMAP SERVER has NOT advertised the capability IDLE."
}
#todo - if we got a + - start a chan readable event handler on the channel
#what else can we get? immediate NO? a missing response is a definite possibility...
#no response until DONE is sent by client
return ""
}
proc IDLEDONE {chan} {
upvar ::punk::imap4::proto::info info
puts -nonewline $chan "DONE\r\n"
flush $chan
set info($chan,idle) {}
# - get response to initial IDLE command - REVIEW
set rtag [punk::imap4::lastrequesttag $chan]
if {[punk::imap4::proto::getresponse $chan $rtag]} {
return 1
}
return 0
}
lappend PUNKARGS [list {
@id -id "::punk::imap4::FOLDERS"
@cmd -name "punk::imap4::FOLDERS" -help\
"List of folders"
@leaders -min 1 -max 1
chan
@opts
-ignorestate -type none
-inline -type none
@values -min 0 -max 2
ref -default ""
mailboxpattern -default "*"
}]
# List of folders
proc FOLDERS {args} {
variable folderinfo
set argd [punk::args::parse $args withid ::punk::imap4::FOLDERS]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set opt_inline [dict exists $received -inline]
set opt_ignorestate [dict exists $received -ignorestate]
set ref [dict get $values ref]
set mbox [dict get $values mailboxpattern]
array unset folderinfo $chan,*
if {$opt_ignorestate} {
set allowstates *
} else {
set allowstates {SELECT AUTH}
}
set folderinfo($chan,match) [list $ref $mbox]
# parray folderinfo
#set rv [punk::imap4::proto::simplecmd $chan LIST $allowstates \"$ref\" \"$mbox\"]
if {[has_capability $chan SPECIAL-USE]} {
set rv [punk::imap4::proto::simplecmd $chan -validstates $allowstates LIST \"$ref\" \"$mbox\" RETURN {(SPECIAL-USE SUBSCRIBED)}]
} else {
set rv [punk::imap4::proto::simplecmd $chan -validstates $allowstates LIST \"$ref\" \"$mbox\" RETURN (SUBSCRIBED)]
}
if {!$opt_inline} {
return $rv
}
set inlineresult {}
foreach f [folderinfo $chan flags] {
set lflags {}
foreach fl [lindex $f 1] {
#review - here we are converting things like {\HasNoChildren} to {hasnochildren}
#This may be desirable from a tcl script user's point of view - but may also
#be a surprise for those expecting the exact IMAP flags. todo?
if {[string is alnum [string index $fl 0]]} {
lappend lflags [string tolower $fl]
} else {
lappend lflags [string tolower [string range $fl 1 end]]
}
}
lappend inlineresult [list [lindex $f 0] $lflags]
}
return $inlineresult
}
# Search command.
proc SEARCH {chan args} {
if {![llength $args]} {
error "missing arguments. Usage: search chan arg ?arg ...?"
}
punk::imap4::proto::requirestate $chan {SELECT EXAMINE}
set imapexpr [punk::imap4::proto::convert_search_expr $args]
punk::imap4::proto::multiline_prefix_command imapexpr "SEARCH"
punk::imap4::proto::multiline_request $chan $imapexpr
if {[punk::imap4::proto::getresponse $chan]} {
return 1
}
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::debugchan
@cmd -name punk::imap4::debugchan -help\
"Set or query the debug flag for an open
channel with a server.
This emits some basic information about the
client request and the final response from the
server to stdout for every command that
interacts with the server."
@leaders -min 1 -max 1
chan
@values -min 0 -max 1
onoff -type boolean -optional 1
}]
proc debugchan {args} {
upvar ::punk::imap4::proto::coninfo coninfo
set argd [punk::args::parse $args withid ::punk::imap4::debugchan]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
if {![dict exists $received onoff]} {
#query
return [dict get $coninfo $chan debug]
}
dict set coninfo $chan debug [dict get $values onoff]
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::debugmode
@cmd -name punk::imap4::debugmode -help\
"Debug mode.
This is a developer mode that provides a basic REPL
(Read Eval Print Loop) to interact more directly with the
server.
Every line entered is sent verbatim to the
server (after the automatic addition of the request identifier/tag).
It's possible to execute Tcl commands by starting the line
with a forward slash."
@leaders -min 0 -max 0
@values -min 1 -max 2
chan -optional 0 -help\
"existing channel for an open IMAP connection"
errormsg -default "None"
}]
proc debugmode {chan {errormsg {None}}} {
variable debugmode 1
variable debugchan $chan
variable version
variable folderinfo
#variable mboxinfo
#variable msginfo
upvar ::punk::imap4::proto::info info
upvar ::punk::imap4::proto::coninfo coninfo
set welcometext [list \
"------------------------ IMAP DEBUG MODE --------------------" \
"server: [dict get $coninfo $chan hostname] port: [dict get $coninfo $chan port]" \
"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 debugmode" \
"Type 'info' to see information about the connection" \
"Type 'showlog ?requesttag|*?' to see the client/server log" \
" (No arg required to show the last command, * to see full log)." \
"Type 'help' to display this information" \
"Last error: '$errormsg'" \
"" \
"IMAP library version: '$version'" \
"" \
]
foreach l $welcometext {
puts $l
}
set prev_chan_debug [dict get $coninfo $chan debug]
dict set coninfo $chan debug 1 ;#ensure debug for this chan on while in debugmode
punk::imap4::proto::debugmode_info $chan
set prev_stdin_conf [chan configure stdin]
chan configure stdin -blocking 1 -inputmode normal
set last_request_tag *
try {
while 1 {
puts -nonewline "imap debug> "
flush stdout
gets stdin line
if {![string length $line]} continue
if {$line eq {!}} {
break
}
switch -glob -- $line {
info {
punk::imap4::proto::debugmode_info $chan
continue
}
help {
foreach l $welcometext {
if {$l eq ""} break
puts $l
}
continue
}
"showlog*" {
if {[regexp {^\s*showlog\s+(\S)\s*$} $line _ logtag]} {
puts [punk::imap4::showlog $chan $logtag]
} else {
puts [punk::imap4::showlog $chan $last_request_tag]
}
continue
}
}
if {[string index $line 0] eq {/}} {
catch {eval [string range $line 1 end]} result
#we may have called a function to make a request - sync our request tag
set last_request_tag [punk::imap4::lastrequesttag $chan]
puts $result
continue
}
# Let's send the request to imap server
set last_request_tag [punk::imap4::proto::request $chan $line]
if {[catch {punk::imap4::proto::getresponse $chan $last_request_tag} errormsg]} {
puts "--- ERROR ---\n$errormsg\n-------------\n"
}
}
} finally {
set debugmode 0
dict set coninfo $chan debugmode $prev_chan_debug ;#restore channel debug flag
chan configure stdin -blocking [dict get $prev_stdin_conf -blocking] -inputmode [dict get $prev_stdin_conf -inputmode]
}
}
#review
proc me {} {
variable debugchan
set debugchan
}
# Other stuff to do in random order...
#
# proc ::imap4::idle notify-command
# proc ::imap4::securestauth user pass
# proc ::imap4::store
# proc ::imap4::logout (need to clean both msg and mailbox info arrays)
# Amend the flags of a message to be updated once CLOSE/EXPUNGE is initiated ;#obsolete?
#STORE of a flag should be imediately reflected in the server state.
#\Recent is imaprev1 only (deprecated) - but in any case, is read-only
#The UID SEARCH mechanism should now be used instead of looking for \Recent flag on the mailbox
#or the untagged response: * <n> RECENT
#UID SEARCH UID > <last-seen-UID>
#The \Recent flag may exist on messages - but is optional
lappend PUNKARGS [list {
@id -id ::punk::imap4::STORE
@cmd -name punk::imap4::STORE -help\
"Alters data associated with a message (or messages) in the mailbox.
The .SILENT suffix for the storetype arg indicates the client is not
requesting an untagged FETCH response indicating the new state of
the flags; however, even in it's presence, servers should send an
untagged FETCH response if an external change to the flags is
observed (e.g changed by another client/session)
"
@leaders -min 1 -max 1
chan -optional 0 -help\
"existing channel for an open IMAP connection"
@values -min 2 -max 3
sequence-set -help\
"A message sequence set such as:
1:1
2:4
*:3
1,3,5,7:9
"
storetype -default +FLAGS -choicecolumns 1 -choices {+FLAGS +FLAGS.SILENT -FLAGS -FLAGS.SILENT FLAGS FLAGS.SILENT}\
-choicelabels {
+FLAGS\
"Add the supplied flagnames to the flags for the message.
The new value of the flags is returned as if a FETCH of
those flags was done."
+FLAGS.SILENT\
"Equivalent to FLAGS, but without returning the new value."
-FLAGS\
"Remove the supplied flagnames from the flags for the
message. The new value of the flags is returned as if a
FETCH of those flags was done."
-FLAGS.SILENT\
"Equivalent to -FLAGS, but without returning a new value."
FLAGS\
"REPLACE the flags for the message with the suplied
flagnames. The new value of the flags is returned as if
a FETCH of those flags was done."
FLAGS.SILENT\
"Equivalent to FLAGS, but without returning a new value."
} -help\
"The type of STORE operation to be performed on the upplied flagnames"
flagname -multiple 1 -choicecolumns 2 -choicerestricted 0 -choicegroups {
SystemFlags {{\Deleted} {\Flagged} {\Seen} {\Answered} {\Draft}}
Keywords9051 {{$MDNSent} {$Forwarded} {$Junk} {$NotJunk} {$Phishing}}
OtherKeywords {{$Important} {$Submitted} {$SubmitPending}}
Obsolete {{\Recent}}
}\
-choicelabels {
{\Seen}\
{ Message has been read}
{\Answered}\
{ Message has been answered}
{\Flagged}\
{ Message is "flagged" for urgent/special attention}
{\Deleted}\
{ Message is "deleted" for removal by later EXPUNGE}
{\Draft}\
{ Message has not completed composition (marked as a
draft).}
{\Recent}\
{ This flag was in use in IMAP4rev1 and was deprecated
in RFC9051}
$Forwarded\
" Message has been forwarded to another email address
by being embedded within, or attached to a new message.
An email client sets this keyword when it successfully
forwards the message to another email address. Typical
usage of this keyword is to show a different (or
additional) icon for a message that has been forwarded.
Once set, the flag SHOULD NOT be cleared."
$MDNSent\
" Message Disposition Notification [RFC8098] was
generated and sent for this message. See [RFC3503] for
more details on how this keyword is used and for
requirements on clients and servers."
$Junk\
" The user (or a delivery agent on behalf of the user)
may choose to mark a message as definitely containing
junk. The $Junk keyword can be used to mark, group,
or hide undesirable messages (and such messages might
be removed or deleted later)."
$NotJunk\
" The user (or a delivery agent on behalf of the user)
may choose to mark a message as definitely not
containing junk. The $NotJunk keyword can be used to
mark, group, or show messages that the user wants to
see."
$Phishing\
" The $Phishing keyword can be used by a delivery agent
to mark a message as highly likely to be a phishing
email. A message that's determined to be a phishing
email by the delivery agent should also be considered
junk email and have the appropriate junk filtering
applied, including setting the $Junk flag and placing
the message in the \Junk special-use mailbox if
available"
} -help\
{Each supplied value is a system flag such as \Seen \Deleted etc or a
keyword/user-defined flag (a name not beginning with a backslash)
The items listed as Keywords9051 are mentioned in RFC9051 as SHOULD be supported
by servers. See also registered keywords:
https://www.iana.org/assignments/imap-jmap-keywords/imap-jmap-keywords.xhtml
}
}]
proc STORE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::STORE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set sequenceset [dict get $values sequence-set]
set storetype [dict get $values storetype]
set flagnames [dict get $values flagname] ;#multiple
set ranges [split $sequenceset ,]
#parse each seq-range to give a chance to raise error
foreach range $ranges {
parse_seq-range $chan $range
}
#review - do we need any client side validation? Duplicates only?
#What about presence of inconsistent flags $Junk $NotJunk?
#probably just best to let the server sort it out
#set validatedflags {}
#foreach fname $flagnames {
# if {[regexp {^\\+(.*?)$} $fname]} {
# #system flag - restrict?
# lappend validatedflags "\\$fname"
# } else {
# #user-defined flag - any name that does not start with a backslash
# lappend validatedflags $fname
# }
#}
set clitag [punk::imap4::proto::request $chan "STORE $sequenceset $storetype ([join $flagnames])"]
if {[punk::imap4::proto::getresponse $chan $clitag]} {
return 1
}
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::LOGOUT
@cmd -name punk::imap4::LOGOUT -help\
"End the connection cleanly.
This disconnects from the server and reads the untagged BYE response
from the server.
It also tidies up client state associated with the channel."
@leaders -min 1 -max 1
chan -optional 0
@opts
@values -min 0 -max 0
}]
proc LOGOUT {args} {
set argd [punk::args::parse $args withid ::punk::imap4::LOGOUT]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
if {[punk::imap4::proto::simplecmd $chan LOGOUT]} {
# clean out info arrays
variable folderinfo
variable mboxinfo
variable msginfo
upvar ::punk::imap4::proto::info info
upvar ::punk::imap4::proto::coninfo coninfo
array unset folderinfo $chan,*
#array unset mboxinfo $chan,*
dict unset mboxinfo $chan
#array unset msginfo $chan,*
dict unset msginfo $chan
array unset info $chan,*
dict unset $coninfo $chan
return 1
}
return 0
}
#Permanently removes all messages that have the \Deleted flag
#set from the currently selected mailbox.
proc EXPUNGE {chan} {
#Cannot call from EXAMINE state
if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT} EXPUNGE]} {
return 1
}
return 0
}
# copy : copy a message to a destination mailbox
lappend PUNKARGS [list {
@id -id ::punk::imap4::COPY
@cmd -name punk::imap4::COPY -help\
"Copies the specified message(s) to the end
of the destination mailbox.
The server SHOULD preserve the flags and
internal date of the message(s) in the copy."
@leaders -min 1 -max 1
chan
@values -min 2 -max 2
sequence-set
mailbox
}]
proc COPY {args} {
set argd [punk::args::parse $args withid :punk::imap4::COPY]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set sequenceset [dict get $values sequence-set]
set mailbox [dict get $values mailbox]
if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT EXAMINE} COPY $sequenceset $mailbox]} {
return 1
}
return 0
}
lappend PUNKARGS [list {
@id -id ::punk::imap4::APPEND
@cmd -name punk::imap4::APPEND -help\
"EXPERIMENTAL - incomplete"
@leaders -min 2 -max 4
chan
mailbox
#The API is a little clunky because the IMAP function has optional interim arguments between mailbox and message.
#We can only put flags after all leaders - which can make this function
#appear inconsistent with others where options always come after chan.
#This is a somewhat deliberate limitation of punk::args - it is intended to provide a simple understandable model
#covering most use-cases - not totally freeform mixes of options between other arguments - especially with optional
#non-flag arguments. (efficiency and complexity and unambiguity regarding values starting with - are important considerations)
#e.g "func a -opt1 o1 b? c? d e" is not supported.
#(optional non-flag args must be at end of leaders or values - and opts must be between those 2 sets.)
#so instead we will use the equiv of "func a b? c? -opt1 o1 d e"
flaglist -default {} -optional 1 -type list -help\
{List of flags such as \Seen \Flagged}
datetime -default "" -optional 1 -type string
@opts
@values -min 1 -max 1
message
}]
proc APPEND {args} {
set argd [punk::args::parse $args withid ::punk::imap4::APPEND]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $leaders mailbox]
set flaglist [dict get $leaders flaglist]
set datetime [dict get $leaders datetime]
set message [dict get $values message]
#todo - send as single synchronizing literal after getting server's continuation (or non-synchronising literals)
return 1
#if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT EXAMINE} APPEND $mailbox]} {
# return 1
#}
#return 0
}
#ascii art from RFC3501/RFC9051
proc rfc_diagram {} {
punk::args::lib::tstr {
+----------------------+
|connection established|
+----------------------+
||
\/
+--------------------------------------+
| server greeting |
+--------------------------------------+
|| (1) || (2) || (3)
\/ || ||
+-----------------+ || ||
|Not Authenticated| || ||
+-----------------+ || ||
|| (7) || (4) || ||
|| \/ \/ ||
|| +----------------+ ||
|| | Authenticated |<=++ ||
|| +----------------+ || ||
|| || (7) || (5) || (6) ||
|| || \/ || ||
|| || +--------+ || ||
|| || |Selected|==++ ||
|| || +--------+ ||
|| || || (7) ||
\/ \/ \/ \/
+--------------------------------------+
| Logout |
+--------------------------------------+
||
\/
+-------------------------------+
|both sides close the connection|
+-------------------------------+
(1) connection without pre-authentication
(OK greeting)
(2) pre-authenticated connection
(PREAUTH greeting)
(3) rejected connection (BYE greeting)
(4) successful LOGIN or AUTHENTICATE command
(5) successful SELECT or EXAMINE command
(6) CLOSE or UNSELECT command, unsolicited
CLOSED response code, or failed SELECT
or EXAMINE command
(7) LOGOUT command, server shutdown, or
connection closed
}
}
#FROM RFC9051
#"Session" refers to the sequence of client/server interaction from
#the time that a mailbox is selected (SELECT or EXAMINE command) until
#the time that selection ends (SELECT or EXAMINE of another mailbox,
#CLOSE command, UNSELECT command, or connection termination).
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::imap4 ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::imap4::admin {
tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
lappend PUNKARGS [list {
@id -id "::punk::imap4::admin::GETQUOTA"
@cmd -name "punk::imap4::::admin::GETQUOTA" -help\
"Get quota information"
@leaders -min 1 -max 1
chan
@opts
@values -min 1 -max 1
mailbox -help\
"e.g user/account.test"
}]
proc GETQUOTA {args} {
set argd [punk::args::parse $args withid ::punk::imap4::admin::GETQUOTA]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
punk::imap4::proto::simplecmd $chan GETQUOTA {AUTH SELECT} $mailbox
}
lappend PUNKARGS [list {
@id -id "::punk::imap4::admin::SETQUOTARESOURCE"
@cmd -name "punk::imap4::admin::SETQUOTARESOURCE" -help\
"Set quota for a resource"
@leaders -min 1 -max 1
chan
@opts
-resource -default STORAGE -help\
"This interface only allows setting of a single resource
at a time."
@values -min 2 -max 2
mailbox -help\
"e.g user/account.test"
quota -type integer -minsize 0 -help\
"Number of 1024 Byte blocks
(KB)"
}]
proc SETQUOTARESOURCE {args} {
set argd [punk::args::parse $args withid ::punk::imap4::admin::SETQUOTARESOURCE]
lassign [dict values $argd] leaders opts values received
set chan [dict get $leaders chan]
set mailbox [dict get $values mailbox]
set resource [dict get $opts -resource]
set quota [dict get $values quota]
punk::imap4::proto::simplecmd $chan SETQUOTA {AUTH SELECT} $mailbox "($resource $quota)"
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::imap4::lib {
tcl::namespace::export {[a-z]*}
tcl::namespace::path [tcl::namespace::parent]
variable PUNKARGS
#*** !doctools
#[subsection {Namespace punk::imap4::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#return 2 element list {address port} even if no port supplied.
#port value 0 if not supplied
proc parse_address_port {address_and_port} {
#must handle ipv6 & ipv4 addresses with and without port
#as ipv6 needs square brackets to handle possible port
# for symmetry we should support bracketed or unbracketed hostnames and ipv4 addresses too.
#e.g for localhost [::1]:143
#e.g [1001:DF3:CF80::143]
set address_and_port [string trim $address_and_port] ;#tolerate surrounding whitespace
set csplit [split $address_and_port :]
switch -- [llength $csplit] {
1 {
#portless address - could be bracketed/unbracketed ip4,ip6 or hostname
if {[string match {\[*\]} $address_and_port]} {
set address [string range $address_and_port 1 end-1]
set address [string trim $address] ;#tolerate whitespace in brackets
} else {
set address $address_and_port
}
set port 0
}
2 {
lassign $csplit addresspart port
#tolerate surrounding whitespace or whitespace around colon
set addresspart [string trim $addresspart]
set port [string trim $port]
if {[string match {\[*\]} $addresspart]} {
set address [string range $addresspart 1 end-1]
set address [string trim $address]
} else {
set address $addresspart
}
}
default {
#more than 1 colon - assume ipv6 - could be bracketed with or port
#or unbracketed without port
if {[regexp {\s*\[(.*)\]\s*(.*)} $address_and_port _match address tail]} {
if {[string match :* $tail]} {
set port [string range $tail 1 end]
set port [string trim $port]
if {$port eq ""} {
#we'll allow a trailing colon after square brackets as equivalent of unspecified port
set port 0
}
} else {
set port 0
}
} else {
#assume entire expression is unbracketed ipv6 with no port
set address $address_and_port
set port 0
}
}
}
if {![string is integer -strict $port]} {
error "parse_address_port unable to determine address and port from $address_and_port - port not integer"
}
if {[regexp {\s} $address]} {
error "parse_address_port unable to determine address and port from $address_and_port - unexpected whitespace"
}
return [list $address $port]
}
## Extract a quoted string
#proc imaptotcl_quoted {chan datavar} {
# upvar 1 $datavar data
# if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} {
# protoerror $chan "IMAP data format error: '$data'"
# }
# set data [string range $data [string length $match] end]
# return [string range $match 1 end-1]
#}
# imapwords - a nonregex based parsing of IMAP command/response structures
# see also imaptotcl_ functions for alternative mechanism
#consider what to do with partial lines due to literals:
# * METADATA Drafts ("/private/specialuse" {7}
#consider the following elements:
# BODY[]
# BODY[]<0.100>
# BINARY.PEEK[1]<100.200>
# we would categorise these as 'bare' initially - but switch to 'sectioned' at opening square bracket
#
#A654 FETCH 2:4 (FLAGS BODY[HEADER.FIELDS (DATE FROM)])
#
#* OK [UIDVALIDITY 3857529045] UIDs valid
#REVIEW
#consider also literal8? ~{<number>}
#at the moment this will parse as 'bare'
proc imapwords {line {maxwords 0}} {
#resulting dictionary to have number of words based on *toplevel* structure
# e.g BODY[HEADER.FIELDS (DATE FROM)] is a single word at the toplevel.
set len [string length $line]
set structure none ;#none|bare|sectioned|quoted|list|literal
set indq 0 ;#in double quotes
set squarenest 0 ;#in square brackets
set listnest 0
#set inbracket 0
#set inbrace 0
set words [dict create]
set w -1
set current ""
set inesc 0
for {set i 0} {$i < $len} {incr i} {
set c [string index $line $i]
if {$inesc} {
if {$c eq "\\"} {
set inesc 0
}
#treat char prefixed with a backslash as non-special e.g \( \) etc don't start/end lists, quoted sections etc
#we also encounter things such as \Sent for which the backslash is just a literal
set c "\\$c"
} else {
if {$c eq "\\"} {
set inesc 1
continue
}
}
switch -- $structure {
none {
if {![string is space $c]} {
set openc "\{" ;#\}
set testc [string map [list $openc opencurly] $c]
#start of a new word
set indq 0
switch -- $testc {
{"} {
incr w
set structure quoted
dict set words $w [dict create type quoted]
set indq 1
}
{(} {
#)
incr w
set listnest 1
set structure list
dict set words $w [dict create type list]
}
{[} {
#]
incr w
set squarenest 1
set structure squarelist
dict set words $w [dict create type squarelist]
}
opencurly {
incr w
set structure literal
dict set words $w [dict create type literal]
}
default {
incr w
set structure bare
dict set words $w [dict create type bare] ;#this is our initial assumption - may be converted to 'sectioned' later
}
}
#our resulting list retains the exact syntax of elements - ie keep openers and closers
append current $c
}
}
bare {
#should usually be an imap ATOM - one or more non-special characters
#we won't try to balance quotes if encountered in bare e.g xxx"y z" would become 2 bares - shouldn't exist anyway?
#assert not indq anyway
set indq 0
if {![string is space $c]} {
if {$c eq "\["} {
#not actually an atom..
set squarenest 1
dict set words $w type sectioned
set structure sectioned
}
#\]
append current $c
} else {
#end of bare word
dict set words $w value $current
set current ""
set structure none
if {$maxwords == $w+1} {
break
}
}
}
squarelist {
#square bracketed substructures e.g
#[PERMANENTFLAGS (<list of flags>)]
#[CAPABILITY IMAP4rev1 LITERAL+ ...]
#It's not known if the protocol or extensions have any subelements that are themselves squarelists
#but we need to count square brackets anyway.
#we don't check balance of sub lists - leave for a subsequent parse of this word's inner structure - REVIEW
if {$indq} {
#don't need to count squarenest or terminate on whitespace
if {$c eq "\""} {
set indq 0
}
append current $c
} else {
#don't allow whitespace to terminate
if {$c eq "\["} {
#not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle
incr squarenest
append current $c
} elseif {$c eq "\]"} {
incr squarenest -1
if {$squarenest == 0} {
#end of squarelist
dict set words $w value $current$c
set current ""
set structure none
if {$maxwords == $w+1} {
break
}
}
} elseif {$c eq "\""} {
set indq 1
append current $c
} else {
append current $c
}
}
}
sectioned {
#whatever these sorts of things are:
# BODY[]
# BODY[]<0>
#The squarebracketed parts can contain substructures like squarelist - but we want to treat this whole thing
#as a word from a toplevel perspective.
#
if {$indq} {
#don't need to count squarenest or terminate on whitespace
if {$c eq "\""} {
set indq 0
}
append current $c
} else {
if {$squarenest > 0} {
#don't allow whitespace to terminate
if {$c eq "\["} {
#not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle
incr squarenest
} elseif {$c eq "\]"} {
incr squarenest -1
} elseif {$c eq "\""} {
set indq 1
}
append current $c
} else {
#presumably at tail e.g BODY[]<0.100>
if {![string is space $c]} {
if {$c eq "\["} {
incr squarenest
} elseif {$c eq "\]"} {
incr squarenest -1
} elseif {$c eq "\""} {
set indq 1
}
append current $c
} else {
#end of sectioned
dict set words $w value $current
set current ""
set structure none
if {$maxwords == $w+1} {
break
}
}
}
}
}
quoted {
#assert indq 1 anyway
set indq 1
if {$c eq "\""} {
set indq 0
#end of quoted - we shouldn't have to handle "xxx"y - it will become the same as "xxx" y REVIEW
dict set words $w value $current$c
set current ""
set structure none
if {$maxwords == $w+1} {
break
}
} else {
append current $c
}
}
list {
#review
#we are not catering for certain unbalanced things like brackets in square bracketed sections: ([xxx(etc]) - should not be required
# this would represent a word that won't be completed at line end - at which point we can detect as an error
#we do cater for unbalanced brackets in quoted strings - as arbitrary strings seem more likely.
if {$indq} {
if {$c eq "\""} {
set indq 0
}
append current $c
} else {
if {$c eq "("} {
incr listnest
append current $c
} elseif {$c eq ")"} {
incr listnest -1
if {$listnest == 0} {
#end outer list
dict set words $w value $current$c
set current ""
set structure none
if {$maxwords == $w+1} {
break
}
} else {
append current $c
}
} elseif {$c eq "\""} {
set indq 1
append current $c
} else {
append current $c
}
}
}
literal {
#we are only catering for basic {nnn} where we expect nnn to be an integer byte count
#or {nnn+}
#Presumably these should be in quoted strings if in mailbox names, searches etc? REVIEW
#\{ ;#editorfix
set rc "\}"
#
if {$c eq $rc} {
#end literal
dict set words $w value $current$c
set current ""
set structure none
if {$maxwords == $w+1} {
break
}
} else {
append current $c
}
}
}
set inesc 0
}
set size [dict size $words]
if {$size} {
set lastindex [expr {$size -1}]
set lastitem [dict get $words $lastindex]
if {![dict exists $lastitem value]} {
#the word didn't complete
dict set words $lastindex value $current
set lasttype [dict get $lastitem type]
#only bare or sectioned require space to terminate - or autoterminate at end of line
if {$lasttype ni {bare sectioned}} {
#other type didn't terminate at end of line - mark as incomplete
dict set words $lastindex error INCOMPLETE
}
}
}
#outer level structure. imapwords can be called again on each word that is of type list or squarelist.
#If a word is of type 'sectioned' it will need to be split into parts for parsing separately
#e.g BINARY.PEEK[<section-binary>]<<partial>> (bare,squarelist?,partial)
return $words
}
#taking an existing words dict that may contain type = literal entries (value = {n})
# and a list of the previously read literals
# stitch them together
proc imapwords_resolved {words literals} {
dict for {wordindex wordinfo} $words {
if {[dict get $wordinfo type] eq "literal"} {
set lit [dict get $wordinfo value]
set litinner [string range $lit 1 end-1]
#server does not send non-synchronizing literals e.g {123+}
set resolved_value [::lpop literals 0]
if {[punk::imap4::proto::is_imap_number64 $litinner] && [string length $resolved_value] == $litinner} {
dict set words $wordindex value $resolved_value
} else {
#protoerror $chan "IMAP: METADATA malformed response ($lit mismatch size of literal [string length $val]) '$line'"
}
dict set words $wordindex type resolvedliteral
}
}
return $words ;#resolved words where type 'literal' has been replaced with 'resolvedliteral'
}
#firstword_basic and secondword_basic don't handle IMAP structures such as lists etc
proc firstword_basic {line} {
if {[regexp -indices -start 0 {\S+} $line range]} {
return [string range $line {*}$range]
} else {
error "firstword regexp failed" ;#why?
}
}
proc secondword_basic {line} {
if {[regexp -indices -start 0 {\S+} $line range]} {
lassign $range s e
if {[regexp -indices -start $e+1 {\S+} $line range]} {
return [string range $line {*}$range]
} else {
error "secondword regexp failed" ;#why?
}
} else {
error "secondword regexp failed." ;#why?
}
}
proc firstword {line} {
set words [imapwords $line 1]
if {[dict size $words]} {
return [dict get $words 0 value]
}
return ""
}
proc secondword {line} {
set words [imapwords $line 2]
if {[dict size $words] > 1} {
return [dict get $words 1 value]
}
return ""
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::imap4::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::imap4 {
tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
namespace eval argdoc {
#namespace for custom argument documentation
proc package_name {} {
return punk::imap4
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package punk::imap4
A fork from tcllib imap4 module
imap4 - imap client-side tcl implementation of imap protocol
} \n]
}
proc get_topic_License {} {
return "X11"
}
proc get_topic_Version {} {
return "$::punk::imap4::version"
}
proc get_topic_Contributors {} {
set authors {{Salvatore Sanfilippo <antirez@invece.org>} {Nicola Hall <nicci.hall@gmail.com>} {Magnatune <magnatune@users.sourceforge.net>} {Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return $contributors
}
proc get_topic_notes {} {
punk::args::lib::tstr -return string {
X11 license - is MIT with additional clause regarding use of contributor names.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::imap4::about"
dict set overrides @cmd -name "punk::imap4::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::imap4
}] \n]
dict set overrides topic -choices [list {*}[punk::imap4::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::imap4::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::imap4::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::imap4::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::imap4 ::punk::imap4::admin ::punk::imap4::proto
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::imap4 [tcl::namespace::eval punk::imap4 {
variable pkg punk::imap4
variable version
set version 999999.0a1.0
}]
################################################################################
# Example and test
################################################################################
if {[info script] eq $argv0} {
#when running a tm module as an app - we should calculate the corresponding tm path
#based on info script and the namespace of the package being provided here
#and add that to the tm list if not already present.
#(auto-cater for any colocated dependencies)
puts "--[info script]--"
punk::args::define {
@id -id ::punk::imap4::commandline
@cmd -name imap4::commandline -help\
"Sample imap4 app to show info about chosen folder
and a few of its messages"
@leaders -min 0 -max 0
@opts
-debug -type none
-security -default TLS/SSL -nocase 1 -choices {None STARTTLS TLS/SSL}
-port -default 0 -type integer -help\
"port to connect to.
It is invalid to set this as well as a non-zero
port value specified as part of the server argument"
@values -min 3 -max 4
server -help\
"server or IP - may optionally include port
e.g
server.example.com:143
10.0.0.1:993
[::1]:143
"
user
pass
folder -optional 1 -default INBOX
}
set argd [punk::args::parse $argv withid ::punk::imap4::commandline]
lassign [dict values $argd] leaders opts values received
if {[dict exists $received -debug]} {
set debugflags "-debug 1"
} else {
set debugflags "-debug 0"
}
set opt_security [dict get $opts -security]
set opt_port [dict get $opts -port]
set server [dict get $values server]
lassign [punk::imap4::lib::parse_address_port $server] address addrport
if {$addrport !=0 && $opt_port != 0} {
puts stderr "Cannot specify port both in -port option as well as part of server argument"
puts stderr [punk::args::usage -scheme error ::punk::imap4::commandline]
return
}
if {$addrport != 0} {
set port $addrport
} else {
set port $opt_port ;#may still be zero
}
set user [dict get $values user]
set pass [dict get $values pass]
set folder [dict get $values folder]
# open and login ...
set imap [punk::imap4::CONNECT {*}$debugflags -security $opt_security $server $opt_port]
punk::imap4::AUTH_LOGIN $imap $user $pass
punk::imap4::select $imap $folder
# Output all the information about that mailbox
foreach info [punk::imap4::mboxinfo $imap] {
puts "$info -> [punk::imap4::mboxinfo $imap $info]"
}
set num_mails [punk::imap4::mboxinfo $imap exists]
if {!$num_mails} {
puts "No mail in folder '$folder'"
} else {
set fields {from: to: subject: size}
# fetch 3 records (at most)) inline
set max [expr {$num_mails<=3?$num_mails:3}]
foreach rec [punk::imap4::FETCH $imap 1:$max -inline {*}$fields] {
puts -nonewline "#[incr idx])"
for {set j 0} {$j<[llength $fields]} {incr j} {
puts "\t[lindex $fields $j] [lindex $rec $j]"
}
}
# Show all the information available about the message ID 1
puts "Available info about message 1 => [punk::imap4::msginfo $imap 1]"
}
# Use the capability stuff
puts "Capabilities: [punk::imap4::proto::has_capability $imap]"
puts "Is able to imap4rev1? [punk::imap4::proto::has_capability $imap imap4rev1]"
if {[dict get $::punk::imap4::coninfo $imap debug]} {
punk::imap4::debugmode $imap
}
# Cleanup
punk::imap4::cleanup $imap
}
return
#*** !doctools
#[manpage_end]