jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

add punk::imap4::admin functions

master
Julian Noble 3 weeks ago
parent
ab43137c29
commit
7a1a4a4ef5
1 changed files with 111 additions and 56 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 167
      src/modules/punk/imap4-999999.0a1.0.tm

167
src/modules/punk/imap4-999999.0a1.0.tm
Unescape View File

@ -91,7 +91,7 @@
#[manpage_begin shellspy_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 --}]
#[moddesc {IMAP4 client}] [comment {-- Description at end of page heading --}]
#[require punk::imap4]
#[keywords module mail imap imap4 client mailclient]
#[description]
@ -110,8 +110,8 @@ tcl::namespace::eval punk::imap4 {
#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)
#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--"
@ -220,7 +220,7 @@ tcl::namespace::eval punk::imap4::system {
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"
error "add_conlog type must be line literal or chunk"
}
variable conlog
set records [list]
@ -229,7 +229,7 @@ tcl::namespace::eval punk::imap4::system {
}
return [llength $datalist]
}
proc get_conlog {chan {tag *}} {
proc get_conlog {chan {tag *}} {
variable conlog
if {$tag eq "*"} {
return [dict get $conlog $chan]
@ -241,7 +241,7 @@ tcl::namespace::eval punk::imap4::system {
#set result [list]
#set first [lsearch -index 3 $loglist $tag]
#if {$first > -1} {
# set last [lsearch -index 3 -start $first+1 $loglist $tag]
# set last [lsearch -index 3 -start $first+1 $loglist $tag]
# if {$last > -1} {
# set result [lrange $loglist $first $last]
# } else {
@ -765,7 +765,7 @@ tcl::namespace::eval punk::imap4::proto {
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})
#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]
@ -785,7 +785,7 @@ tcl::namespace::eval punk::imap4::proto {
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]
}
@ -793,7 +793,7 @@ tcl::namespace::eval punk::imap4::proto {
puts stderr "msgbox: $msgbox items: $items"
foreach {annotation val} $items {
#todo -cache? where?
#folderinfo is for last LIST command
#folderinfo is for last LIST command
#
puts stderr "msgbox: $msgbox annotation: $annotation value: $val"
}
@ -819,7 +819,7 @@ tcl::namespace::eval punk::imap4::proto {
HEADER {string cat HEADER}
RFC822.HEADER {
#deprecated in rfc9051
string cat RFC822.HEADER
string cat RFC822.HEADER
}
RFC822.TEXT {
string cat RFC822.TEXT
@ -848,7 +848,7 @@ tcl::namespace::eval punk::imap4::proto {
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
@ -1175,7 +1175,7 @@ tcl::namespace::eval punk::imap4 {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::imap4}]
#[para] Core API functions for punk::imap4
#[para] Core API functions for punk::imap4
#[list_begin definitions]
variable PUNKARGS
@ -1189,7 +1189,7 @@ tcl::namespace::eval punk::imap4 {
# 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]
#variable debug [dict create]
# Version
variable version "2025-02-25"
@ -1197,7 +1197,7 @@ tcl::namespace::eval punk::imap4 {
# This is where we take state of all the IMAP connections.
# The following arrays are indexed with the connection channel
# to access the per-channel information.
### client cached state
array set folderinfo {} ;# list of folders.
set mboxinfo [dict create] ;# selected mailbox info.
@ -2670,7 +2670,7 @@ tcl::namespace::eval punk::imap4 {
return 0
}
# Expunge : force removal of any messages with the
# Expunge : force removal of any messages with the
# flag \Deleted
proc EXPUNGE {chan} {
if {[punk::imap4::proto::simplecmd $chan EXPUNGE SELECT {}]} {
@ -2744,6 +2744,61 @@ tcl::namespace::eval 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
@ -2756,21 +2811,21 @@ tcl::namespace::eval punk::imap4::lib {
#*** !doctools
#[subsection {Namespace punk::imap4::lib}]
#[para] Secondary functions that are part of the API
#[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
# #[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
#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]
@ -2784,7 +2839,7 @@ tcl::namespace::eval punk::imap4::lib {
set address [string trim $address] ;#tolerate whitespace in brackets
} else {
set address $address_and_port
}
}
set port 0
}
2 {
@ -2842,11 +2897,11 @@ tcl::namespace::eval punk::imap4::lib {
# imapwords - a nonregex based parsing of IMAP command/response structures
# see also imaptotcl_ functions for alternative mechanism
# 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[]
# BODY[]<0.100>
# BINARY.PEEK[1]<100.200>
# we would categorise these as 'bare' initially - but switch to 'sectioned' at opening square bracket
@ -2870,7 +2925,7 @@ tcl::namespace::eval punk::imap4::lib {
#set inbracket 0
#set inbrace 0
set words [dict create]
set w -1
set w -1
set current ""
set inesc 0
for {set i 0} {$i < $len} {incr i} {
@ -2906,28 +2961,28 @@ tcl::namespace::eval punk::imap4::lib {
#)
incr w
set listnest 1
set structure list
set structure list
dict set words $w [dict create type list]
}
{[} {
#]
incr w
set squarenest 1
set structure squarelist
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
#our resulting list retains the exact syntax of elements - ie keep openers and closers
append current $c
}
}
@ -2938,7 +2993,7 @@ tcl::namespace::eval punk::imap4::lib {
#assert not indq anyway
set indq 0
if {![string is space $c]} {
if {$c eq "\["} {
if {$c eq "\["} {
#not actually an atom..
set squarenest 1
dict set words $w type sectioned
@ -2958,7 +3013,7 @@ tcl::namespace::eval punk::imap4::lib {
}
squarelist {
#square bracketed substructures e.g
#[PERMANENTFLAGS (<list of flags>)]
#[PERMANENTFLAGS (<list of flags>)]
#[CAPABILITY IMAP4rev1 LITERAL+ ...]
#It's not known if the protocol or extensions have any subelements that are themselves squarelists
@ -2973,8 +3028,8 @@ tcl::namespace::eval punk::imap4::lib {
} 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
#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
@ -3012,8 +3067,8 @@ tcl::namespace::eval punk::imap4::lib {
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
#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 "\""} {
@ -3096,7 +3151,7 @@ tcl::namespace::eval punk::imap4::lib {
}
literal {
#we are only catering for basic {nnn} where we expect nnn to be an integer byte count
#or {nnn+}
#or {nnn+}
#Presumably these should be in quoted strings if in mailbox names, searches etc? REVIEW
#\{ ;#editorfix
set rc "\}"
@ -3128,7 +3183,7 @@ tcl::namespace::eval punk::imap4::lib {
if {$lasttype ni {bare sectioned}} {
#other type didn't terminate at end of line - mark as incomplete
dict set words $lastindex error INCOMPLETE
}
}
}
}
@ -3163,14 +3218,14 @@ tcl::namespace::eval punk::imap4::lib {
if {[dict size $words]} {
return [dict get $words 0 value]
}
return ""
return ""
}
proc secondword {line} {
set words [imapwords $line 2]
if {[dict size $words] > 1} {
return [dict get $words 1 value]
}
return ""
return ""
}
#*** !doctools
@ -3187,16 +3242,16 @@ tcl::namespace::eval punk::imap4::lib {
#tcl::namespace::eval punk::imap4::system {
#*** !doctools
#[subsection {Namespace punk::imap4::system}]
#[para] Internal functions that are not part of the API
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::imap4 {
tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase
variable PUNKARGS
@ -3220,7 +3275,7 @@ tcl::namespace::eval punk::imap4 {
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
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]
@ -3228,11 +3283,11 @@ tcl::namespace::eval punk::imap4 {
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package punk::imap4
punk::args::lib::tstr [string trim {
package punk::imap4
A fork from tcllib imap4 module
imap4 - imap client-side tcl implementation of imap protocol
@ -3266,9 +3321,9 @@ tcl::namespace::eval punk::imap4 {
# 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 -name "punk::imap4::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::imap4
About punk::imap4
}] \n]
dict set overrides topic -choices [list {*}[punk::imap4::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
@ -3284,7 +3339,7 @@ tcl::namespace::eval punk::imap4 {
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# == === === === === === === === === === === === === === ===
# -----------------------------------------------------------------------------
@ -3294,16 +3349,16 @@ tcl::namespace::eval punk::imap4 {
# 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::proto
lappend ::punk::args::register::NAMESPACES ::punk::imap4 ::punk::imap4::admin ::punk::imap4::proto
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
## Ready
package provide punk::imap4 [tcl::namespace::eval punk::imap4 {
variable pkg punk::imap4
variable version
set version 999999.0a1.0
set version 999999.0a1.0
}]
################################################################################
@ -3313,8 +3368,8 @@ 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)
#and add that to the tm list if not already present.
#(auto-cater for any colocated dependencies)
puts "--[info script]--"
punk::args::define {
@ -3338,7 +3393,7 @@ if {[info script] eq $argv0} {
10.0.0.1:993
[::1]:143
"
user
user
pass
folder -optional 1 -default INBOX
}
@ -3380,7 +3435,7 @@ if {[info script] eq $argv0} {
set num_mails [punk::imap4::mboxinfo $imap exists]
if {!$num_mails} {
puts "No mail in folder '$folder'"
} else {
} else {
set fields {from: to: subject: size}
# fetch 3 records (at most)) inline
set max [expr {$num_mails<=3?$num_mails:3}]
@ -3390,11 +3445,11 @@ if {[info script] eq $argv0} {
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]"

Write Preview
Loading…
Cancel
Save