From 7a1a4a4ef5f5eb8818c7a02f7cbf5ac075a44781 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 15 Mar 2025 03:04:42 +1100 Subject: [PATCH] add punk::imap4::admin functions --- src/modules/punk/imap4-999999.0a1.0.tm | 167 ++++++++++++++++--------- 1 file changed, 111 insertions(+), 56 deletions(-) diff --git a/src/modules/punk/imap4-999999.0a1.0.tm b/src/modules/punk/imap4-999999.0a1.0.tm index a6f8355b..5952717a 100644 --- a/src/modules/punk/imap4-999999.0a1.0.tm +++ b/src/modules/punk/imap4-999999.0a1.0.tm @@ -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 ()] + #[PERMANENTFLAGS ()] #[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]"