From ab43137c2976a092b95865938f88c1f27628f74a Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Fri, 7 Mar 2025 10:27:01 +1100 Subject: [PATCH] add punk::imap4 pkg, promise pkg, console/cesu/args updates --- callbacks/dispatch.tcl | 2 +- scriptlib/thread_interp.tcl | 69 + src/Tcl9icon.six | 2 + src/Tcl9icon.svg | 11 + .../modules/include_modules.config | 1 + src/bootsupport/modules/promise-1.2.0.tm | 1311 +++++++ src/bootsupport/modules/punk/args-0.1.0.tm | 13 +- src/bootsupport/modules/punk/console-0.1.1.tm | 60 +- src/defaultconfigs/Adventure.toml | 12 + src/lib/app-shellspy/shellspy.tcl | 167 +- src/modules/punk/args-999999.0a1.0.tm | 13 +- src/modules/punk/cesu-999999.0a1.0.tm | 215 +- src/modules/punk/console-999999.0a1.0.tm | 60 +- src/modules/punk/icomm-999999.0a1.0.tm | 2168 +++++++++++ src/modules/punk/icomm-buildversion.txt | 3 + src/modules/punk/imap4-999999.0a1.0.tm | 3412 ++++++++++++++++ src/modules/punk/imap4-buildversion.txt | 3 + src/modules/punk/jtest.tcl | 44 + src/modules/punk/repl-999999.0a1.0.tm | 3444 +++++++++++++++++ src/modules/punk/repl-buildversion.txt | 3 + .../modules/include_modules.config | 1 + .../src/bootsupport/modules/promise-1.2.0.tm | 1311 +++++++ .../bootsupport/modules/punk/args-0.1.0.tm | 13 +- .../bootsupport/modules/punk/console-0.1.1.tm | 60 +- .../modules/include_modules.config | 1 + .../src/bootsupport/modules/promise-1.2.0.tm | 1311 +++++++ .../bootsupport/modules/punk/args-0.1.0.tm | 13 +- .../bootsupport/modules/punk/console-0.1.1.tm | 60 +- src/runtime/mapvfs.config | 5 +- src/vendormodules/commandstack-0.3.tm | 8 +- src/vendormodules/include_modules.config | 2 + src/vendormodules/oolib-0.1.tm | 195 - src/vendormodules/overtype-1.6.5.tm | 45 +- src/vendormodules/promise-1.2.0.tm | 1311 +++++++ src/vendormodules/tomlish-1.1.1.tm | 9 +- .../lib/app-shellspy/shellspy.tcl | 167 +- .../_vfscommon.vfs/modules/promise-1.2.0.tm | 1311 +++++++ .../_vfscommon.vfs/modules/punk/args-0.1.0.tm | 13 +- .../_vfscommon.vfs/modules/punk/cesu-0.1.0.tm | 215 +- .../modules/punk/console-0.1.1.tm | 60 +- .../modules/punk/icomm-0.1.0.tm | 2168 +++++++++++ .../_vfscommon.vfs/modules/punk/imap4-0.9.tm | 3412 ++++++++++++++++ src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl | 44 + .../modules/punk/repl-0.1.1.tm} | 67 +- .../_vfscommon.vfs/modules/punk/repl-0.1.tm | 12 +- 45 files changed, 22381 insertions(+), 446 deletions(-) create mode 100644 scriptlib/thread_interp.tcl create mode 100644 src/Tcl9icon.six create mode 100644 src/Tcl9icon.svg create mode 100644 src/bootsupport/modules/promise-1.2.0.tm create mode 100644 src/defaultconfigs/Adventure.toml create mode 100644 src/modules/punk/icomm-999999.0a1.0.tm create mode 100644 src/modules/punk/icomm-buildversion.txt create mode 100644 src/modules/punk/imap4-999999.0a1.0.tm create mode 100644 src/modules/punk/imap4-buildversion.txt create mode 100644 src/modules/punk/jtest.tcl create mode 100644 src/modules/punk/repl-999999.0a1.0.tm create mode 100644 src/modules/punk/repl-buildversion.txt create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/promise-1.2.0.tm delete mode 100644 src/vendormodules/oolib-0.1.tm create mode 100644 src/vendormodules/promise-1.2.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/promise-1.2.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl rename src/{modules/punk/repl-0.1.tm => vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm} (98%) diff --git a/callbacks/dispatch.tcl b/callbacks/dispatch.tcl index 6d8f659d..d2a43906 100644 --- a/callbacks/dispatch.tcl +++ b/callbacks/dispatch.tcl @@ -2,7 +2,7 @@ namespace eval shellspy::callbacks { package require shellfilter - #each member of args - ist not itself a list - and cannot be treated as one. + #each member of args - is not itself a list - and cannot be treated as one. #things like [concat {*}args] will generall break things further down the line proc cmdshellb {args} { shellfilter::log::open callback_cmdb {-syslog 127.0.0.1:514} diff --git a/scriptlib/thread_interp.tcl b/scriptlib/thread_interp.tcl new file mode 100644 index 00000000..cb2aa9cd --- /dev/null +++ b/scriptlib/thread_interp.tcl @@ -0,0 +1,69 @@ +set arg1 [lindex $::argv 0] + +interp create code1 +interp create code2 + + +puts stderr "loading Thread package in all 3 interps" +package require Thread +code1 eval {package require Thread} +code2 eval {package require Thread} + +puts stderr "establishing ::testfunc proc in all 3 interps" +code1 eval {proc ::testfunc {args} {puts stderr "evaluated in code1 interp: $args"}} +code2 eval {proc ::testfunc {args} {puts stderr "evaluated in code2 interp: $args"}} +proc ::testfunc {args} {puts stderr "evaluated in parent interp: $args"} + + +puts stderr "Calling a thread function in nominated interp '$arg1' first" +#1st use of thread function makes that interp the one to receive all subsequent messages +switch -- $arg1 { + parent { + thread::id + } + code1 { + code1 eval {thread::id} + } + code2 { + code2 eval {thread::id} + } + default { + puts stderr "Usage thread_interp.tcl parent|code1|code2" + exit 1 + } +} + + +puts stderr "sending scripts" +thread::send -async [thread::id] { + ::testfunc script sent from parent interp +} +code1 eval { + thread::send -async [thread::id] { + ::testfunc script sent from code1 interp + } +} +code2 eval { + thread::send -async [thread::id] { + ::testfunc script sent from code2 interp + } +} +#test +after 0 {::testfunc after script in parent interp} +code1 eval {after 0 {::testfunc after script in code1 interp}} +code2 eval {after 0 {::testfunc after script in code2 interp}} + + +code1 eval { + set workertid [thread::create] + thread::send $workertid {package require Thread} + thread::send $workertid [list thread::send -async [thread::id] { + ::testfunc script sent from code1 interp via worker + }] +} + +after idle {set ::done 1} +vwait ::done + + + diff --git a/src/Tcl9icon.six b/src/Tcl9icon.six new file mode 100644 index 00000000..9fe68f6a --- /dev/null +++ b/src/Tcl9icon.six @@ -0,0 +1,2 @@ +[?25l[?80l[?8452lP0;1;0q"1;1;50;60#0;2;21;21;21#1;2;24;24;24#2;2;26;26;26#3;2;28;28;28#4;2;30;30;30#5;2;32;32;32#6;2;34;34;34#7;2;38;38;38#8;2;39;39;39#9;2;40;40;40#10;2;41;41;41#11;2;38;43;21#12;2;41;41;41#13;2;40;47;18#14;2;42;50;19#15;2;45;53;20#16;2;50;58;22#17;2;52;61;23#18;2;55;65;25#19;2;58;69;26#20;2;62;73;28#21;2;66;78;30#22;2;69;81;31#23;2;70;83;32#24;2;72;84;32#25;2;72;85;32#26;2;72;85;33#27;2;93;93;93#28;2;41;41;41#29;2;38;45;18#30;2;44;52;20#31;2;47;55;21#32;2;53;63;24#33;2;55;64;24#34;2;63;74;29#35;2;66;77;29#36;2;60;70;27#37;2;62;72;28#38;2;40;47;18#39;2;41;48;18#40;2;34;34;34#41;2;36;36;36#42;2;42;50;19#43;2;43;51;19#44;2;49;57;22#45;2;50;58;22#46;2;67;78;30#47;2;68;80;30#48;2;21;21;21#49;2;22;22;22#50;2;23;23;23#51;2;24;24;24#52;2;25;25;25#53;2;27;27;27#54;2;38;38;38#55;2;39;39;39#56;2;57;67;25#57;2;58;68;26#58;2;32;32;32#59;2;33;33;33#60;2;52;61;23#61;2;52;61;23#62;2;69;81;31#63;2;70;82;32#64;2;70;83;32#65;2;71;84;32#66;2;27;27;27#67;2;28;28;28#68;2;29;29;29#69;2;31;31;31#70;2;32;32;32#71;2;39;39;39#72;2;72;84;32#73;2;72;85;32#74;2;40;40;40#75;2;41;41;41#76;2;72;85;32#77;2;72;85;33#78;2;21;21;21#79;2;22;22;22#80;2;21;21;21#81;2;22;22;22#82;2;21;21;21#83;2;22;22;22#84;2;21;21;21#85;2;22;22;22#86;2;21;21;21#87;2;22;22;22#88;2;21;21;21#89;2;22;22;22#90;2;21;21;21#91;2;22;22;22#92;2;21;21;21#93;2;22;22;22#94;2;21;21;21#95;2;22;22;22#96;2;21;21;21#97;2;22;22;22#98;2;21;21;21#99;2;22;22;22#100;2;21;21;21#101;2;22;22;22#102;2;21;21;21#103;2;22;22;22#104;2;21;21;21#105;2;22;22;22#106;2;21;21;21#107;2;22;22;22#108;2;21;21;21#109;2;22;22;22#110;2;21;21;21#111;2;22;22;22#112;2;21;21;21#113;2;22;22;22#114;2;21;21;21#115;2;22;22;22#116;2;21;21;21#117;2;22;22;22#118;2;21;21;21#119;2;22;22;22#120;2;21;21;21#121;2;22;22;22#122;2;21;21;21#123;2;22;22;22#124;2;21;21;21#125;2;22;22;22#126;2;21;21;21#127;2;22;22;22#128;2;21;21;21#129;2;22;22;22#130;2;21;21;21#131;2;22;22;22#132;2;21;21;21#133;2;22;22;22#134;2;21;21;21#135;2;22;22;22#136;2;21;21;21#137;2;22;22;22#138;2;21;21;21#139;2;22;22;22#140;2;21;21;21#141;2;22;22;22#142;2;21;21;21#143;2;22;22;22#144;2;21;21;21#145;2;22;22;22#146;2;21;21;21#147;2;22;22;22#148;2;21;21;21#149;2;22;22;22#150;2;21;21;21#151;2;22;22;22#152;2;21;21;21#153;2;22;22;22#154;2;21;21;21#155;2;22;22;22#156;2;21;21;21#157;2;22;22;22#158;2;21;21;21#159;2;22;22;22#160;2;21;21;21#161;2;22;22;22#162;2;21;21;21#163;2;22;22;22#164;2;21;21;21#165;2;22;22;22#166;2;21;21;21#167;2;22;22;22#168;2;21;21;21#169;2;22;22;22#170;2;21;21;21#171;2;22;22;22#172;2;21;21;21#173;2;22;22;22#174;2;21;21;21#175;2;22;22;22#176;2;21;21;21#177;2;22;22;22#178;2;21;21;21#179;2;22;22;22#180;2;21;21;21#181;2;22;22;22#182;2;21;21;21#183;2;22;22;22#184;2;21;21;21#185;2;22;22;22#186;2;21;21;21#187;2;22;22;22#188;2;21;21;21#189;2;22;22;22#190;2;21;21;21#191;2;22;22;22#192;2;21;21;21#193;2;22;22;22#194;2;21;21;21#195;2;22;22;22#196;2;21;21;21#197;2;22;22;22#198;2;21;21;21#199;2;22;22;22#200;2;21;21;21#201;2;22;22;22#202;2;21;21;21#203;2;22;22;22#204;2;21;21;21#205;2;22;22;22#206;2;21;21;21#207;2;22;22;22#208;2;21;21;21#209;2;22;22;22#210;2;21;21;21#211;2;22;22;22#212;2;21;21;21#213;2;22;22;22#214;2;21;21;21#215;2;22;22;22#216;2;21;21;21#217;2;22;22;22#218;2;21;21;21#219;2;22;22;22#220;2;21;21;21#221;2;22;22;22#222;2;21;21;21#223;2;22;22;22#224;2;21;21;21#225;2;22;22;22#226;2;21;21;21#227;2;22;22;22#228;2;21;21;21#229;2;22;22;22#230;2;21;21;21#231;2;22;22;22#232;2;21;21;21#233;2;22;22;22#234;2;21;21;21#235;2;22;22;22#236;2;21;21;21#237;2;22;22;22#238;2;21;21;21#239;2;22;22;22#240;2;21;21;21#241;2;22;22;22#242;2;21;21;21#243;2;22;22;22#244;2;21;21;21#245;2;22;22;22#246;2;21;21;21#247;2;22;22;22#248;2;21;21;21#249;2;22;22;22#250;2;21;21;21#251;2;22;22;22#252;2;22;22;22#0!50?$#14!27?A$#16!31?C$#19!18?C$#20!34?C$#21!31?_$#25!14?O!19?GCC$#26!13?__oowww!10{wWWG$#29!17?C!20?C$#30!33?C$#34!40?A$#35!37?C$#39!41?A$#43!22?A!14?A$#44!23?A??A$#47!30?C!8?A$#56!35?G??A$#57!33?O$#60!24?AA$#61!13?O?G$#63!12?_$#65!16?G??C-#16!6?O$#20!27?C$#22!28?A$#25!6?_!4?@!17?@$#26!7?ow{}}!12~^NFB@$#31!30?@$#32!25?O$#33!24?_$#36!7?G?A$#37!8?C$#56!26?G$#60!10?@-#1!46?G$#5!42?_$#10!43?oww_$#19!23?@$#20!27?_$#21!22?A$#25!19?_$#26???_w}!13~^NB@$#29!30?C$#30!21?G$#31!26?_$#35!20?O$#39!27?O$#40!41?_$#44???GA$#50!43?G$#51!42?O$#54!46?O$#57!28?O$#61!29?G$#62!5?@$#63???O$#65!4?C$#70!44?C$#71!45?C$#72!21?C$#252!45?A-#3!47?@$#4!40?G$#10!39?_ow{!4~{$#21!22?_$#25!17?GA!4?GC$#26??{!14~F@$#30!24?A$#31!25?@$#32!18?C$#38!23?C$#39?_$#43!24?G$#46!26?@$#47??A$#50!42?@$#52!37?A!10?_$#54!47?A$#56!17?O?@???O$#59!40?@C$#61??@$#62!21?_$#64!25?A$#65!22?O$#68!39?O$#69!38?_@$#71!42?A$#252!48?O-#1!48?G$#3!28?G?O$#6!37?@$#9!33?G?C$#10!32?ooww{}!10~$#25!15?C??OC$#26??!13~B?_??A$#29!15?O$#31!19?A$#32!17?O$#35!16?@$#36!15?G!4?C$#37!20?@$#38!16?A$#39?C!19?A$#40!31?O$#41!36?A$#43?B$#47!18?G$#50!34?C$#51!30?G$#52!29?G$#53!31?G!16?D$#56!18?_$#59!32?G$#63!19?G$#68!48?A$#72!21?@$#252!27?G-#7!31?@$#9!46?G@$#10!27?_ow{}!14~F$#14???O$#20!16?C$#21??@$#22!16?@$#23!17?@$#25!15?C$#26???F^!9~WGA$#29!17?A$#32!14?AO$#37!14?C$#44??A$#45!15?A$#46???G$#47!14?@$#59!27?O$#63!4?_$#65!14?_$#66!29?C$#67!28?G$#68!46?O$#69!30?A$#70!47?A$#71!26?_$#88!47?C$#89!25?_-#3!43?G$#9!15?GC!4?A??@$#10!14?_ow{{woo}}}!16~^NF@$#14!13?C$#26!5?@BF^~~^F@$#30!12?O$#31!14?@$#33!8?_$#35!5?A$#39!4?@?G$#40!14?O!26?_$#41!21?C$#52!20?G$#53!20?@$#55!44?A$#59!23?@!18?O$#60!7?O$#63!12?GA$#64!11?_$#68!22?@!22?@$#70!19?C?@$#71!21?G$#72!6?CG-#7!16?O$#9!12?G!22?G$#10!13?EFNN^^^!10~^^^NNFFBB@$#13!10?A$#16!11?@$#25!10?@$#40!13?@$#41!19?_$#53!12?O!5?_!15?O?G$#54!30?_!6?C$#55!33?O$#58!40?@$#60!9?@$#66!39?A$#67!13?G$#68!31?_$#69!11?_C$#71!14?G$#88!11?O$#89!15?O-#50!26?@$#51!25?@$#88!23?@$#252!24?@-#0!50?\ +[?25h \ No newline at end of file diff --git a/src/Tcl9icon.svg b/src/Tcl9icon.svg new file mode 100644 index 00000000..fbddb7d3 --- /dev/null +++ b/src/Tcl9icon.svg @@ -0,0 +1,11 @@ + + + + Tcl9 Icon + + + + + + + diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 816f3331..247371ee 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -23,6 +23,7 @@ set bootsupport_modules [list\ src/vendormodules patterncmd\ src/vendormodules patternlib\ src/vendormodules patternpredator2\ + src/vendormodules promise\ src/vendormodules sha1\ src/vendormodules tomlish\ src/vendormodules test::tomlish\ diff --git a/src/bootsupport/modules/promise-1.2.0.tm b/src/bootsupport/modules/promise-1.2.0.tm new file mode 100644 index 00000000..a4b82e45 --- /dev/null +++ b/src/bootsupport/modules/promise-1.2.0.tm @@ -0,0 +1,1311 @@ +# Copyright (c) 2015-2023, Ashok P. Nadkarni +# All rights reserved. + +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: + +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. + +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. + +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +package require Tcl 8.6- + +namespace eval promise { + proc version {} { return 1.2.0 } +} + +proc promise::lambda {params body args} { + # Creates an anonymous procedure and returns a command prefix for it. + # params - parameter definitions for the procedure + # body - body of the procedures + # args - additional arguments to be passed to the procedure when it + # is invoked + # + # This is just a convenience command since anonymous procedures are + # commonly useful with promises. The lambda package from tcllib + # is identical in function. + + return [list ::apply [list $params $body] {*}$args] +} + +catch {promise::Promise destroy} +oo::class create promise::Promise { + + # The promise state can be one of + # PENDING - Initial state where it has not yet been assigned a + # value or error + # FULFILLED - The promise has been assigned a value + # REJECTED - The promise has been assigned an error + # CHAINED - The promise is attached to another promise + variable _state + + # Stores data that is accessed through the setdata/getdata methods. + # The Promise class itself does not use this. + variable _clientdata + + # The promise value once it is fulfilled or rejected. In the latter + # case, it should be an the error message + variable _value + + # The error dictionary in case promise is rejected + variable _edict + + # Reactions to be notified when the promise is rejected. Each element + # in this list is a pair consisting of the fulfilment reaction + # and the rejection reaction. Either element of the pair could be + # empty signifying no reaction for that case. The list is populated + # via the then method. + variable _reactions + + # Reference counting to free up promises since Tcl does not have + # garbage collection for objects. Garbage collection via reference + # counting only takes place after at least one done/then reaction + # is placed on the event queue, not before. Else promises that + # are immediately resolved on construction would be freed right + # away before the application even gets a chance to call done/then. + variable _do_gc + variable _nrefs + + # If no reject reactions are registered, then the Tcl bgerror + # handler is invoked. But don't want to do this more than once + # so track it + variable _bgerror_done + + constructor {cmd} { + # Create a promise for the asynchronous operation to be initiated + # by $cmd. + # cmd - a command prefix that should initiate an asynchronous + # operation. + # The command prefix $cmd is passed an additional argument - the + # name of this Promise object. It should arrange for one of the + # object's settle methods [fulfill], [chain] or + # [reject] to be called when the operation completes. + + set _state PENDING + set _reactions [list ] + set _do_gc 0 + set _bgerror_done 0 + set _nrefs 0 + array set _clientdata {} + + # Errors in the construction command are returned via + # the standard mechanism of reject. + # + if {[catch { + # For some special cases, $cmd may be "" if the async operation + # is initiated outside the constructor. This is not a good + # thing because the error in the initiator will not be + # trapped via the standard promise error catching mechanism + # but that's the application's problem (actually pgeturl also + # uses this). + if {[llength $cmd]} { + uplevel #0 [linsert $cmd end [self]] + } + } msg edict]} { + my reject $msg $edict + } + } + + destructor { + # Destroys the object. + # + # This method should not be generally called directly as [Promise] + # objects are garbage collected either automatically or via the [ref] + # and [unref] methods. + } + + method state {} { + # Returns the current state of the promise. + # + # The promise state may be one of the values `PENDING`, + # `FULFILLED`, `REJECTED` or `CHAINED` + return $_state + } + + method getdata {key} { + # Returns data previously stored through the setdata method. + # key - key whose associated values is to be returned. + # An error will be raised if no value is associated with the key. + return $_clientdata($key) + } + + method setdata {key value} { + # Sets a value to be associated with a key. + # key - the lookup key + # value - the value to be associated with the key + # A promise internally maintains a dictionary whose values can + # be accessed with the [getdata] and [setdata] methods. This + # dictionary is not used by the Promise class itself but is meant + # to be used by promise library specializations or applications. + # Callers need to take care that keys used for a particular + # promise are sufficiently distinguishable so as to not clash. + # + # Returns the value stored with the key. + set _clientdata($key) $value + } + + method value {} { + # Returns the settled value for the promise. + # + # The returned value may be the fulfilled value or the rejected + # value depending on whether the associated operation was successfully + # completed or failed. + # + # An error is raised if the promise is not settled yet. + if {$_state ni {FULFILLED REJECTED}} { + error "Value is not set." + } + return $_value + } + + method ref {} { + # Increments the reference count for the object. + incr _nrefs + } + + method unref {} { + # Decrements the reference count for the object. + # + # The object may have been destroyed when the call returns. + incr _nrefs -1 + my GC + } + + method nrefs {} { + # Returns the current reference count. + # + # Use for debugging only! Note, internal references are not included. + return $_nrefs + } + + method GC {} { + if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { + my destroy + } + } + + method FulfillAttached {value} { + if {$_state ne "CHAINED"} { + return + } + set _value $value + set _state FULFILLED + my ScheduleReactions + return + } + + method RejectAttached {reason edict} { + if {$_state ne "CHAINED"} { + return + } + set _value $reason + set _edict $edict + set _state REJECTED + my ScheduleReactions + return + } + + # Method to invoke to fulfil a promise with a value or another promise. + method fulfill {value} { + # Fulfills the promise. + # value - the value with which the promise is fulfilled + # + # Returns `0` if promise had already been settled and `1` if + # it was fulfilled by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `FULFILLED` state with + # the value specified by $value. If there are any fulfillment + # reactions registered by the [Promise.done] or [Promise.then] methods, they + # are scheduled to be run. + set _value $value + set _state FULFILLED + my ScheduleReactions + return 1 + } + + # Method to invoke to fulfil a promise with a value or another promise. + method chain {promise} { + # Chains the promise to another promise. + # promise - the [Promise] object to which this promise is to + # be chained + # + # Returns `0` if promise had already been settled and `1` otherwise. + + #ruff + # If the promise on which this method is called + # has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; + } + + #ruff + # Otherwise, it is chained to $promise so that it reflects that + # other promise's state. + if {[catch { + $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] + } msg edict]} { + my reject $msg $edict + } else { + set _state CHAINED + } + + return 1 + } + + method reject {reason {edict {}}} { + # Rejects the promise. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # + # The $reason and $edict values are passed on to the rejection + # reactions. By convention, these should be of the form returned + # by the `catch` or `try` commands in case of errors. + # + # Returns `0` if promise had already been settled and `1` if + # it was rejected by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `REJECTED` state. If + # there are any reject reactions registered by the [Promise.done] or + # [Promise.then] methods, they are scheduled to be run. + + set _value $reason + #ruff + # If $edict is not specified, or specified as an empty string, + # a suitable error dictionary is constructed in its place + # to be passed to the reaction. + if {$edict eq ""} { + catch {throw {PROMISE REJECTED} $reason} - edict + } + set _edict $edict + set _state REJECTED + my ScheduleReactions + return 1 + } + + # Internal method to queue all registered reactions based on + # whether the promise is succesfully fulfilled or not + method ScheduleReactions {} { + if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { + # Promise is not settled or no reactions registered + return + } + + # Note on garbage collection: garbage collection is to be enabled if + # at least one FULFILLED or REJECTED reaction is registered. + # Also if the promise is REJECTED but no rejection handlers are run + # we also schedule a background error. + # In all cases, CLEANUP reactions do not count. + foreach reaction $_reactions { + foreach type {FULFILLED REJECTED} { + if {[dict exists $reaction $type]} { + set _do_gc 1 + if {$type eq $_state} { + set cmd [dict get $reaction $type] + if {[llength $cmd]} { + if {$type eq "FULFILLED"} { + lappend cmd $_value + } else { + lappend cmd $_value $_edict + } + set ran_reaction($type) 1 + # Enqueue the reaction via the event loop + after 0 [list after idle $cmd] + } + } + } + } + if {[dict exists $reaction CLEANUP]} { + set cmd [dict get $reaction CLEANUP] + if {[llength $cmd]} { + # Enqueue the cleaner via the event loop passing the + # *state* as well as the value + if {$_state eq "REJECTED"} { + lappend cmd $_state $_value $_edict + } else { + lappend cmd $_state $_value + } + after 0 [list after idle $cmd] + # Note we do not set _do_gc if we only run cleaners + } + } + } + set _reactions [list ] + + # Check for need to background error (see comments above) + if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { + # TBD - should we also check _nrefs before backgrounding error? + + # Wrap in catch in case $_edict does not follow error conventions + # or is not even a dictionary + if {[catch { + dict get $_edict -level + dict get $_edict -code + }]} { + catch {throw {PROMISE REJECT} $_value} - edict + } else { + set edict $_edict + } + # TBD - how exactly is level to be handled? + # If -level is not 0, bgerror barfs because it treates + # it as TCL_RETURN no matter was -code is + dict set edict -level 0 + after idle [interp bgerror {}] [list $_value $edict] + set _bgerror_done 1 + } + + my GC + return + } + + method RegisterReactions {args} { + # Registers the specified reactions. + # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` + # with values being the corresponding reaction callback + + lappend _reactions $args + my ScheduleReactions + return + } + + method done {{on_fulfill {}} {on_reject {}}} { + # Registers reactions to be run when the promise is settled. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. + # Reactions are called with an additional argument which is + # the value with which the promise was settled. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # The method triggers garbage collection of the object if the + # promise has been settled and any registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Note that both $on_fulfill and $on_reject may be specified + # as empty strings if no further action needs to be taken on + # settlement of the promise. If the promise is rejected, and + # no rejection reactions are registered, the error is reported + # via the Tcl `interp bgerror` facility. + + # TBD - as per the Promise/A+ spec, errors in done should generate + # a background error (unlike then). + + my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject + + #ruff + # The method does not return a value. + return + } + + method then {on_fulfill {on_reject {}}} { + # Registers reactions to be run when the promise is settled + # and returns a new [Promise] object that will be settled by the + # reactions. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. If an empty string, no fulfill + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. If unspecified or an empty string, + # no reject reaction is registered. + # Both reactions are passed the value with which the promise was settled. + # The reject reaction is passed an additional argument which is + # the error dictionary. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # If the reaction that is invoked runs without error, its return + # value fulfills the new promise returned by the `then` method. + # If it raises an exception, the new promise will be rejected + # with the error message and dictionary from the exception. + # + # Alternatively, the reactions can explicitly invoke commands + # [then_fulfill], [then_reject] or [then_chain] to + # resolve the returned promise. In this case, the return value + # (including exceptions) from the reactions are ignored. + # + # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), + # the new promise is created and fulfilled (or rejected) with + # the same value that would have been passed in to the reactions. + # + # The method triggers garbage collection of the object if the + # promise has been settled and registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Returns a new promise that is settled by the registered reactions. + + set then_promise [[self class] new ""] + my RegisterReactions \ + FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ + REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] + return $then_promise + } + + # This could be a forward, but then we cannot document it via ruff! + method catch {on_reject} { + # Registers reactions to be run when the promise is rejected. + # on_reject - command prefix for the reaction + # reaction to run if the promise is rejected. If unspecified + # or an empty string, no reject reaction is registered. The + # reaction is called with an additional argument which is the + # value with which the promise was settled. + # This method is just a wrapper around [Promise.then] with the + # `on_fulfill` parameter defaulting to an empty string. See + # the description of that method for details. + return [my then "" $on_reject] + } + + method cleanup {cleaner} { + # Registers a reaction to be executed for running cleanup + # code when the promise is settled. + # cleaner - command prefix to run on settlement + # This method is intended to run a clean up script + # when a promise is settled. Its primary use is to avoid duplication + # of code in the `then` and `catch` handlers for a promise. + # It may also be called multiple times + # to clean up intermediate steps when promises are chained. + # + # The method returns a new promise that will be settled + # as per the following rules. + # - if the cleaner runs without errors, the returned promise + # will reflect the settlement of the promise on which this + # method is called. + # - if the cleaner raises an exception, the returned promise + # is rejected with a value consisting of the error message + # and dictionary pair. + # + # Returns a new promise that is settled based on the cleaner + set cleaner_promise [[self class] new ""] + my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] + return $cleaner_promise + } +} + +proc promise::_then_reaction {target_promise status cmd value {edict {}}} { + # Run the specified command and fulfill/reject the target promise + # accordingly. If the command is empty, the passed-in value is passed + # on to the target promise. + + # IMPORTANT!!!! + # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else + # promise::then_fulfill/then_reject/then_chain will not work + # Also, Do NOT change the param name target_promise without changing + # those procs. + # Oh what a hack to get around lack of closures. Alternative would have + # been to pass an additional parameter (target_promise) + # to the application code but then that script would have had to + # carry that around. + + if {[info level] != 1} { + error "Internal error: _then_reaction not at level 1" + } + + if {[llength $cmd] == 0} { + switch -exact -- $status { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict} + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid status $state" + } + } + } else { + # Invoke the real reaction code and fulfill/reject the target promise. + # Note the reaction code may have called one of the promise::then_* + # commands itself and reactions run resulting in the object being + # freed. Hence resolve using the safe* variants + # TBD - ideally we would like to execute at global level. However + # the then_* commands retrieve target_promise from level 1 (here) + # which they cannot if uplevel #0 is done. So directly invoke. + if {$status eq "REJECTED"} { + lappend cmd $value $edict + } else { + lappend cmd $value + } + if {[catch $cmd reaction_value reaction_edict]} { + safe_reject $target_promise $reaction_value $reaction_edict + } else { + safe_fulfill $target_promise $reaction_value + } + } + return +} + +proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { + # Run the specified cleaner and fulfill/reject the target promise + # accordingly. If the cleaner executes without error, the original + # value and state is passed on. If the cleaner executes with error + # the promise is rejected. + + if {[llength $cleaner] == 0} { + switch -exact -- $state { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict } + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid state $state" + } + } + } else { + if {[catch {uplevel #0 $cleaner} err edict]} { + # Cleaner failed. Reject the target promise + $target_promise reject $err $edict + } else { + # Cleaner completed without errors, pass on the original value + if {$state eq "FULFILLED"} { + $target_promise fulfill $value + } else { + $target_promise reject $value $edict + } + } + } + return +} + +proc promise::then_fulfill {value} { + # Fulfills the promise returned by a [Promise.then] method call from + # within its reaction. + # value - the value with which to fulfill the promise + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - `then_fulfill`, + # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + + # TBD - what if someone calls this from within a uplevel #0 ? The + # upvar will be all wrong + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_fulfill called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise fulfill $value +} + +proc promise::then_chain {promise} { + # Chains the promise returned by a [Promise.then] method call to + # another promise. + # promise - the promise to which the promise returned by [Promise.then] is + # to be chained + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_chain` chains + # the promise returned by the `then` method that queued the currently + # running reaction to $promise so that the former will be settled + # based on the latter. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_chain called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise chain $promise +} + +proc promise::then_reject {reason edict} { + # Rejects the promise returned by a [Promise.then] method call from + # within its reaction. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_reject` rejects + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_reject called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise reject $reason $edict +} + +proc promise::all {promises} { + # Returns a promise that fulfills or rejects when all promises + # in the $promises argument have fulfilled or any one has rejected. + # promises - a list of Promise objects + # If any of $promises rejects, then the promise returned by the + # command will reject with the same value. Otherwise, the promise + # will fulfill when all promises have fulfilled. + # The resolved value will be a list of the resolved + # values of the contained promises. + + set all_promise [Promise new [lambda {promises prom} { + set npromises [llength $promises] + if {$npromises == 0} { + $prom fulfill {} + return + } + + # Ask each promise to update us when resolved. + foreach promise $promises { + $promise done \ + [list ::promise::_all_helper $prom $promise FULFILLED] \ + [list ::promise::_all_helper $prom $promise REJECTED] + } + + # We keep track of state with a dictionary that will be + # stored in $prom with the following keys: + # PROMISES - the list of promises in the order passed + # PENDING_COUNT - count of unresolved promises + # RESULTS - dictionary keyed by promise and containing resolved value + set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] + + $prom setdata ALLPROMISES $all_state + } $promises]] + + return $all_promise +} + +proc promise::all* args { + # Returns a promise that fulfills or rejects when all promises + # in the $args argument have fulfilled or any one has rejected. + # args - list of Promise objects + # This command is identical to the all command except that it takes + # multiple arguments, each of which is a Promise object. See [all] + # for a description. + return [all $args] +} + +# Callback for promise::all. +# all_promise - the "master" promise returned by the all call. +# done_promise - the promise whose callback is being serviced. +# resolution - whether the current promise was resolved with "FULFILLED" +# or "REJECTED" +# value - the value of the currently fulfilled promise or error description +# in case rejected +# edict - error dictionary (if promise was rejected) +proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { + if {![info object isa object $all_promise]} { + # The object has been deleted. Naught to do + return + } + if {[$all_promise state] ne "PENDING"} { + # Already settled. This can happen when a tracked promise is + # rejected and another tracked promise gets settled afterwards. + return + } + if {$resolution eq "REJECTED"} { + # This promise failed. Immediately reject the master promise + # TBD - can we somehow indicate which promise failed ? + $all_promise reject $value $edict + return + } + + # Update the state of the resolved tracked promise + set all_state [$all_promise getdata ALLPROMISES] + dict set all_state RESULTS $done_promise $value + dict incr all_state PENDING_COUNT -1 + $all_promise setdata ALLPROMISES $all_state + + # If all promises resolved, resolve the all promise + if {[dict get $all_state PENDING_COUNT] == 0} { + set values {} + foreach prom [dict get $all_state PROMISES] { + lappend values [dict get $all_state RESULTS $prom] + } + $all_promise fulfill $values + } + return +} + +proc promise::race {promises} { + # Returns a promise that fulfills or rejects when any promise + # in the $promises argument is fulfilled or rejected. + # promises - a list of Promise objects + # The returned promise will fulfill and reject with the same value + # as the first promise in $promises that fulfills or rejects. + set race_promise [Promise new [lambda {promises prom} { + if {[llength $promises] == 0} { + catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict + $prom reject $reason $edict + return + } + # Use safe_*, do not directly call methods since $prom may be + # gc'ed once settled + foreach promise $promises { + $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] + } + } $promises]] + + return $race_promise +} + +proc promise::race* {args} { + # Returns a promise that fulfills or rejects when any promise + # in the passed arguments is fulfilled or rejected. + # args - list of Promise objects + # This command is identical to the `race` command except that it takes + # multiple arguments, each of which is a Promise object. See [race] + # for a description. + return [race $args] +} + +proc promise::await {prom} { + # Waits for a promise to be settled and returns its resolved value. + # prom - the promise that is to be waited on + # This command may only be used from within a procedure constructed + # with the [async] command or any code invoked from it. + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + set coro [info coroutine] + if {$coro eq ""} { + throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" + } + $prom done [list $coro success] [list $coro fail] + lassign [yieldto return -level 0] status val ropts + if {$status eq "success"} { + return $val + } else { + return -options $ropts $val + } +} + +proc promise::async {name paramdefs body} { + # Defines an procedure that will run a script asynchronously as a coroutine. + # name - name of the procedure + # paramdefs - the parameter definitions to the procedure in the same + # form as passed to the standard `proc` command + # body - the script to be executed + # + # When the defined procedure $name is called, it runs the supplied $body + # within a new coroutine. The return value from the $name procedure call + # will be a promise that will be fulfilled when the coroutine completes + # normally or rejected if it completes with an error. + # + # Note that the passed $body argument is not the body of the + # the procedure $name. Rather it is run as an anonymous procedure in + # the coroutine but in the same namespace context as $name. Thus the + # caller or the $body script must not make any assumptions about + # relative stack levels, use of `uplevel` etc. + # + # The primary purpose of this command is to make it easy, in + # conjunction with the [await] command, to wrap a sequence of asynchronous + # operations as a single computational unit. + # + # Returns a promise that will be settled with the result of the script. + if {![string equal -length 2 "$name" "::"]} { + set ns [uplevel 1 namespace current] + set name ${ns}::$name + } else { + set ns :: + } + set tmpl { + proc %NAME% {%PARAMDEFS%} { + set p [promise::Promise new [promise::lambda {real_args prom} { + coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { + upvar #1 _current_async_promise current_p + set current_p $p + set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] + if {$status == 0} { + $p fulfill $res + } else { + $p reject $res $ropts + } + } $prom {*}$real_args] + } [lrange [info level 0] 1 end]]] + return $p + } + } + eval [string map [list %NAME% $name \ + %PARAMDEFS% $paramdefs \ + %BODY% $body \ + %NS% $ns] $tmpl] +} + +proc promise::async_fulfill {val} { + # Fulfills a promise for an async procedure with the specified value. + # val - the value with which to fulfill the promise + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_fulfill called from outside an async context." + } + $current_p fulfill $val + return +} + +proc promise::async_reject {val {edict {}}} { + # Rejects a promise for an async procedure with the specified value. + # val - the value with which to reject the promise + # edict - error dictionary for rejection + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_reject called from outside an async context." + } + $current_p reject $val $edict + return +} + +proc promise::async_chain {prom} { + # Chains a promise for an async procedure to the specified promise. + # prom - the promise to which the async promise is to be linked. + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_chain called from outside an async context." + } + $current_p chain $prom + return +} + +proc promise::pfulfilled {value} { + # Returns a new promise that is already fulfilled with the specified value. + # value - the value with which to fulfill the created promise + return [Promise new [lambda {value prom} { + $prom fulfill $value + } $value]] +} + +proc promise::prejected {value {edict {}}} { + # Returns a new promise that is already rejected. + # value - the value with which to reject the promise + # edict - error dictionary for rejection + # By convention, $value should be of the format returned by + # [Promise.reject]. + return [Promise new [lambda {value edict prom} { + $prom reject $value $edict + } $value $edict]] +} + +proc promise::eventloop {prom} { + # Waits in the eventloop until the specified promise is settled. + # prom - the promise to be waited on + # The command enters the event loop in similar fashion to the + # Tcl `vwait` command except that instead of waiting on a variable + # the command waits for the specified promise to be settled. As such + # it has the same caveats as the vwait command in terms of care + # being taken in nested calls etc. + # + # The primary use of the command is at the top level of a script + # to wait for one or more promise based tasks to be completed. Again, + # similar to the vwait forever idiom. + # + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + + set varname [namespace current]::_pwait_[info cmdcount] + $prom done \ + [lambda {varname result} { + set $varname [list success $result] + } $varname] \ + [lambda {varname error ropts} { + set $varname [list fail $error $ropts] + } $varname] + vwait $varname + lassign [set $varname] status result ropts + if {$status eq "success"} { + return $result + } else { + return -options $ropts $result + } +} + +proc promise::pgeturl {url args} { + # Returns a promise that will be fulfilled when the URL is fetched. + # url - the URL to fetch + # args - arguments to pass to the `http::geturl` command + # This command invokes the asynchronous form of the `http::geturl` command + # of the `http` package. If the operation completes with a status of + # `ok`, the returned promise is fulfilled with the contents of the + # http state array (see the documentation of `http::geturl`). If the + # the status is anything else, the promise is rejected with + # the `reason` parameter to the reaction containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # with an additional key `http_state`, containing the + # contents of the http state array. + + uplevel #0 {package require http} + proc pgeturl {url args} { + set prom [Promise new [lambda {http_args prom} { + http::geturl {*}$http_args -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + if {$http_state(status) eq "ok"} { + $prom fulfill [array get http_state] + } else { + if {[info exists http_state(error)]} { + set msg [lindex $http_state(error) 0] + } + if {![info exists msg] || $msg eq ""} { + set msg "Error retrieving URL." + } + catch {throw {PROMISE PGETURL} $msg} msg edict + dict set edict http_state [array get http_state] + $prom reject $msg $edict + } + http::cleanup $tok + } $prom] + } [linsert $args 0 $url]]] + return $prom + } + tailcall pgeturl $url {*}$args +} + +proc promise::ptimer {millisecs {value "Timer expired."}} { + # Returns a promise that will be fulfilled when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be fulfilled + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to an error + # message and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimeout] which is similar but rejects the promise instead + # of fulfilling it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't allow "idle", "cancel" etc. as an argument to after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [list promise::safe_fulfill $prom $value] + } $millisecs $value]] +} + +proc promise::ptimeout {millisecs {value "Operation timed out."}} { + # Returns a promise that will be rejected when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be rejected + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to $value + # and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimer] which is similar but fulfills the promise instead + # of rejecting it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't want to accept "idle", "cancel" etc. for after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [::promise::lambda {prom msg} { + catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict + ::promise::safe_reject $prom $msg $edict + } $prom $value] + } $millisecs $value]] +} + +proc promise::pconnect {args} { + # Returns a promise that will be fulfilled when the socket connection + # is completed. + # args - arguments to be passed to the Tcl `socket` command + # This is a wrapper for the async version of the Tcl `socket` command. + # If the connection completes, the promise is fulfilled with the + # socket handle. + # In case of errors (e.g. if the address cannot be fulfilled), the + # promise is rejected with the `reason` parameter containing the + # error message and the `edict` parameter containing the Tcl error + # dictionary. + # + return [Promise new [lambda {so_args prom} { + set so [socket -async {*}$so_args] + fileevent $so writable [promise::lambda {prom so} { + fileevent $so writable {} + set err [chan configure $so -error] + if {$err eq ""} { + $prom fulfill $so + } else { + catch {throw {PROMISE PCONNECT FAIL} $err} err edict + $prom reject $err $edict + } + } $prom $so] + } $args]] +} + +proc promise::_read_channel {prom chan data} { + set newdata [read $chan] + if {[string length $newdata] || ![eof $chan]} { + append data $newdata + fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] + return + } + + # EOF + set code [catch { + # Need to make the channel blocking else no error is returned + # on the close + fileevent $chan readable {} + fconfigure $chan -blocking 1 + close $chan + } result edict] + if {$code} { + safe_reject $prom $result $edict + } else { + safe_fulfill $prom $data + } +} + +proc promise::pexec {args} { + # Runs an external program and returns a promise for its output. + # args - program and its arguments as passed to the Tcl `open` call + # for creating pipes + # If the program runs without errors, the promise is fulfilled by its + # standard output content. Otherwise + # promise is rejected. + # + # Returns a promise that will be settled by the result of the program + return [Promise new [lambda {open_args prom} { + set chan [open |$open_args r] + fconfigure $chan -blocking 0 + fileevent $chan readable [list promise::_read_channel $prom $chan ""] + } $args]] +} + +proc promise::safe_fulfill {prom value} { + # Fulfills the specified promise. + # prom - the [Promise] object to be fulfilled + # value - the fulfillment value + # This is a convenience command that checks if $prom still exists + # and if so fulfills it with $value. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [fulfill][Promise.fulfill] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return 0 + } + return [$prom fulfill $value] +} + +proc promise::safe_reject {prom value {edict {}}} { + # Rejects the specified promise. + # prom - the [Promise] object to be fulfilled + # value - see [Promise.reject] + # edict - see [Promise.reject] + # This is a convenience command that checks if $prom still exists + # and if so rejects it with the specified arguments. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [reject][Promise.reject] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return + } + $prom reject $value $edict +} + +proc promise::ptask {script} { + # Creates a new Tcl thread to run the specified script and returns + # a promise for the script results. + # script - script to run in the thread + # Returns a promise that will be settled by the result of the script + # + # The `ptask` command runs the specified script in a new Tcl + # thread. The promise returned from this command will be fulfilled + # with the result of the script if it completes + # successfully. Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + # + # The command requires the Thread package to be loaded. + + uplevel #0 package require Thread + proc [namespace current]::ptask script { + return [Promise new [lambda {script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + # ok or return + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + thread::create $thread_script + } $script]] + } + tailcall [namespace current]::ptask $script +} + +proc promise::pworker {tpool script} { + # Runs a script in a worker thread from a thread pool and + # returns a promise for the same. + # tpool - thread pool identifier + # script - script to run in the worker thread + # Returns a promise that will be settled by the result of the script + # + # The Thread package allows creation of a thread pool with the + # `tpool create` command. The `pworker` command runs the specified + # script in a worker thread from a thread pool. The promise + # returned from this command will be fulfilled with the result of + # the script if it completes successfully. + # Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + + # No need for package require Thread since if tpool is passed to + # us, Thread must already be loaded + return [Promise new [lambda {tpool script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + tpool::post -detached -nowait $tpool $thread_script + } $tpool $script]] +} + +if {0} { + package require http + proc checkurl {url} { + set prom [promise::Promise new [promise::lambda {url prom} { + http::geturl $url -method HEAD -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + $prom fulfill [list $http_state(url) $http_state(status)] + ::http::cleanup $tok + } $prom] + } $url]] + return $prom + } + + proc checkurls {urls} { + return [promise::all [lmap url $urls {checkurl $url}]] + } + + [promise::all [ + list [ + promise::ptask {expr 1+1} + ] [ + promise::ptask {expr 2+2} + ] + ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] +} + +package provide promise [promise::version] + +if {[info exists ::argv0] && + [file tail [info script]] eq [file tail $::argv0]} { + set filename [file tail [info script]] + if {[llength $::argv] == 0} { + puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" + exit 1 + } + switch -glob -- [lindex $::argv 0] { + ver* { puts [promise::version] } + tm - + dist* { + if {[file extension $filename] ne ".tm"} { + set dir [file join [file dirname [info script]] .. build] + file mkdir $dir + file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] + } else { + error "Cannot create distribution from a .tm file" + } + } + install { + # Install in first native file system that exists on search path + foreach path [tcl::tm::path list] { + if {[lindex [file system $path] 0] eq "native"} { + set dir $path + if {[file isdirectory $path]} { + break + } + # Else keep looking + } + } + if {![file exists $dir]} { + file mkdir $dir + } + if {[file extension $filename] eq ".tm"} { + # We already are a .tm with version number + set target $filename + } else { + set target [file rootname $filename]-[promise::version].tm + } + file copy -force [info script] [file join $dir $target] + } + default { + puts stderr "Unknown option/command \"[lindex $::argv 0]\"" + exit 1 + } + } +} diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index e940dada..74a3ffc8 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -4001,7 +4001,17 @@ tcl::namespace::eval punk::args { set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { - set chosen $v_test + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set set choice_in_list 1 } else { #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. @@ -4046,6 +4056,7 @@ tcl::namespace::eval punk::args { } } + #override the optimistic existing val if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 2e10e75b..a8884746 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -740,18 +740,27 @@ namespace eval punk::console { set was_raw 1 set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + puts -nonewline $output $query;flush $output chan configure $input -blocking 0 set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on set tsclock($callid) $tslaunch($callid) - #write before console enableRaw vs after?? - #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it - puts -nonewline $output $query;flush $output + #after 0 + #------------------ + #trying alternatives to get faster read and maintain reliability..REVIEW + #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features + #------------------ + # 1) faster - races? + $this_handler $input $callid $capturingendregex $this_handler $input $callid $capturingendregex - if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } + # 2) more reliable? + #chan event $input readable [list $this_handler $input $callid $capturingendregex] + #------------------ #response from terminal @@ -794,7 +803,7 @@ namespace eval punk::console { if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { - puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" + puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" } if {$was_raw == 0} { @@ -956,9 +965,10 @@ namespace eval punk::console { set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] #review - what is min length of any ansiresponse? + #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z #endregex is capturing - but as we are only testing the match here #it should perform the same as if it were non-capturing - if {[string length $sofar] > 3 && [regexp $endregex $sofar]} { + if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" chan event $chan readable {} set waits($callid) ok @@ -1438,7 +1448,8 @@ namespace eval punk::console { -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 newsize -default "" -help\ - "character cell pixel dimensions WxH" + "character cell pixel dimensions WxH + or omit to query cell size." } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] @@ -1474,6 +1485,31 @@ namespace eval punk::console { } set cell_size ${w}x${h} } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #puts -->$payload<-- + return [expr {$payload in {Z K M}}] + } #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { @@ -1587,7 +1623,6 @@ namespace eval punk::console { } - proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?7\$p" @@ -1683,7 +1718,14 @@ namespace eval punk::console { return } - puts -nonewline stdout $char_or_string + #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error + #e.g contains surrogate pair + if {[catch { + puts -nonewline stdout $char_or_string + } errM]} { + puts stderr "test_char_width couldn't emit this string - \nerror: $errM" + } + set response [punk::console::get_cursor_pos] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { diff --git a/src/defaultconfigs/Adventure.toml b/src/defaultconfigs/Adventure.toml new file mode 100644 index 00000000..e29e4229 --- /dev/null +++ b/src/defaultconfigs/Adventure.toml @@ -0,0 +1,12 @@ +# Adventure +[colors] +foreground = "#feffff" +background = "#040404" +cursor_bg = "#feffff" +cursor_border = "#feffff" +cursor_fg = "#000000" +selection_bg = "#606060" +selection_fg = "#ffffff" + +ansi = ["#040404","#d84a33","#5da602","#eebb6e","#417ab3","#e5c499","#bdcfe5","#dbded8"] +brights = ["#685656","#d76b42","#99b52c","#ffb670","#97d7ef","#aa7900","#bdcfe5","#e4d5c7"] diff --git a/src/lib/app-shellspy/shellspy.tcl b/src/lib/app-shellspy/shellspy.tcl index 57296992..95f057bb 100644 --- a/src/lib/app-shellspy/shellspy.tcl +++ b/src/lib/app-shellspy/shellspy.tcl @@ -233,77 +233,77 @@ namespace eval shellspy { proc get_channel_config {config} { #note tcl script being called from wrong place.. configs don't affect: todo - move it. set params [dict create] - if {$config == 0} { - #bad for: everything. extra cr - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation auto - } - - if {$config == 1} { - #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process - #not ok for: bash,wsl, tcl script - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf - } - if {$config == 2} { - #ok for: cmd, cmd/uc,pwsh,sh , tcl script process - #not ok for: tcl script, bash, wsl - dict set params -inbuffering none ;#default - dict set params -outbuffering none ;#default - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf ;#default - } - if {$config == 3} { - #ok for: cmd - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - if {$config == 4} { - #ok for: cmd,cmd/uc,raw,sh - #not ok for pwsh,bash,wsl, tcl script, tcl script process - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - - if {$config == 5} { - #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process - #not ok for bash,wsl - #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - if {$config == 6} { - #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash - #not ok for: vim with cmd /u/c (?) - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - if {$config == 7} { - #ok for: sh,bash - #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation crlf - } - if {$config == 8} { - #not ok for anything..all have extra cr - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation crlf + switch -- $config { + 0 { + #bad for: everything. extra cr + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation auto + } + 1 { + #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process + #not ok for: bash,wsl, tcl script + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf + } + 2 { + #ok for: cmd, cmd/uc,pwsh,sh , tcl script process + #not ok for: tcl script, bash, wsl + dict set params -inbuffering none ;#default + dict set params -outbuffering none ;#default + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf ;#default + } + 3 { + #ok for: cmd + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 4 { + #ok for: cmd,cmd/uc,raw,sh + #not ok for pwsh,bash,wsl, tcl script, tcl script process + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 5 { + #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process + #not ok for bash,wsl + #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 6 { + #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash + #not ok for: vim with cmd /u/c (?) + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 7 { + #ok for: sh,bash + #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation crlf + } + 8 { + #not ok for anything..all have extra cr + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation crlf + } } return $params } @@ -653,10 +653,27 @@ namespace eval shellspy { set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { ::tcl::tm::add %m% set scriptname %s% -set ::argv [list %a%] -set ::argc [llength $::argv] -source [file normalize $scriptname] - +set normscript [file normalize $scriptname] + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] +set ::argv0 $normscript +info script $normscript +source $normscript + +#restore values +info script $prevscript +dict with prevglobal {} }] set repl_lines "" diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index aae5119a..81ff5dec 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -4001,7 +4001,17 @@ tcl::namespace::eval punk::args { set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { - set chosen $v_test + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set set choice_in_list 1 } else { #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. @@ -4046,6 +4056,7 @@ tcl::namespace::eval punk::args { } } + #override the optimistic existing val if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { diff --git a/src/modules/punk/cesu-999999.0a1.0.tm b/src/modules/punk/cesu-999999.0a1.0.tm index 7857b480..e17acd66 100644 --- a/src/modules/punk/cesu-999999.0a1.0.tm +++ b/src/modules/punk/cesu-999999.0a1.0.tm @@ -70,7 +70,7 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cesu { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - #variable xyz + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::cesu}] @@ -96,6 +96,8 @@ tcl::namespace::eval punk::cesu { } proc mapReply string { + package rquire http + http::config variable ::http::formMap set string [encoding convertto utf-8 $string] @@ -104,19 +106,21 @@ tcl::namespace::eval punk::cesu { } - + #where did original come from? wiki? proc cesu2utf str { #hacked by JMN - as original seemed broken and intention as to input is unclear if {[regexp {\xED([\xA0-\xAF])([\x80-\xBF])\xED([\xB0-\xBF])([\x80-\xBF])} $str]} { #set str [string map {\ \\ \[ \\\[ \] \\\]} $str] ;#original -broken - unsure of usecase/intention set str [string map {\\ \\\\ \[ \\\[ \] \\\]} $str] ;#guess intention is to stop premature substitution of escapes and commands #return [subst -novariables [regsub -all {^\xED([\xA0-\xAF])([\x80-\xBF])\xED([\xB0-\xBF])([\x80-\xBF])$} $str {[cesu2utfR \1 \2 \3 \4]} ]] ;#original. anchoring seems unlikely to be desirable + #capture the relevant 4 of the 6 bytes return [subst -novariables [regsub -all {\xED([\xA0-\xAF])([\x80-\xBF])\xED([\xB0-\xBF])([\x80-\xBF])} $str {[cesu2utfR \1 \2 \3 \4]} ]] } else { return $str } } + #4 captured bytes (excludes the 2 \xED leaders) proc cesu2utfR {1 2 3 4} { # UTF-8: 11110xxx 10xx xxxx 10xx xxxx 10xxxxxx # CESU-8: 11101101 1010 yy yy 10xxxx xx 11101101 1011xxxx 10xxxxxx @@ -125,7 +129,7 @@ tcl::namespace::eval punk::cesu { binary scan $3 c 3 puts [list $1 $2 $3] #binary scan $4 c 4 - incr 1 + incr 1 ;#// Effectively adds 0x10000 to the codepoint ? return [binary format ccca \ [expr {0xF0 | (($1 & 0xC) >> 2)}] \ @@ -171,17 +175,106 @@ tcl::namespace::eval punk::cesu { encoding convertfrom utf-8 $x } - #e.g test2 "note \ud83f\udd1e etc" - #e.g test2 "faces \ud83d\ude10 \ud83d\ude21 \ud83d\ude31" - #note: test2 \U1f600 returns a mouse (\U1f400) instead of smiley - # but test2 \U1f400 returns a mouse. - # Either surrogated_string shouldn't include non BMP chars anyway (G.I.G.O?).. or we're doing something wrong. - proc test2 {surrogated_string} { - #JMN + #e.g from_surrogatestring "note \ud83f\udd1e etc" + #e.g from_surrogatestring "faces \ud83d\ude10 \ud83d\ude21 \ud83d\ude31" + #note: from_surrogatestring \U1f600 returns a mouse (\U1f400) instead of smiley + # but from_surrogatestring \U1f400 returns a mouse. + # Tcl bug - fixed some time in 9.x + # surrogated_string shouldn't include non BMP chars anyway (G.I.G.O?) + lappend PUNKARGS [list { + @id -id ::punk::cesu::from_surrogatestring + @cmd -name punk::cesu::from_surrogatestring -help\ + "Convert a string containing surrogate pairs + to string with pairs converted to unicode non-BMP + characters" + @values + surrogated_string -help\ + "May contain a mix of surrogate pairs and other + characters - only the surrogate pairs will be converted." + }] + proc from_surrogatestring {surrogated_string} { set cesu [encoding convertto cesu-8 $surrogated_string] set x [cesu2utf $cesu] encoding convertfrom utf-8 $x } + proc _to_test {emoji} { + puts stderr "_to_test incomplete" + set cesu [encoding convertto cesu-8 $e] + puts stderr "cesu-8: $cesu" + + } + lappend PUNKARGS [list { + @id -id ::punk::cesu::to_surrogatestring + @opts + -format -default escape -choices {raw escape} -choicelabels { + raw\ + " emit raw surrogate pairs + may not be writable to + output channels" + escape\ + " emit unprocessed backslash hex + escape sequences for surrogate + pairs created for non-BMP chars. + (Does not convert existing surrogates + in the input into escape sequences!)" + } + @values -min 1 -max 1 + string -help\ + "String possibly containing non-BMP codepoints to be converted + e.g + >to_surrogatestring -format escape \"mouse: \\U1f400\" + mouse: \\uD83D\\uDC00 + " + }] + proc to_surrogatestring {args} { + set argd [punk::args::parse $args withid ::punk::cesu::to_surrogatestring] + lassign [dict values $argd] leaders opts values received + set opt_format [dict get $opts -format] + set string [dict get $values string] + set out "" + foreach c [split $string ""] { + set dec [scan $c %c] + if {$dec < 65536} { + append out $c + #if {$opt_format eq "escape"} { + #todo - detect existing surrogates in input? + #} + } else { + set pairinfo [nonbmp_surrogate_info $c] + if {$opt_format eq "raw"} { + append out [dict get $pairinfo raw] + } else { + append out [dict get $pairinfo escapes] + } + } + } + return $out + } + + proc nonbmp_surrogate_info {char} { + #set cinfo [punk::char::char_info $char] + #set dec [dict get $cinfo dec] + lassign [scan $char %c%s] dec remainder + if {$remainder ne "" || $dec < 65536} { + error "nonbmp_surrogate_info takes a single non-BMP char (codepoint in the range U+10000 to U+10FFFF)" + } + #U - 0x10000 + set less [expr {$dec - 0x10000}] + set lsb10 [expr {$less & 0b11111_11111}] ;#Least significant 10 bits of 20 + set msb10 [expr {($less & 0b11111_11111_00000_00000) >> 10}] ;#most significant 10 bits of 20 + + #apply 'base' values + set msbfinal [expr {$msb10 + 0xd800}] + set lsbfinal [expr {$lsb10 + 0xdc00}] + + set msbhex [format %4.4llX $msbfinal] + #set msbinfo [punk::char::char_info_dec $msbfinal -fields all -except testwidth] ;#don't use all/testwidth will try to emit the char and fail/show error + set lsbhex [format %4.4llX $lsbfinal] + #set lsbinfo [punk::char::char_info_dec $lsbfinal -fields all -except testwidth] ;#don't use all/testwidth will try to emit the char and fail/show error + set esc "\\u$msbhex\\u$lsbhex" + set raw [format %c $msbfinal][format %c $lsbfinal] + return [dict create escapes $esc msbdec $msbfinal msbhex $msbhex lsbdec $lsbfinal lsbhex $lsbhex raw $raw] + } # #test_enc_equivalency \U1f400 \U1f600 @@ -191,7 +284,7 @@ tcl::namespace::eval punk::cesu { foreach enc [lsort [encoding names]] { puts stdout "testing $enc" if {$enc in "iso2022 iso2022-jp iso2022-kr"} { - puts stderr "skipping $enc - crashes tcl9 on non BMP codepoints" + puts stderr "skipping $enc - crashes (early versions?) tcl9 on non BMP codepoints" continue } if {[catch { @@ -253,6 +346,106 @@ tcl::namespace::eval punk::cesu::lib { #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::cesu { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::cesu" + @package -name "punk::cesu" -help\ + "experimental cesu conversions + surrogate pair processing" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::cesu + } + 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::cesu + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::cesu::version" + } + proc get_topic_Contributors {} { + set authors {"Julian Noble "} + 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_custom-topic {} { + punk::args::lib::tstr -return string { + nothing to see here + } + } + # ------------------------------------------------------------- + } + + # 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::cesu::about" + dict set overrides @cmd -name "punk::cesu::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::cesu + }] \n] + dict set overrides topic -choices [list {*}[punk::cesu::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::cesu::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::cesu::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::cesu::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::cesu +} +# ----------------------------------------------------------------------------- ## Ready package provide punk::cesu [tcl::namespace::eval punk::cesu { variable pkg punk::cesu diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 745d2ea4..6fc60a2c 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -740,18 +740,27 @@ namespace eval punk::console { set was_raw 1 set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + puts -nonewline $output $query;flush $output chan configure $input -blocking 0 set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on set tsclock($callid) $tslaunch($callid) - #write before console enableRaw vs after?? - #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it - puts -nonewline $output $query;flush $output + #after 0 + #------------------ + #trying alternatives to get faster read and maintain reliability..REVIEW + #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features + #------------------ + # 1) faster - races? + $this_handler $input $callid $capturingendregex $this_handler $input $callid $capturingendregex - if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } + # 2) more reliable? + #chan event $input readable [list $this_handler $input $callid $capturingendregex] + #------------------ #response from terminal @@ -794,7 +803,7 @@ namespace eval punk::console { if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { - puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" + puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" } if {$was_raw == 0} { @@ -956,9 +965,10 @@ namespace eval punk::console { set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] #review - what is min length of any ansiresponse? + #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z #endregex is capturing - but as we are only testing the match here #it should perform the same as if it were non-capturing - if {[string length $sofar] > 3 && [regexp $endregex $sofar]} { + if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" chan event $chan readable {} set waits($callid) ok @@ -1438,7 +1448,8 @@ namespace eval punk::console { -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 newsize -default "" -help\ - "character cell pixel dimensions WxH" + "character cell pixel dimensions WxH + or omit to query cell size." } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] @@ -1474,6 +1485,31 @@ namespace eval punk::console { } set cell_size ${w}x${h} } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #puts -->$payload<-- + return [expr {$payload in {Z K M}}] + } #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { @@ -1587,7 +1623,6 @@ namespace eval punk::console { } - proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?7\$p" @@ -1683,7 +1718,14 @@ namespace eval punk::console { return } - puts -nonewline stdout $char_or_string + #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error + #e.g contains surrogate pair + if {[catch { + puts -nonewline stdout $char_or_string + } errM]} { + puts stderr "test_char_width couldn't emit this string - \nerror: $errM" + } + set response [punk::console::get_cursor_pos] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { diff --git a/src/modules/punk/icomm-999999.0a1.0.tm b/src/modules/punk/icomm-999999.0a1.0.tm new file mode 100644 index 00000000..c88e173c --- /dev/null +++ b/src/modules/punk/icomm-999999.0a1.0.tm @@ -0,0 +1,2168 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::icomm 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::icomm 0 999999.0a1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::icomm] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::icomm +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::icomm +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::icomm::class { + #*** !doctools + #[subsection {Namespace punk::icomm::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# comm.tcl -- +# +# socket-based 'send'ing of commands between interpreters. +# +# %%_OSF_FREE_COPYRIGHT_%% +# Copyright (C) 1995-1998 The Open Group. All Rights Reserved. +# (Please see the file "comm.LICENSE" that accompanied this source, +# or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html) +# Copyright (c) 2003-2007 ActiveState Corporation +# +# This is the 'comm' package written by Jon Robert LoVerso, placed +# into its own namespace during integration into tcllib. +# +# Note that the actual code was changed in several places (Reordered, +# eval speedup) +# +# comm works just like Tk's send, except that it uses sockets. +# These commands work just like "send" and "winfo interps": +# +# comm send ?-async? ? ...? +# comm interps +# +# See the manual page comm.n for further details on this package. + +package require Tcl 8.6- +package require snit ; # comm::future objects. + +namespace eval ::punk::icomm { + namespace export comm comm_send + + variable comm + array set comm {} + + if {![info exists comm(chans)]} { + array set comm { + debug 0 chans {} localhost 127.0.0.1 + connecting,hook 1 + connected,hook 1 + incoming,hook 1 + eval,hook 1 + callback,hook 1 + reply,hook 1 + lost,hook 1 + offerVers {3 2 } + acceptVers {3 2 } + defVers 2 + defaultEncoding "utf-8" + defaultSilent 0 + } + + set comm(lastport) [expr {[pid] % 32768 + 9999}] + # fast check for acceptable versions + foreach comm(_x) $comm(acceptVers) { + set comm($comm(_x),vers) 1 + } + catch {unset comm(_x)} + } + + # Class variables: + # lastport saves last default listening port allocated + # debug enable debug output + # chans list of allocated channels + # future,fid,$fid List of futures a specific peer is waiting for. + # + # Channel instance variables: + # comm() + # $ch,port listening port (our id) + # $ch,socket listening socket + # $ch,socketcmd command to use to create sockets. + # $ch,silent boolean to indicate whether to throw error on + # protocol negotiation failure + # $ch,local boolean to indicate if port is local + # $ch,interp interpreter to run received scripts in. + # If not empty we own it! = We destroy it + # with the channel + # $ch,events List of hoks to run in the 'interp', if defined + # $ch,serial next serial number for commands + # + # $ch,hook,$hook script for hook $hook + # + # $ch,peers,$id open connections to peers; ch,id=>fid + # $ch,fids,$fid reverse mapping for peers; ch,fid=>id + # $ch,vers,$id negotiated protocol version for id + # $ch,pending,$id list of outstanding send serial numbers for id + # + # $ch,buf,$fid buffer to collect incoming data + # $ch,result,$serial result value set here to wake up sender + # $ch,return,$serial return codes to go along with result + + if {0} { + # Propagate result, code, and errorCode. Can't just eval + # otherwise TCL_BREAK gets turned into TCL_ERROR. + global errorInfo errorCode + set code [catch [concat commSend $args] res] + return -code $code -errorinfo $errorInfo -errorcode $errorCode $res + } +} + +namespace eval ::punk::icomm { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::icomm}] + #[para] Core API functions for punk::icomm + #[list_begin definitions] + + variable PUNKARGS + + # ::punk::icomm::comm_send -- + # + # Convenience command. Replaces Tk 'send' and 'winfo' with + # versions using the 'comm' variants. Multiple calls are + # allowed, only the first one will have an effect. + # + # Arguments: + # None. + # + # Results: + # None. + + proc comm_send {} { + proc send {args} { + # Use pure lists to speed this up. + uplevel 1 [linsert $args 0 ::punk::icomm::comm send] + } + rename winfo tk_winfo + proc winfo {cmd args} { + if {![string match in* $cmd]} { + # Use pure lists to speed this up ... + return [uplevel 1 [linsert $args 0 tk_winfo $cmd]] + } + return [::punk::icomm::comm interps] + } + proc ::punk::icomm::comm_send {} {} + } + + + + + #(Ensemble equivalent) + + # ::punk::icomm::comm -- + # + # See documentation for public methods of "comm". + # This procedure is followed by the definition of + # the public methods themselves. + # + # Arguments: + # cmd Invoked method + # args Arguments to method. + # + # Results: + # As of the invoked method. + + proc comm {cmd args} { + set method [info commands ::punk::icomm::comm_cmd_$cmd*] + + if {[llength $method] == 1} { + set chan ::punk::icomm::comm; # passed to methods + return [uplevel 1 [linsert $args 0 $method $chan]] + } else { + foreach c [info commands ::punk::icomm::comm_cmd_*] { + # remove ::comm::comm_cmd_ + #lappend cmds [string range $c 17 end] + lappend cmds [string range $c 24 end] + } + return -code error "unknown subcommand \"$cmd\":\ + must be one of [join [lsort $cmds] {, }]" + } + } + + + #ensemble members + proc comm_cmd_connect {chan args} { + uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan] + } + proc comm_cmd_self {chan args} { + variable comm + return $comm($chan,port) + } + proc comm_cmd_channels {chan args} { + variable comm + return $comm(chans) + } + proc comm_cmd_configure {chan args} { + uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0] + } + proc comm_cmd_ids {chan args} { + variable comm + set res $comm($chan,port) + foreach {i id} [array get comm $chan,fids,*] { + lappend res $id + } + return $res + } + proc comm_cmd_remoteid {chan args} { + variable comm + if {[info exists comm($chan,remoteid)]} { + set comm($chan,remoteid) + } else { + return -code error "No remote commands processed yet" + } + } + proc comm_cmd_debug {chan bool} { + variable comm + return [set comm(debug) [string is true -strict $bool]] + } + + + # ### ### ### ######### ######### ######### + ## API: Setup async result generation for a remotely invoked command. + + # (future,fid,) -> list (future) + # (current,async) -> bool (default 0) + # (current,state) -> list (chan fid cmd ser) + + proc comm_cmd_return_async {chan} { + variable comm + + if {![info exists comm(current,async)]} { + return -code error "No remote commands processed yet" + } + if {$comm(current,async)} { + # Return the same future which were generated by the first + # call. + return $comm(current,state) + } + + #foreach {cmdchan cmdfid cmd ser} $comm(current,state) break + lassign $comm(current,state) cmdchan cmdfid cmd ser + + # Assert that the channel performing the request and the channel + # the current command came in are identical. Panic if not. + + if {![string equal $chan $cmdchan]} { + return -code error "Internal error: Trying to activate\ + async return for a command on a different channel" + } + + # Establish the future for the command and return a handle for + # it. Remember the outstanding futures for a peer, so that we can + # cancel them if the peer is lost before the promise implicit in + # the future is redeemed. + + set future [::punk::icomm::future %AUTO% $chan $cmdfid $cmd $ser] + + lappend comm(future,fid,$cmdfid) $future + set comm(current,state) $future + + # Mark the current command as using async result return. We do + # this last to ensure that all errors in this method are reported + # through the regular channels. + + set comm(current,async) 1 + + return $future + } + # hook -- + # + # Internal command. Implements 'comm hook'. + # + # Arguments: + # hook hook to modify + # script Script to add/remove to/from the hook + # + # Results: + # None. + # + proc comm_cmd_hook {chan hook {script +}} { + variable comm + if {![info exists comm($hook,hook)]} { + return -code error "Unknown hook invoked" + } + if {!$comm($hook,hook)} { + return -code error "Unimplemented hook invoked" + } + if {[string equal + $script]} { + if {[catch {set comm($chan,hook,$hook)} ret]} { + return + } + return $ret + } + if {[string match +* $script]} { + append comm($chan,hook,$hook) \n [string range $script 1 end] + } else { + set comm($chan,hook,$hook) $script + } + return + } + + # abort -- + # + # Close down all peer connections. + # Implements the 'comm abort' method. + # + # Arguments: + # None. + # + # Results: + # None. + + proc comm_cmd_abort {chan} { + variable comm + + foreach pid [array names comm $chan,peers,*] { + commLostConn $chan $comm($pid) "Connection aborted by request" + } + } + + # destroy -- + # + # Destroy the channel invoking it. + # Implements the 'comm destroy' method. + # + # Arguments: + # None. + # + # Results: + # None. + # + proc comm_cmd_destroy {chan} { + variable comm + catch {close $comm($chan,socket)} + comm_cmd_abort $chan + if {$comm($chan,interp) != {}} { + interp delete $comm($chan,interp) + } + array unset comm $chan,* + + #catch {unset comm($chan,port)} + #catch {unset comm($chan,local)} + #catch {unset comm($chan,silent)} + #catch {unset comm($chan,interp)} + #catch {unset comm($chan,events)} + #catch {unset comm($chan,socket)} + #catch {unset comm($chan,socketcmd)} + #catch {unset comm($chan,remoteid)} + #unset comm($chan,serial) + #unset comm($chan,chan) + #unset comm($chan,encoding) + #unset comm($chan,listen) + ## array unset would have been nicer, but is not available in + ## 8.2/8.3 + #foreach pattern {hook,* interp,* vers,*} { + # array unset comm $chan,$pattern + # #foreach k [array names comm $chan,$pattern] { + # # unset comm($k) + # #} + #} + set pos [lsearch -exact $comm(chans) $chan] + set comm(chans) [lreplace $comm(chans) $pos $pos] + if { + ![string equal ::punk::icomm::comm $chan] && + ![string equal [info proc $chan] ""] + } { + rename $chan {} + } + return + } + + # shutdown -- + # + # Close down a peer connection. + # Implements the 'comm shutdown' method. + # + # Arguments: + # id Reference to the remote interp + # + # Results: + # None. + # + proc comm_cmd_shutdown {chan id} { + variable comm + + if {[info exists comm($chan,peers,$id)]} { + commLostConn $chan $comm($chan,peers,$id) \ + "Connection shutdown by request" + } + } + + # new -- + # + # Create a new comm channel/instance. + # Implements the 'comm new' method. + # + # Arguments: + # newchan Name of the new channel + # args Configuration, in the form of -option value pairs. + # + # Results: + # None. + # + proc comm_cmd_new {_irrelevant_chan newchan args} { + variable comm + + if {[lsearch -exact $comm(chans) $newchan] >= 0} { + return -code error "Already existing channel: $newchan" + } + if {([llength $args] % 2) != 0} { + return -code error "Must have an even number of config arguments" + } + # ensure that the new channel name is fully qualified + set newchan ::[string trimleft $newchan :] + if {[string equal ::punk::icomm::comm $newchan]} { + # allow comm to be recreated after destroy + } elseif {[string equal $newchan [info commands $newchan]]} { + return -code error "Already existing command: $newchan" + } else { + # Create the new channel with fully qualified proc name + proc $newchan {cmd args} { + set method [info commands ::punk::icomm::comm_cmd_$cmd*] + + if {[llength $method] == 1} { + # this should work right even if aliased + # it is passed to methods to identify itself + set chan [namespace origin [lindex [info level 0] 0]] + return [uplevel 1 [linsert $args 0 $method $chan]] + } else { + foreach c [info commands ::punk::icomm::comm_cmd_*] { + # remove ::comm::comm_cmd_ + #lappend cmds [string range $c 17 end] + lappend cmds [string range $c 24 end] + } + return -code error "unknown subcommand \"$cmd\":\ + must be one of [join [lsort $cmds] {, }]" + } + } + } + lappend comm(chans) $newchan + set chan $newchan + set comm($chan,serial) 0 + set comm($chan,chan) $chan + set comm($chan,tclchan) "" + set comm($chan,port) 0 + set comm($chan,listen) 0 + set comm($chan,socket) "" + set comm($chan,local) 1 + set comm($chan,silent) $comm(defaultSilent) + set comm($chan,encoding) $comm(defaultEncoding) + set comm($chan,interp) {} + set comm($chan,events) {} + set comm($chan,socketcmd) ::socket + + if {[llength $args] > 0} { + if {[catch [linsert $args 0 commConfigure $chan 1] err]} { + comm_cmd_destroy $chan + return -code error $err + } + } + return $chan + } + + # send -- + # + # Send command to a specified channel. + # Implements the 'comm send' method. + # + # Arguments: + # args see inside + # + # Results: + # varies. + # + proc comm_cmd_send {chan args} { + variable comm + + set cmd send + + # args = ?-async | -command command? id cmd ?arg arg ...? + set i 0 + set opt [lindex $args $i] + if {[string equal -async $opt]} { + set cmd async + incr i + } elseif {[string equal -command $opt]} { + set cmd command + set callback [lindex $args [incr i]] + incr i + } + # args = id cmd ?arg arg ...? + + set id [lindex $args $i] + incr i + set args [lrange $args $i end] + + if {![info complete $args]} { + return -code error "Incomplete command" + } + if {![llength $args]} { + return -code error \ + "wrong # args: should be \"send ?-async? id arg ?arg ...?\"" + } + if {[catch {commConnect $chan $id} fid]} { + return -code error "Connect to remote failed: $fid" + } + + set ser [incr comm($chan,serial)] + # This is unneeded - wraps from 2147483647 to -2147483648 + ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0} + + commDebug {puts stderr "<$chan> send <[list [list $cmd $ser $args]]>"} + + # The double list assures that the command is a single list when read. + puts $fid [list [list $cmd $ser $args]] + flush $fid + + commDebug {puts stderr "<$chan> sent"} + + # wait for reply if so requested + + if {[string equal command $cmd]} { + # In this case, don't wait on the command result. Set the callback + # in the return and that will be invoked by the result. + lappend comm($chan,pending,$id) [list $ser callback] + set comm($chan,return,$ser) $callback + return $ser + } elseif {[string equal send $cmd]} { + upvar 0 comm($chan,pending,$id) pending ;# shorter variable name + + lappend pending $ser + set comm($chan,return,$ser) "" ;# we're waiting + + commDebug {puts stderr "<$chan> --<>--"} + vwait ::punk::icomm::comm($chan,result,$ser) + + # if connection was lost, pending is gone + if {[info exists pending]} { + set pos [lsearch -exact $pending $ser] + set pending [lreplace $pending $pos $pos] + } + + commDebug { + puts stderr "<$chan> result\ + <$comm($chan,return,$ser);$comm($chan,result,$ser)>" + } + + array set return $comm($chan,return,$ser) + unset comm($chan,return,$ser) + set thisres $comm($chan,result,$ser) + unset comm($chan,result,$ser) + switch -- $return(-code) { + "" - 0 {return $thisres} + 1 { + return -code $return(-code) \ + -errorinfo $return(-errorinfo) \ + -errorcode $return(-errorcode) \ + $thisres + } + default {return -code $return(-code) $thisres} + } + } + } + + ############################################################################### + + # ::punk::icomm::commDebug -- + # + # Internal command. Conditionally executes debugging + # statements. Currently this are only puts commands logging the + # various interactions. These could be replaced with calls into + # the 'log' module. + # + # Arguments: + # arg Tcl script to execute. + # + # Results: + # None. + + proc commDebug {cmd} { + variable comm + if {$comm(debug)} { + uplevel 1 $cmd + } + } + + # ::punk::icomm::commConfVars -- + # + # Internal command. Used to declare configuration options. + # + # Arguments: + # v Name of configuration option. + # t Default value. + # + # Results: + # None. + + proc commConfVars {v t} { + variable comm + set comm($v,var) $t + set comm(vars) {} + foreach c [array names comm *,var] { + lappend comm(vars) [lindex [split $c ,] 0] + } + return + } + commConfVars port p + commConfVars local b + commConfVars listen b + commConfVars socket ro + commConfVars socketcmd socketcmd + commConfVars chan ro + commConfVars serial ro + commConfVars encoding enc + commConfVars silent b + commConfVars interp interp + commConfVars events ev + commConfVars tclchan tclchan + + # ::punk::icomm::commConfigure -- + # + # Internal command. Implements 'comm configure'. + # + # Arguments: + # force Boolean flag. If set the socket is reinitialized. + # args New configuration, as -option value pairs. + # + # Results: + # None. + + proc commConfigure {chan {force 0} args} { + variable comm + + # query + if {[llength $args] == 0} { + foreach v $comm(vars) { + lappend res -$v $comm($chan,$v) + } + return $res + } elseif {[llength $args] == 1} { + set arg [lindex $args 0] + set var [string range $arg 1 end] + if {![string match -* $arg] || ![info exists comm($var,var)]} { + return -code error "Unknown configuration option: $arg" + } + return $comm($chan,$var) + } + + # set + set opt 0 + foreach arg $args { + incr opt + if {[info exists skip]} {unset skip; continue} + set var [string range $arg 1 end] + if {![string match -* $arg] || ![info exists comm($var,var)]} { + return -code error "Unknown configuration option: $arg" + } + set optval [lindex $args $opt] + switch $comm($var,var) { + ev { + if {![string equal $optval ""]} { + set err 0 + if {[catch { + foreach ev $optval { + if {[lsearch -exact {connecting connected incoming eval callback reply lost} $ev] < 0} { + set err 1 + break + } + } + }]} { + set err 1 + } + if {$err} { + return -code error \ + "Non-event to configuration option: -$var" + } + } + # FRINK: nocheck + set $var $optval + set skip 1 + } + interp { + if { + ![string equal $optval ""] && + ![interp exists $optval] + } { + return -code error \ + "Non-interpreter to configuration option: -$var" + } + # FRINK: nocheck + set $var $optval + set skip 1 + } + b { + # FRINK: nocheck + set $var [string is true -strict $optval] + set skip 1 + } + v { + # FRINK: nocheck + set $var $optval + set skip 1 + } + p { + ##nagelfar ignore + if {![string is integer -strict $optval]} { + return -code error \ + "Non-port to configuration option: -$var" + } + # FRINK: nocheck + set $var [format %d $optval] + set skip 1 + } + i { + ##nagelfar ignore + if {![string is integer $optval]} { + return -code error \ + "Non-integer to configuration option: -$var" + } + # FRINK: nocheck + set $var [format %d $optval] + set skip 1 + } + enc { + # to configure encodings, we will need to extend the + # protocol to allow for handshaked encoding changes + return -code error "encoding not configurable" + if {[lsearch -exact [encoding names] $optval] == -1} { + return -code error \ + "Unknown encoding to configuration option: -$var" + } + set $var $optval + set skip 1 + } + ro { + return -code error "Readonly configuration option: -$var" + } + socketcmd { + if {$optval eq {}} { + return -code error \ + "Non-command to configuration option: -$var" + } + + set $var $optval + set skip 1 + } + tclchan { + #test existence of channel - don't use existence in [chan names] - could be a wrapped channel + if {[catch {chan configure $optval} errM]} { + return -code error \ + "Cannot verify existence of Tcl channel supplied to configuration option: -$var" + } + set $var $optval + set skip 1 + } + } + } + if {[info exists skip]} { + return -code error "Missing value for option: $arg" + } + + foreach var {port listen local socketcmd tclchan} { + # FRINK: nocheck + if {[info exists $var] && [set $var] != $comm($chan,$var)} { + incr force + # FRINK: nocheck + set comm($chan,$var) [set $var] + } + } + + foreach var {silent interp events} { + # FRINK: nocheck + if {[info exists $var] && ([set $var] != $comm($chan,$var))} { + # FRINK: nocheck + set comm($chan,$var) [set ip [set $var]] + if {[string equal $var "interp"] && ($ip != "")} { + # Interrogate the interp about its capabilities. + # + # Like: set, array set, uplevel present ? + # Or: The above, hidden ? + # + # This is needed to decide how to execute hook scripts + # and regular scripts in this interpreter. + set comm($chan,interp,set) [Capability $ip set] + set comm($chan,interp,aset) [Capability $ip array] + set comm($chan,interp,upl) [Capability $ip uplevel] + } + } + } + + if {[info exists encoding] && + ![string equal $encoding $comm($chan,encoding)]} { + # This should not be entered yet + set comm($chan,encoding) $encoding + fconfigure $comm($chan,socket) -encoding $encoding + foreach {i sock} [array get comm $chan,peers,*] { + fconfigure $sock -encoding $encoding + } + } + + # do not re-init socket + if {!$force} {return ""} + + #experimental e.g fifo2 + #------------------------- + if {[info exists comm($chan,tclchan)] && $comm($chan,tclchan) ne "" && $comm($chan,listen)} { + #treat as always connected - call commIncoming imediately. + punk::icomm::commIncoming $chan $comm($chan,tclchan) "localaddr" "localtclchan" + return + } + + #------------------------- + + # User is recycling object, possibly to change from local to !local + if {[info exists comm($chan,socket)]} { + comm_cmd_abort $chan + catch {close $comm($chan,socket)} + unset comm($chan,socket) + } + + set comm($chan,socket) "" + if {!$comm($chan,listen)} { + set comm($chan,port) 0 + return "" + } + + if {[info exists port] && [string equal "" $comm($chan,port)]} { + set nport [incr comm(lastport)] + } else { + set userport 1 + set nport $comm($chan,port) + } + while {1} { + set cmd [list $comm($chan,socketcmd) -server [list ::punk::icomm::commIncoming $chan]] + if {$comm($chan,local)} { + lappend cmd -myaddr $comm(localhost) + } + lappend cmd $nport + if {![catch $cmd ret]} { + break + } + if {[info exists userport] || ![string match "*already in use" $ret]} { + # don't eradicate the class + if { + ![string equal ::punk::icomm::comm $chan] && + ![string equal [info proc $chan] ""] + } { + rename $chan {} + } + return -code error $ret + } + set nport [incr comm(lastport)] + } + set comm($chan,socket) $ret + fconfigure $ret -translation lf -encoding $comm($chan,encoding) + + # If port was 0, system allocated it for us + set comm($chan,port) [lindex [fconfigure $ret -sockname] 2] + return "" + } + + # ::punk::icomm::Capability -- + # + # Internal command. Interogate an interp for + # the commands needed to execute regular and + # hook scripts. + + proc Capability {interp cmd} { + if {[lsearch -exact [interp hidden $interp] $cmd] >= 0} { + # The command is present, although hidden. + return hidden + } + + # The command is not a hidden command. Use info to determine if it + # is present as regular command. Note that the 'info' command + # itself might be hidden. + + if {[catch { + set has [llength [interp eval $interp [list info commands $cmd]]] + }] && [catch { + set has [llength [interp invokehidden $interp info commands $cmd]] + }]} { + # Unable to interogate the interpreter in any way. Assume that + # the command is not present. + set has 0 + } + return [expr {$has ? "ok" : "no"}] + } + + # punk::icomm::commConnect -- + # + # Internal command. Called to connect to a remote interp + # + # Arguments: + # id Specification of the location of the remote interp. + # A list containing either one or two elements. + # One element = port, host is localhost. + # Two elements = port and host, in this order. + # + # Results: + # fid channel handle of the socket the connection goes through. + + proc commConnect {chan id} { + variable comm + + commDebug {puts stderr "<$chan> commConnect $id"} + + # process connecting hook now + CommRunHook $chan connecting + + if {[info exists comm($chan,peers,$id)]} { + return $comm($chan,peers,$id) + } + if {[lindex $id 0] == 0} { + return -code error "Remote comm is anonymous; cannot connect" + } + + # experimental + # ----------------------------------------------------------- + if {[llength $id] == 2 && [lindex $id 0] eq "tclchan"} { + set fid [lindex $id 1] + if {[catch {chan configure $fid} errMsg]} { + error $errMsg $::errorInfo + } + + # process connected hook now + if {[catch { + CommRunHook $chan connected + } err]} { + global errorInfo + set ei $errorInfo + close $fid + error $err $ei + } + # commit new connection + commNewConn $chan $id $fid + # send offered protocols versions and id to identify ourselves to remote + #puts $fid [list $comm(offerVers) $comm($chan,port)] + puts $fid [list $comm(offerVers) $fid] ;#all we have to offer is our end of the pipe as an id? + set comm($chan,vers,$id) $comm(defVers) ;# default proto vers + flush $fid + return $fid + } + # ----------------------------------------------------------- + + + if {[llength $id] > 1} { + set host [lindex $id 1] + } else { + set host $comm(localhost) + } + set port [lindex $id 0] + set fid [$comm($chan,socketcmd) $host $port] + + # process connected hook now + if {[catch { + CommRunHook $chan connected + } err]} { + global errorInfo + set ei $errorInfo + close $fid + error $err $ei + } + + # commit new connection + commNewConn $chan $id $fid + + # send offered protocols versions and id to identify ourselves to remote + puts $fid [list $comm(offerVers) $comm($chan,port)] + set comm($chan,vers,$id) $comm(defVers) ;# default proto vers + flush $fid + return $fid + } + + # ::punk::icomm::commIncoming -- + # + # Internal command. Called for an incoming new connection. + # Handles connection setup and initialization. + # + # Arguments: + # chan logical channel handling the connection. + # fid channel handle of the socket running the connection. + # addr ip address of the socket channel 'fid' + # remport remote port for the socket channel 'fid' + # + # Results: + # None. + + proc commIncoming {chan fid addr remport} { + variable comm + + commDebug {puts stderr "<$chan> commIncoming $fid $addr $remport"} + + # process incoming hook now + if {[catch { + CommRunHook $chan incoming + } err]} { + global errorInfo + set ei $errorInfo + close $fid + error $err $ei + } + + # Wait for offered version, without blocking the entire system. + # Bug 3066872. For a Tcl 8.6 implementation consider use of + # coroutines to hide the CSP and properly handle everything + # event based. + + fconfigure $fid -blocking 0 + fileevent $fid readable [list ::punk::icomm::commIncomingOffered $chan $fid $addr $remport] + return + } + + proc commIncomingOffered {chan fid addr remport} { + variable comm + + # Check if we have a complete line. + if {[gets $fid protoline] < 0} { + #commDebug {puts stderr "commIncomingOffered: no data"} + if {[eof $fid]} { + commDebug {puts stderr "commIncomingOffered: eof on fid=$fid"} + catch { + close $fid + } + } + return + } + + # Protocol version line has been received, disable event handling + # again. + fileevent $fid readable {} + fconfigure $fid -blocking 1 + + # a list of offered proto versions is the first word of first line + # remote id is the second word of first line + # rest of first line is ignored + + set offeredvers [lindex $protoline 0] + set remid [lindex $protoline 1] + + commDebug {puts stderr "<$chan> offered <$protoline>"} + + # use the first supported version in the offered list + foreach v $offeredvers { + if {[info exists comm($v,vers)]} { + set vers $v + break + } + } + if {![info exists vers]} { + close $fid + if {[info exists comm($chan,silent)] && + [string is true -strict $comm($chan,silent)]} { + return + } + error "Unknown offered protocols \"$protoline\" from $addr/$remport" + } + + set chanconf [chan configure $fid] + if {[dict exists $chanconf -sockname]} { + # If the remote host addr isn't our local host addr, + # then add it to the remote id. + if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} { + set id $remid + } else { + set id [list $remid $addr] + } + } else { + #tclchan? + set id $fid + + } + + # Detect race condition of two comms connecting to each other + # simultaneously. It is OK when we are talking to ourselves. + + if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} { + + puts stderr "commIncoming race condition: $id" + puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)" + + # To avoid the race, we really want to terminate one connection. + # However, both sides are committed to using it. + # commConnect needs to be synchronous and detect the close. + # close $fid + # return $comm($chan,peers,$id) + } + + # Make a protocol response. Avoid any temptation to use {$vers > 2} + # - this forces forwards compatibility issues on protocol versions + # that haven't been invented yet. DON'T DO IT! Instead, test for + # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK. + + switch $vers { + 3 { + # Respond with the selected version number + puts $fid [list [list vers $vers]] + flush $fid + } + } + + # commit new connection + commNewConn $chan $id $fid + set comm($chan,vers,$id) $vers + } + + # ::punk::icomm::commNewConn -- + # + # Internal command. Common new connection processing + # + # Arguments: + # id Reference to the remote interp + # fid channel handle of the socket running the connection. + # + # Results: + # None. + + proc commNewConn {chan id fid} { + variable comm + + commDebug {puts stderr "<$chan> commNewConn $id $fid"} + + # There can be a race condition two where comms connect to each other + # simultaneously. This code favors our outgoing connection. + + if {[info exists comm($chan,peers,$id)]} { + # abort this connection, use the existing one + # close $fid + # return -code return $comm($chan,peers,$id) + } else { + set comm($chan,pending,$id) {} + set comm($chan,peers,$id) $fid + } + set comm($chan,fids,$fid) $id + fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 + fileevent $fid readable [list ::punk::icomm::commCollect $chan $fid] + } + + # ::punk::icomm::commLostConn -- + # + # Internal command. Called to tidy up a lost connection, + # including aborting ongoing sends. Each send should clean + # themselves up in pending/result. + # + # Arguments: + # fid Channel handle of the socket which got lost. + # reason Message describing the reason of the loss. + # + # Results: + # reason + + proc commLostConn {chan fid reason} { + variable comm + + commDebug {puts stderr "<$chan> commLostConn $fid $reason"} + + catch {close $fid} + + set id $comm($chan,fids,$fid) + + # Invoke the callbacks of all commands which have such and are + # still waiting for a response from the lost peer. Use an + # appropriate error. + + foreach s $comm($chan,pending,$id) { + if {[string equal "callback" [lindex $s end]]} { + set ser [lindex $s 0] + if {[info exists comm($chan,return,$ser)]} { + set args [list -id $id \ + -serial $ser \ + -chan $chan \ + -code -1 \ + -errorcode NONE \ + -errorinfo "" \ + -result $reason \ + ] + if {[catch {uplevel \#0 $comm($chan,return,$ser) $args} err]} { + commBgerror $err + } + } + } else { + set comm($chan,return,$s) {-code error} + set comm($chan,result,$s) $reason + } + } + unset comm($chan,pending,$id) + unset comm($chan,fids,$fid) + catch {unset comm($chan,peers,$id)} ;# race condition + catch {unset comm($chan,buf,$fid)} + + # Cancel all outstanding futures for requests which were made by + # the lost peer, if there are any. This does not destroy + # them. They will stay around until the long-running operations + # they belong too kill them. + + CancelFutures $fid + + # process lost hook now + catch {CommRunHook $chan lost} + + return $reason + } + + proc commBgerror {err} { + # SF Tcllib Patch #526499 + # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883 + # for initial request and comments) + # + # Error in async call. Look for [bgerror] to report it. Same + # logic as in Tcl itself. Errors thrown by bgerror itself get + # reported to stderr. + if {[catch {bgerror $err} msg]} { + puts stderr "bgerror failed to handle background error." + puts stderr " Original error: $err" + puts stderr " Error in bgerror: $msg" + flush stderr + } + } + + # CancelFutures: Mark futures associated with a comm channel as + # expired, done when the connection to the peer has been lost. The + # marked futures will not generate result anymore. They will also stay + # around until destroyed by the script they belong to. + + proc CancelFutures {fid} { + variable comm + if {![info exists comm(future,fid,$fid)]} return + + commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \ + "\n\t : "]"} + + foreach future $comm(future,fid,$fid) { + $future Cancel + } + + unset comm(future,fid,$fid) + return + } + + ############################################################################### + + # ::punk::icomm::commCollect -- + # + # Internal command. Called from the fileevent to read from fid + # and append to the buffer. This continues until we get a whole + # command, which we then invoke. + # + # Arguments: + # chan logical channel collecting the data + # fid channel handle of the socket we collect. + # + # Results: + # None. + + proc commCollect {chan fid} { + variable comm + upvar #0 comm($chan,buf,$fid) data + + # Tcl8 may return an error on read after a close + if {[catch {read $fid} nbuf] || [eof $fid]} { + commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"} + commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"} + commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"} + + fileevent $fid readable {} ;# be safe + commLostConn $chan $fid "target application died or connection lost" + return + } + append data $nbuf + + commDebug {puts stderr "<$chan> collect <$data>"} + + # If data contains at least one complete command, we will + # be able to take off the first element, which is a list holding + # the command. This is true even if data isn't a well-formed + # list overall, with unmatched open braces. This works because + # each command in the protocol ends with a newline, thus allowing + # lindex and lreplace to work. + # + # This isn't true with Tcl8.0, which will return an error until + # the whole buffer is a valid list. This is probably OK, although + # it could potentially cause a deadlock. + + # [AK] Actually no. This breaks down if the sender shoves so much + # data at us so fast that the receiver runs into out of memory + # before the list is fully well-formed and thus able to be + # processed. + + + while {![catch { + set cmdrange [Word0 data] + # word0 is essentially the pre-8.0 'lindex 0', getting + # the first word of a list, even if the remainder is not fully + # well-formed. Slight API change, we get the char indices the + # word is between, and a relative index to the remainder of + # the list. + }]} { + # Unpack the indices, then extract the word. + #foreach {s e step} $cmdrange break + lassign $cmdrange s e step + + set cmd [string range $data $s $e] + commDebug {puts stderr "<$chan> cmd <$data>"} + if {[string equal "" $cmd]} break + if {[info complete $cmd]} { + # The word is a command, step to the remainder of the + # list, and delete the word we have processed. + incr e $step + set data [string range $data $e end] + after idle \ + [list ::punk::icomm::commExec $chan $fid $comm($chan,fids,$fid) $cmd] + } + } + } + + # ::punk::icomm::commExec -- + # + # Internal command. Receives and executes a remote command, + # returning the result and/or error. Unknown protocol commands + # are silently discarded + # + # Arguments: + # chan logical channel collecting the data + # fid channel handle of the socket we collect. + # remoteid id of the other side. + # buf buffer containing the command to execute. + # + # Results: + # None. + + proc commExec {chan fid remoteid buf} { + variable comm + + # buffer should contain: + # send # {cmd} execute cmd and send reply with serial # + # async # {cmd} execute cmd but send no reply + # reply # {cmd} execute cmd as reply to serial # + + # these variables are documented in the hook interface + set cmd [lindex $buf 0] + set ser [lindex $buf 1] + set buf [lrange $buf 2 end] + set buffer [lindex $buf 0] + + # Save remoteid for "comm remoteid". This will only be valid + # if retrieved before any additional events occur on this channel. + # N.B. we could have already lost the connection to remote, making + # this id be purely informational! + set comm($chan,remoteid) [set id $remoteid] + + # Save state for possible async result generation + AsyncPrepare $chan $fid $cmd $ser + + commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"} + + switch -- $cmd { + send - async - command {} + callback { + if {![info exists comm($chan,return,$ser)]} { + commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} + return + } + + # Decompose reply command to assure it only uses "return" + # with no side effects. + + array set return {-code "" -errorinfo "" -errorcode "" } + set ret [lindex $buffer end] + set len [llength $buffer] + incr len -2 + foreach {sw val} [lrange $buffer 1 $len] { + if {![info exists return($sw)]} {continue} + set return($sw) $val + } + + catch {CommRunHook $chan callback} + + # this wakes up the sender + commDebug {puts stderr "<$chan> --<>--"} + + # the return holds the callback command + # string map the optional %-subs + set args [list -id $id \ + -serial $ser \ + -chan $chan \ + -code $return(-code) \ + -errorcode $return(-errorcode) \ + -errorinfo $return(-errorinfo) \ + -result $ret \ + ] + set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err] + catch { + unset comm($chan,return,$ser) + } + + # remove pending serial + upvar 0 comm($chan,pending,$id) pending + if {[info exists pending]} { + set pos [lsearch -exact $pending [list $ser callback]] + if {$pos != -1} { + set pending [lreplace $pending $pos $pos] + } + } + if {$code} { + commBgerror $err + } + return + } + reply { + if {![info exists comm($chan,return,$ser)]} { + commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} + return + } + + # Decompose reply command to assure it only uses "return" + # with no side effects. + + array set return {-code "" -errorinfo "" -errorcode "" } + set ret [lindex $buffer end] + set len [llength $buffer] + incr len -2 + foreach {sw val} [lrange $buffer 1 $len] { + if {![info exists return($sw)]} continue + set return($sw) $val + } + + catch {CommRunHook $chan reply} + + # this wakes up the sender + commDebug {puts stderr "<$chan> --<>--"} + set comm($chan,result,$ser) $ret + set comm($chan,return,$ser) [array get return] + return + } + vers { + set comm($chan,vers,$id) $ser + return + } + default { + commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""} + return + } + } + + # process eval hook now + set done 0 + set err 0 + if {[info exists comm($chan,hook,eval)]} { + set err [catch {CommRunHook $chan eval} ret] + commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"} + switch $err { + 1 { + # error + set done 1 + } + 2 - 3 { + # return / break + set err 0 + set done 1 + } + } + } + + commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"} + + # exec command + if {!$done} { + commDebug {puts stderr "<$chan> exec ($buffer)"} + + # Sadly, the uplevel needs to be in the catch to access the local + # variables buffer and ret. These cannot simply be global because + # commExec is reentrant (i.e., they could be linked to an allocated + # serial number). + + if {$comm($chan,interp) == {}} { + # Main interpreter + set thecmd [concat [list uplevel \#0] $buffer] + set err [catch $thecmd ret] + } else { + # Redirect execution into the configured slave + # interpreter. The exact command used depends on the + # capabilities of the interpreter. A best effort is made + # to execute the script in the global namespace. + set interp $comm($chan,interp) + + if {$comm($chan,interp,upl) == "ok"} { + set thecmd [concat [list uplevel \#0] $buffer] + set err [catch {interp eval $interp $thecmd} ret] + } elseif {$comm($chan,interp,aset) == "hidden"} { + set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0] + set err [catch $thecmd ret] + } else { + set thecmd [concat [list interp eval $interp] $buffer] + set err [catch $thecmd ret] + } + } + } + + # Check and handle possible async result generation. + if {[AsyncCheck]} {return} + + commSendReply $chan $fid $cmd $ser $err $ret + return + } + + # ::punk::icomm::commSendReply -- + # + # Internal command. Executed to construct and send the reply + # for a command. + # + # Arguments: + # fid channel handle of the socket we are replying to. + # cmd The type of request (send, command) we are replying to. + # ser Serial number of the request the reply is for. + # err result code to place into the reply. + # ret result value to place into the reply. + # + # Results: + # None. + + proc commSendReply {chan fid cmd ser err ret} { + variable comm + + commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"} + + # The double list assures that the command is a single list when read. + if {[string equal send $cmd] || [string equal command $cmd]} { + # The catch here is just in case we lose the target. Consider: + # comm send $other comm send [comm self] exit + catch { + set return [list return -code $err] + # send error or result + if {$err == 1} { + global errorInfo errorCode + lappend return -errorinfo $errorInfo -errorcode $errorCode + } + lappend return $ret + if {[string equal send $cmd]} { + set reply reply + } else { + set reply callback + } + puts $fid [list [list $reply $ser $return]] + flush $fid + } + commDebug {puts stderr "<$chan> reply sent"} + } + + if {$err == 1} { + commBgerror $ret + } + commDebug {puts stderr "<$chan> exec complete"} + return + } + + proc CommRunHook {chan event} { + variable comm + + # The documentation promises the hook scripts to have access to a + # number of internal variables. For a regular hook we simply + # execute it in the calling level to fulfill this. When the hook + # is redirected into an interpreter however we do a best-effort + # copying of the variable values into the interpreter. Best-effort + # because the 'set' command may not be available in the + # interpreter, not even hidden. + + if {![info exists comm($chan,hook,$event)]} return + set cmd $comm($chan,hook,$event) + set interp $comm($chan,interp) + commDebug {puts stderr "<$chan> hook($event) run <$cmd>"} + + if { + ($interp != {}) && + ([lsearch -exact $comm($chan,events) $event] >= 0) + } { + # Best-effort to copy the context into the interpreter for + # access by the hook script. + set vars { + addr buffer chan cmd fid host + id port reason remport ret var + } + + if {$comm($chan,interp,set) == "ok"} { + foreach v $vars { + upvar 1 $v V + if {![info exists V]} continue + interp eval $interp [list set $v $V] + } + } elseif {$comm($chan,interp,set) == "hidden"} { + foreach v $vars { + upvar 1 $v V + if {![info exists V]} continue + interp invokehidden $interp set $v $V + } + } + upvar 1 return AV + if {[info exists AV]} { + if {$comm($chan,interp,aset) == "ok"} { + interp eval $interp [list array set return [array get AV]] + } elseif {$comm($chan,interp,aset) == "hidden"} { + interp invokehidden $interp array set return [array get AV] + } + } + + commDebug {puts stderr "<$chan> /interp $interp"} + set code [catch {interp eval $interp $cmd} res options] + } else { + commDebug {puts stderr "<$chan> /main"} + set code [catch {uplevel 1 $cmd} res options] + } + + # Perform the return code propagation promised + # to the hook scripts. + return -options $options -code $code $res + } + + # ### ### ### ######### ######### ######### + ## Hooks to link async return and future processing into the regular + ## system. + + # AsyncPrepare, AsyncCheck: Initialize state information for async + # return upon start of a remote invokation, and checking the state for + # async return. + + proc AsyncPrepare {chan fid cmd ser} { + variable comm + set comm(current,async) 0 + set comm(current,state) [list $chan $fid $cmd $ser] + return + } + + proc AsyncCheck {} { + # Check if the executed command notified us of an async return. If + # not we let the regular return processing handle the end of the + # script. Otherwise we stop the caller from proceeding, preventing + # a regular return. + + variable comm + if {!$comm(current,async)} {return 0} + return 1 + } + + # FutureDone: Action taken by an uncanceled future to deliver the + # generated result to the proper invoker. This also removes the future + # from the list of pending futures for the comm channel. + + proc FutureDone {future chan fid cmd sid rcode rvalue} { + variable comm + commSendReply $chan $fid $cmd $sid $rcode $rvalue + + set pos [lsearch -exact $comm(future,fid,$fid) $future] + set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos] + return + } + + # ### ### ### ######### ######### ######### + ## Hooks to save command state across nested eventloops a remotely + ## invoked command may run before finally activating async result + ## generation. + + # DANGER !! We have to refer to comm internals using fully-qualified + # names because the wrappers will execute in the global namespace + # after their installation. + + proc Vwait {varname} { + variable ::punk::icomm::comm + + set hasstate [info exists comm(current,async)] + set hasremote 0 + if {$hasstate} { + set chan [lindex $comm(current,state) 0] + set async $comm(current,async) + set state $comm(current,state) + set hasremote [info exists comm($chan,remoteid)] + if {$hasremote} { + set remoteid $comm($chan,remoteid) + } + } + + set code [catch {uplevel 1 [list ::punk::icomm::VwaitOrig $varname]} res] + + if {$hasstate} { + set comm(current,async) $async + set comm(current,state) $state + } + if {$hasremote} { + set comm($chan,remoteid) $remoteid + } + + return -code $code $res + } + + proc Update {args} { + variable ::punk::icomm::comm + + set hasstate [info exists comm(current,async)] + set hasremote 0 + if {$hasstate} { + set chan [lindex $comm(current,state) 0] + set async $comm(current,async) + set state $comm(current,state) + + set hasremote [info exists comm($chan,remoteid)] + if {$hasremote} { + set remoteid $comm($chan,remoteid) + } + } + + set code [catch {uplevel 1 [linsert $args 0 ::punk::icomm::UpdateOrig]} res] + + if {$hasstate} { + set comm(current,async) $async + set comm(current,state) $state + } + if {$hasremote} { + set comm($chan,remoteid) $remoteid + } + + return -code $code $res + } + + # Install the wrappers. + + proc InitWrappers {} { + rename ::vwait ::punk::icomm::VwaitOrig + rename ::punk::icomm::Vwait ::vwait + + rename ::update ::punk::icomm::UpdateOrig + rename ::punk::icomm::Update ::update + + proc ::punk::icomm::InitWrappers {} {} + return + } + + proc Word0 {dv} { + upvar 1 $dv data + + # data + # + # The string we expect to be either a full well-formed list, or a + # well-formed list until the end of the first word in the list, + # with non-wellformed data following after, i.e. an incomplete + # list with a complete first word. + + set re "^\\s*(\{)" ;#\} + if {[regexp -indices $re $data -> bracerange]} { + # The word is brace-quoted, starting at index 'lindex + # bracerange 0'. We now have to find the closing brace, + # counting inner braces, ignoring quoted braces. We fail if + # there is no proper closing brace. + + lassign $bracerange s e + incr s ; # index of the first char after the brace. + incr e ; # same. but this is our running index. + + set level 1 + set max [string length $data] + + while {$level} { + # We are looking for the first regular or backslash-quoted + # opening or closing brace in the string. If none is found + # then the word is not complete, and we abort our search. + + # \{Bug 2972571: To avoid the bogus detection of + # backslash-quoted braces we look for double-backslashes + # as well and skip them. Without this a string like '{puts + # \\}' will incorrectly find a \} at the end, missing the + # end of the word. + set re {((\\\\)|([{}])|(\\[{}]))} ;#split out for dumb editor to fix highlighting + # ^^ ^ ^ + # |\\ regular \quoted + # any + + if {![regexp -indices -start $e $re $data -> any dbs regular quoted]} { + return -code error "no complete word found/1" + } + # + lassign $dbs ds de + lassign $quoted qs qe + lassign $regular rs re + + if {$ds >= 0} { + # Skip double-backslashes ... + set e $de + incr e + continue + } elseif {$qs >= 0} { + # Skip quoted braces ... + set e $qe + incr e + continue + } elseif {$rs >= 0} { + # Step one nesting level in or out. + if {[string index $data $rs] eq "\{" || "boguseditorfix" eq "\}"} { + incr level + } else { + incr level -1 + } + set e $re + incr e + #puts @$e + continue + } else { + return -code error "internal error" + } + } + # + incr e -2 ; # index of character just before the brace. + return [list $s $e 2] + + } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} { + # The word is a simple literal which ends at the next + # whitespace character. Note that there has to be a whitespace + # for us to recognize a word, for while there is no whitespace + # behind it in the buffer the word itself may be incomplete. + + return [linsert $wordrange end 1] + } + + return -code error "no complete word found/2" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::icomm ---}] +} + +interp alias {} ::punk::icomm::comm_cmd_interps {} ::punk::icomm::comm_cmd_ids + + + + +# ### ### ### ######### ######### ######### +## API: Future objects. + +snit::type punk::icomm::future { + option -command -default {} + + constructor {chan fid cmd ser} { + set xfid $fid + set xcmd $cmd + set xser $ser + set xchan $chan + return + } + + destructor { + if {!$canceled} { + return -code error \ + "Illegal attempt to destroy unresolved future \"$self\"" + } + } + + method return {args} { + # Syntax: | 0 + # : -code x | 2 + # : -code x val | 3 + # : val | 4 + # Allowing multiple -code settings, last one is taken. + + set rcode 0 + set rvalue {} + + while {[lindex $args 0] == "-code"} { + set rcode [lindex $args 1] + set args [lrange $args 2 end] + } + if {[llength $args] > 1} { + return -code error "wrong\#args, expected \"?-code errcode? ?result?\"" + } + if {[llength $args] == 1} { + set rvalue [lindex $args 0] + } + + if {!$canceled} { + ::punk::icomm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue + set canceled 1 + } + # assert: canceled == 1 + $self destroy + return + } + + variable xfid {} + variable xcmd {} + variable xser {} + variable xchan {} + variable canceled 0 + + # Internal method for use by comm channels. Marks the future as + # expired, no peer to return a result back to. + + method Cancel {} { + set canceled 1 + if {![llength $options(-command)]} {return} + uplevel #0 [linsert $options(-command) end $self] + return + } +} + +# ### ### ### ######### ######### ######### +## Setup +::punk::icomm::InitWrappers + +############################################################################### +# +# Finish creating "comm" using the default port for this interp. +# + +#don't listen by default +proc ::punk::icomm::initlocal {{tcpport 0}} { + if {![info exists ::punk::icomm::comm(comm,port)]} { + if {[string equal macintosh $::tcl_platform(platform)]} { + ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 0 -listen 1 + set ::punk::icomm::comm(localhost) \ + [lindex [fconfigure $::punk::icomm::comm(::punk::icomm::comm,socket) -sockname] 0] + ::punk::icomm::comm config -local 1 + } else { + ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 1 -listen 1 + } + } + return [::punk::icomm::comm configure] +} + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::icomm::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::icomm::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 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::icomm::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::icomm::system { + #*** !doctools + #[subsection {Namespace punk::icomm::system}] + #[para] Internal functions that are not part of the API + + + +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::icomm { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::icomm" + @package -name "punk::icomm" -help\ + "taken from tcllib comm package + todo - describe changes" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::icomm + } + 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::icomm + description to come.. + } \n] + } + proc get_topic_License {} { + return "" + } + proc get_topic_Version {} { + return "$::punk::icomm::version" + } + proc get_topic_Contributors {} { + set authors {} + 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_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # 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::icomm::about" + dict set overrides @cmd -name "punk::icomm::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::icomm + }] \n] + dict set overrides topic -choices [list {*}[punk::icomm::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::icomm::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::icomm::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::icomm::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::icomm +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::icomm [tcl::namespace::eval punk::icomm { + variable pkg punk::icomm + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/icomm-buildversion.txt b/src/modules/punk/icomm-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/icomm-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/imap4-999999.0a1.0.tm b/src/modules/punk/imap4-999999.0a1.0.tm new file mode 100644 index 00000000..a6f8355b --- /dev/null +++ b/src/modules/punk/imap4-999999.0a1.0.tm @@ -0,0 +1,3412 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/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 +# Copyright (C) 2004 Salvatore Sanfilippo +# Copyright (C) 2013 Nicola Hall +# Copyright (C) 2013 Magnatune +# +# 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) + +# +# @@ Meta Begin +# Application punk::imap4 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[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 --}] +#[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 { + 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}] +#[item] [package {punk::args}] +#[item] [package {punk::lib}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::imap4::class { + #*** !doctools + #[subsection {Namespace punk::imap4::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +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::proto { + variable PUNKARGS + variable info + variable coninfo + namespace export {[a-z]*} + + #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 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] + } + # 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. + proc simplecmd {chan command validstates args} { + requirestate $chan $validstates + + set req "$command" + foreach arg $args { + 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 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 line + 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 + ::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 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 + } + + # Extract information from the line + set dirty 0 + 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= + regexp {.*\[CAPABILITY\s+(.*)\]\s*(.*)$} $line => capstring tailstring + 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'" + } + } + } + } + + #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) + incr dirty + } + {^[0-9]+\s+RECENT} { + regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent) + incr dirty + } + {.*?\[UIDVALIDITY\s+[0-9]+?\]} { + regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,uidval) + incr dirty + } + {.*?\[UNSEEN\s+[0-9]+?\]} { + regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,unseen) + incr dirty + } + {.*?\[UIDNEXT\s+[0-9]+?\]} { + regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,uidnext) + 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 + } + {^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) + 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] + 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 ad 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 + 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 + } + set info($chan,lastrequest) $request + } + + + # 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 {} + } + + 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 - + ALL {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 + } + + NOT { + set e [convert_search_expr [pop0 expr]] + multiline_append_command result "NOT" + multiline_concat_expr result $e + } + + SMALLER - + LARGER { + set len [pop0 expr] + ##nagelfar ignore + 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 + } + + + + # 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::OPEN + @cmd -name punk::imap4::OPEN -help\ + "Open a new IMAP connection and initialise the handler. + Returns the Tcl channel to use in subsequent calls to + the API." + @leaders -min 0 -max 0 + -debug -type boolean -default 0 + -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 port argument + 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 OPEN {args} { + set argd [punk::args::parse $args withid ::punk::imap4::OPEN] + 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::OPEN] + 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. todo UIDs separate variable? + #some headers have multipl 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 password [dict get $values 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 "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 password [dict get $values password] + package require base64 + set b64_creds [base64::encode $opt_authorization\0$username\0$password] + if {[punk::imap4::proto::simplecmd $chan "AUTHENTICATE PLAIN" {*}$allowstates $b64_creds]} { + return 1 + } + set info($chan,state) AUTH + 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; + 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 + }] + 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 + } + + # General function for selection. + proc selectmbox {chan cmd mailbox} { + upvar ::punk::imap4::proto::info info + variable mboxinfo + + 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 + 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 + } + + set info($chan,state) SELECT + # Set the new name as mbox->current. + #set mboxinfo($chan,current) $mailbox + _set_mboxinfo $chan current $mailbox + return 0 + } + # Read-only equivalent of SELECT. + proc EXAMINE {chan {mailbox INBOX}} { + selectmbox $chan EXAMINE $mailbox + } + + # Parse an IMAP range, store 'start' and 'end' in the + # named vars. If the first number of the range is omitted, + # 1 is assumed. If the second number of the range is omitted, + # the value of "exists" of the current mailbox is assumed. + # + # So : means all the messages. + proc parserange {chan range startvar endvar} { + + upvar $startvar start $endvar end + set rangelist [split $range :] + switch -- [llength $rangelist] { + 1 { + ##nagelfar ignore + 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] + } + ##nagelfar ignore + 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 + range supplied for the message(s) of interest." + @leaders -min 1 -max 1 + chan + @opts + -inline -type none + @values -min 1 -max -1 + range -help\ + "Message sequence number set. + e.g + 1 + 1:3 + 2:2 + :3 + " + queryitems -default {} -help\ + "Some common FETCH queries are shown here, but + this list isn't exhaustive."\ + -multiple 1 -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices { + ALL FAST FULL BODY BODYSTRUCTURE ENVELOPE FLAGS INTERNALDATE + SIZE RFC822.SIZE + UID + TEXT HEADER BODY[] + } -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" + } + }] + 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 range [dict get $values range] + set query_items [dict get $values queryitems] + + punk::imap4::proto::requirestate $chan SELECT + parserange $chan $range start end + + 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 $start:$end [lindex $items 0]"] + } else { + set request_tag [punk::imap4::proto::request $chan "FETCH $start:$end ([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. + proc CHECK {chan} { + punk::imap4::proto::simplecmd $chan CHECK SELECT {} + } + + # Close the mailbox. Permanently removes \Deleted messages and return to + # the AUTH state. + proc CLOSE {chan} { + upvar ::punk::imap4::proto::info info + variable mboxinfo + + if {[punk::imap4::proto::simplecmd $chan CLOSE SELECT {}]} { + 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 UNSELECT {*}$allowstates {}]} { + 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 + proc CREATE {chan mailbox} { + punk::imap4::proto::simplecmd $chan CREATE {AUTH SELECT} $mailbox + } + + # ------------------------------------------------------------ + # - RFC6154 IMAP LIST Extension for Special-use Mailboxes + # - other mailbox 'annotations' ? + # - relevant CAPS: SPECIAL-USE CREATE-SPECIAL-USE LIST-EXTENDED + # ------------------------------------------------------------ + proc GETMETADATA {chan mailbox annotation} { + #on cyrus at least, annotation must begin with /shared or /private + #e.g /private/specialuse + #C: GETMETDATA "Foldername" /private/specialuse + #S: * METADATA "Foldername" (/private/specialuse NIL) + #S: OK Completed + #or + #C: GETMETDATA "Junk" /private/specialuse + #S: * METADATA "Foldername" (/private/specialuse {5} + #S: \Junk + #S: ) + #S: OK Completed + set annotation [string trim $annotation] + if {![string match "/private/?*" $annotation] && ![string match "/shared/?*" $annotation]} { + error "GETMETADATA annotation must begin with /shared/ or /private/" + } + punk::imap4::proto::simplecmd $chan GETMETADATA {AUTH SELECT} $mailbox $annotation + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::SETMETADATA" + @cmd -name "punk::imap4::SETMETDATA" -help\ + "Set metadata on mailbox" + @leaders -min 1 -max 1 + chan + @opts + @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] + 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 {$value in [list "" NIL]} { + punk::imap4::proto::simplecmd $chan SETMETADATA {AUTH SELECT} $mailbox "($annotation NIL)" + } else { + punk::imap4::proto::simplecmd $chan SETMETADATA {AUTH SELECT} $mailbox "($annotation \"$value\")" + } + } + # ------------------------------------------------------------ + + # Delete a mailbox + proc DELETE {chan mailbox} { + punk::imap4::proto::simplecmd $chan DELETE {AUTH SELECT} $mailbox + } + + # Rename a mailbox + proc RENAME {chan oldname newname} { + punk::imap4::proto::simplecmd $chan RENAME {AUTH SELECT} $oldname $newname + } + + # Subscribe to a mailbox + proc SUBSCRIBE {chan mailbox} { + punk::imap4::proto::simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox + } + + # Unsubscribe to a mailbox + proc UNSUBSCRIBE {chan mailbox} { + punk::imap4::proto::simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox + } + + #TODO + proc IDLE {chan} { + if {[punk::imap4::prot::has_capability $chan IDLE]} { + punk::imap4::proto::simplecmd $chan IDLE {AUTH SELECT} + } 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 "" + mbox -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 mbox] + + 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 LIST $allowstates \"$ref\" \"$mbox\" RETURN (SPECIAL-USE SUBSCRIBED)] + } else { + set rv [punk::imap4::proto::simplecmd $chan LIST $allowstates \"$ref\" \"$mbox\" RETURN (SUBSCRIBED)] + } + if {$opt_inline} { + set rv {} + 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 rv [list [lindex $f 0] $lflags] + } + } + # parray folderinfo + return $rv + } + + + # Search command. + proc SEARCH {chan args} { + if {![llength $args]} { + error "missing arguments. Usage: search chan arg ?arg ...?" + } + + punk::imap4::proto::requirestate $chan SELECT + set imapexpr [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 + proc STORE {chan range key values} { + set valid_keys { + FLAGS + FLAGS.SILENT + +FLAGS + +FLAGS.SILENT + -FLAGS + -FLAGS.SILENT + } + if {$key ni $valid_keys} { + error "Invalid data item: $key. Must be one of [join $valid_keys ,]" + } + parserange $chan $range start end + set newflags {} + foreach val $values { + if {[regexp {^\\+(.*?)$} $val]} { + lappend newflags $values + } else { + lappend newflags "\\$val" + } + } + set clitag [punk::imap4::proto::request $chan "STORE $start:$end $key ([join $newflags])"] + if {[punk::imap4::proto::getresponse $chan $clitag]} { + return 1 + } + return 0 + } + + # Logout + proc LOGOUT {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 + } + + # Expunge : force removal of any messages with the + # flag \Deleted + proc EXPUNGE {chan} { + if {[punk::imap4::proto::simplecmd $chan EXPUNGE SELECT {}]} { + return 1 + } + return 0 + } + + # copy : copy a message to a destination mailbox + proc COPY {chan msgid mailbox} { + if {[punk::imap4::proto::simplecmd $chan COPY SELECT [list $msgid $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 + } + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::imap4 ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# 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? ~{} + #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 ()] + #[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[]<> (bare,squarelist?,partial) + return $words + } + + #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 ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::imap4::system { + #*** !doctools + #[subsection {Namespace punk::imap4::system}] + #[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 + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::imap4" + @package -name "punk::imap4" -help\ + "Package + Description" + }] + + 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 } {Nicola Hall } {Magnatune } {Julian Noble }} + 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::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::OPEN {*}$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 :$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] + diff --git a/src/modules/punk/imap4-buildversion.txt b/src/modules/punk/imap4-buildversion.txt new file mode 100644 index 00000000..329cdfff --- /dev/null +++ b/src/modules/punk/imap4-buildversion.txt @@ -0,0 +1,3 @@ +0.9 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/jtest.tcl b/src/modules/punk/jtest.tcl new file mode 100644 index 00000000..6379cfd9 --- /dev/null +++ b/src/modules/punk/jtest.tcl @@ -0,0 +1,44 @@ + + set a b + set x {a b} + set x [] + set x { + a + {b c} + } + + + + array set comm { + debug 0 + chans {} + localhost 1.2 + x {} + y jb + j aa + blah "xxxb" + defaulg 0 + } + + #test + + if {"x" eq max(2,3)} { + } + if {"x" eq min(1)} {} + + set x [dict create {a b c {x} e f }] + zlib adler32 "abc" + dict get $x "a" + #dict create {a b} + set x [] + #test + array set test1 {blah etc} + array set comm { + debug 0 chans {} localhost 127.0.0.1 + offerVers {3 2} + acceptVers {3 2} + defaultEncoding "utf-8" + defaultSilent 0 + } + #test + set x blah \ No newline at end of file diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm new file mode 100644 index 00000000..bb06e1bd --- /dev/null +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -0,0 +1,3444 @@ + +#punk linerepl +#todo - make repls configurable/pluggable packages + + +#list/string-rep bug +global run_commandstr "" + +set stdin_info [chan configure stdin] +if {[dict exists $stdin_info -inputmode]} { + #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. + # tcl_interactive used by repl to determine if stderr output prompt to be printed. + # (that way, piping commands into stdin should not produce prompts for each command) + set tcl_interactive 1 +} +#however, the -mode option only seems to appear on linux when a terminal exists.. +if {[dict exists $stdin_info -mode]} { + set tcl_interactive 1 +} +#give up for now +set tcl_interactive 1 + + + + + + +package require Thread +package require shellfilter +#package require shellrun +#package require punk +package require punk::lib +package require punk::args +package require punk::aliascore +if {[catch {punk::aliascore::init} errM]} { + puts stderr "punk::aliascore::init error: $errM" +} +package require punk::config +package require punk::ns +package require punk::ansi +package require punk::console +package require textblock + + + + + +if {![info exists ::env(SHELL)]} { + set ::env(SHELL) punk86 +} +if {![info exists ::env(TERM)]} { + # tset -r seems to rely on env(TERM) - so this doesn't seem to work + #if {![catch {exec tset -r} result]} { + # #e.g Terminal type is xterm-256color. + # set t [string trimright [lindex $result end] .] + # set ::env(TERM) $t + #} else { + #fake it ? + #set ::env(TERM) vt100 + set ::env(TERM) xterm-256color + #} +} + +#todo - move to less generic namespace ie punk::repl +namespace eval repl { + variable codethread + if {![info exists codethread]} { + set codethread "" + } + variable codethread_cond + + variable screen_last_chars "" ;#a small sliding append buffer for last char of any screen output to detect \n vs string + variable screen_last_char_list [list] + + #variable last_unknown "" + tsv::set repl last_unknown "" + tsv::set console is_raw 0 + variable output "" + #important not to initialize - as it can be preset by cooperating package before app-punk has been package required + #(this is an example of a deaddrop) + variable post_script +} +namespace eval punk::repl::class { + oo::class create con { + variable o_data ;#dict + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + } +} +namespace eval punk::repl { + tsv::set repl runid 0 + + #todo - key on shell/subshell + tsv::set repl runchunks-0 [list] ;#last_run_display + + + variable debug_repl 0 + variable signal_control_c 0 + variable signal_control_c_msg "" + variable prompt_reset_flag 0 ;#trigger repl to re-retrieve prompt settings + + proc todo {} { + puts "tcl History" + puts "repltelemetry package" + puts "deaddrop package for a consistent way for modules to leave small notes to others that may come later." + } + + #since we are targeting Tcl 8.6+ - we should be using 'interp bgerror .' + #todo - make optional/configurable? + proc bgerror2 {args} { + puts stderr "====================" + puts stderr "punk::repl::bgerror" + puts stderr "====================" + puts stderr "[lindex $args 0]" + puts stderr "-------------------" + puts stderr "[lrange $args 1 end]" + puts stderr "====================" + puts stderr "^^^^^^^^^^^^^^^^^^^" + } + proc bgerror {args} { + set message [lindex $args 0] + set errdict [lindex $args 1] + puts stderr "\n*> repl background error: '$message'" + #puts stderr "*> [set ::errorInfo]" + puts stderr "*> errorinfo: [dict get $errdict -errorinfo]" + set stdinreader [fileevent stdin readable] + if {![string length $stdinreader]} { + puts stderr "*> stdin reader inactive" + } else { + puts stderr "*> stdin reader active" + } + flush stderr + } + + if {![llength [info commands ::bgerror]]} { + #interp alias {} bgerror {} ::punk::repl::bgerror + } + interp bgerror "" ::punk::repl::bgerror + +} +namespace eval repl { + +} + +proc ::punk::repl::init_signal_handlers {} { + if {$::tcl_platform(platform) eq "windows"} { + #puts stdout "===============repl loading twapi===========" + if {![catch {package require twapi}]} { + + #If script launched with windows batch file - we have to be careful to stop a ctrl-c from eventually reaching the batch file when the program terminates, even if fully handled here. + #This is done from within the launching batch file + proc ::punk::repl::handler_console_control {args} { + variable signal_control_c + flush stderr + variable signal_control_c_msg + switch -- [lindex $args 0] { + ctrl-c { + #puts stderr "->event $args" + flush stderr + incr signal_control_c + #rputs stderr "* console_control: $args" + if {[tsv::get console is_raw]} { + if {[lindex $::errorCode 0] eq "CHILDKILLED"} { + #rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" + #avoid spurious triggers after interrupting a command.. + #review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl + set ::punk::repl::signal_control_c 0 + set preverr [string map {"child killed" "child_killed"} $::errorInfo] + catch {error $preverr} ;#for errorInfo display + return 42 + } else { + #how to let rawmode loop handle it? It doesn't seem to get through if we return 0 + #puts stderr "signal ctrl-c while in raw mode" + #flush stderr + set signal_control_c_msg "signal ctrl-c $signal_control_c rawmode" + if {[catch { + lassign [punk::console::get_size] _w console_width _h console_height + } errM]} { + puts stderr "signal ctrl-c error get_size error:$errM" + } + + if {$signal_control_c < 3} { + set remaining [expr {3 - $signal_control_c}] + if {[catch { + punk::repl::console_controlnotification "[a+ web-orange]ctrl-c ($remaining more to quit, enter to continue)[a]" $console_width $console_height + } errM]} { + puts stderr "signal ctrl-c error console_controlnotification error:$errM" + } + } elseif {$signal_control_c == 3} { + #puts stderr "signal ctrl-c x3 received - quitting." + if {[catch { + punk::repl::console_controlnotification "ctrl-c x3 received - quitting punk shell" $console_width $console_height + } errM]} { + puts stderr "signal ctrl-c error console_controlnotification error:$errM" + } + flush stderr + after 25 + quit + return 1 + } elseif {$signal_control_c > 5} { + #fallback if quit didn't work + #puts stderr "signal ctrl-c $signal_control_c received - sending to default handler" + if {[catch { + punk::repl::console_controlnotification "ctrl-c $signal_control_c received - sending to default handler" $console_width $console_height + } errM]} { + puts stderr "signal ctrl-c error console_controlnotification error:$errM" + } + flush stderr + punk::console::mode line + return 0 + } + + return 1 + #after 200 {exit 42} ;#temp + #return 42 + } + } + + + if {[lindex $::errorCode 0] eq "CHILDKILLED"} { + set signal_control_c 0 + set preverr [string map {"child killed" "child_killed"} $::errorInfo] + catch {error $preverr} ;#for errorInfo display + return 42 + } + if {[catch { + lassign [punk::console::get_size] _w console_width _h console_height + } errM]} { + puts stderr "signal ctrl-c error get_size error:$errM" + } + + #note - returning 0 means pass event to other handlers including OS default handler + if {$signal_control_c <= 2} { + set remaining [expr {3 - $signal_control_c}] + #puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)" + #flush stderr + if {[catch { + punk::repl::console_controlnotification "ctrl-c ($remaining more to quit, enter to continue)" $console_width $console_height + } errM]} { + puts stderr "signal ctrl-c error console_controlnotification error:$errM" + } + return 1 + } elseif {$signal_control_c == 3} { + #puts stderr "signal ctrl-c x3 received - quitting." + if {[catch { + punk::repl::console_controlnotification "ctrl-c x3 received - quitting punk shell" $console_width $console_height + } errM]} { + puts stderr "signal ctrl-c error console_controlnotification error:$errM" + } + flush stderr + after 25 + quit + return 1 + } elseif {$signal_control_c == 4} { + puts stderr "signal ctrl-c x4 received - one more to hard exit" + flush stderr + return 1 + } elseif {$signal_control_c >= 5} { + #a script that allows events to be processed could still be running + puts stderr "signal ctrl-c x5 received - hard exit" + flush stderr + after 25 + exit 499 ;# HTTP 'client closed request' - just for the hell of it. + } else { + puts stderr "signal ctrl-c $signal_control_c received" + flush stderr + #return 0 to fall through to default handler + return 0 + } + + } + default { + puts stderr "unhandled console signal $args" + return 1 + } + } + } + twapi::set_console_control_handler ::punk::repl::handler_console_control + #we can't yet emit from an event with proper prompt handling - + #repl::rputs stdout "twapi loaded" + } else { + #repl::rputs stderr " Failed to load twapi" + } + } else { + #TODO + } +} + +#console handler may already be set, but in another thread/interp - so we can't use existence of proc to test +#we're ok with an existing handler - just catch for now. REVIEW we should make sure it didn't fail the first time +catch {punk::repl::init_signal_handlers} + + +# moved to punk package.. +#set outdevice [shellfilter::stack::new punkout -settings [list -tag "punkout" -buffering none -raw 1 -syslog [dict get $::punk::config::running syslog_stdout] -file [dict get $::punk::config::running logfile_stdout]]] +#set out [dict get $outdevice localchan] +#set errdevice [shellfilter::stack::new punkerr -settings [list -tag "punkerr" -buffering none -raw 1 -syslog [dict get $::punk::config::running syslog_stderr] -file [dict get $::punk::config::running logfile_stderr]]] +#set err [dict get $errdevice localchan] + + + +# +#set indevice [shellfilter::stack::new commandin -settings {-tag "commandin" -readbuffering line -writebuffering none -raw 1 -direction in}] +#set program_read_stdin_pipe [dict get $indevice localchan] + + + + + +proc punk::repl::reset_prompt {} { + variable prompt_reset_flag + set prompt_reset_flag 1 +} + +#aliases c and clear to this by ::punk +proc punk::repl::reset_terminal {} { + set prompt_reset_flag 1 + #clear ;#call to external executable which may not be available + puts -nonewline stdout [::punk::ansi::reset] +} + +proc punk::repl::get_prompt_config {} { + if {[catch {punk::console::vt52} is_vt52]} { + set is_vt52 0 + } + if {$is_vt52} { + set resultprompt "52-" + set nlprompt "52." + set infoprompt "52*" + set debugprompt "52~" + } else { + if {$::tcl_interactive} { + set RST [a] + set resultprompt "[a green bold]-$RST " + set nlprompt "[a green bold].$RST " + set infoprompt "[a green bold]*$RST " + set debugprompt "[a purple bold]~$RST " + } else { + set resultprompt "" + set nlprompt "" + set infoprompt "" + set debugprompt "" + } + } + return [list resultprompt $resultprompt nlprompt $nlprompt infoprompt $infoprompt debugprompt $debugprompt] +} + +proc repl::start {inchan args} { + puts stderr "-->repl::start $inchan $args" + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + if {![info exists input_chunks_waiting($inchan)]} { + set input_chunks_waiting($inchan) [list] + } + + variable codethread + #review + if {$codethread eq ""} { + error "start - no codethread. call init first. (options -safe 0|1)" + } + variable commandstr + + # --- + variable editbuf + variable editbuf_list ;#command history + variable editbuf_linenum_submitted + variable editbuf_active_index + # --- + + variable reading + variable done + set done 0 + variable startinstance + variable loopinstance + if {[namespace exists ::punkapp]} { + #review - document ? + if {[dict exists $args -defaultresult]} { + set ::punkapp::default_result [dict get $args -defaultresult] + } + } + incr startinstance + set loopinstance 0 + if {[info exists ::punk::ns::ns_current]} { + set start_in_ns $::punk::ns::ns_current + } else { + set start_in_ns :: + } + thread::send $codethread [string map [list %ns1% $start_in_ns] { + #set ::punk::repl::codethread::running 1 + + #the interp in which commands such as d/ run + #we need to namespace eval for the -safe interp which may not have the packages loaded (or be able to) but still needs default values + #punk::repl::codethread::running is required whether safe or not. + interp eval code { + namespace eval ::punk::repl::codethread {} + set ::punk::repl::codethread::running 1 + namespace eval ::punk::ns::ns_current {} + set ::punk::ns::ns_current %ns1% + } + }] + set commandstr "" + + # --- + set editbuf [punk::repl::class::class_editbuf new {}] + lappend editbuf_list $editbuf ;#current editbuf is always in the history + set editbuf_linenum_submitted 0 + set editbuf_active_index 0 + # --- + + if {$::punk::console::ansi_wanted == 2} { + if {[::punk::console::test_can_ansi]} { + set ::punk::console::ansi_wanted 1 + } else { + set ::punk::console::ansi_wanted -1 + } + } + puts stderr "-->repl::start active on $inchan $args replthread:[thread::id] codethread:$codethread" + set prompt_config [punk::repl::get_prompt_config] + doprompt "P% " + fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] + set reading 1 + + #catch { + # set punk::console::tabwidth [punk::console::get_tabstop_apparent_width] + #} + vwait [namespace current]::done + fileevent $inchan readable {} + + + #puts stderr "-->start done = $::repl::done" + #todo - override exit? + #after 0 ::repl::post_operations + after idle ::repl::post_operations + vwait repl::post_operations_done + #puts stderr "-->start post_operations_done = $::repl::post_operations_done" + if {[namespace exists ::punkapp]} { + #todo check and get punkapp::result array - but what key? + if {[info exists ::punkapp::result(shell)]} { + set temp $::punkapp::result(shell) + unset ::punkapp::result(shell) + return $temp + } elseif {[info exists ::punkapp::default_result]} { + set temp $::punkapp::default_result + unset ::punkapp::default_result + return $temp + } + } + + + variable codethread_cond + if {[catch { + tsv::unset codethread_$codethread + } errM]} { + puts stderr " repl::start temp warning - $errM" + } + thread::cancel $codethread + thread::cond destroy $codethread_cond ;#race if we destroy cond before child thread has exited - as it can send a -async quit + set codethread "" + set codethread_cond "" + punk::console::mode line ;#review - revert to line mode on final exit - but we may be exiting a nested repl + puts "end repl::start" + return 0 +} +proc repl::post_operations {} { + if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { + #put aside post_script so the script has the option to add another post_script and restart the repl + set ::repl::running_script $::repl::post_script + set ::repl::post_script "" + uplevel #0 {eval $::repl::running_script} + } + #todo - tidyup so repl could be restarted + set ::repl::post_operations_done 0 +} + + +proc repl::reopen_stdin {} { + #variable reopen_stdin_attempts + if {$::tcl_platform(platform) eq "windows"} { + puts stderr "|repl> Attempting reconnection of console to stdin by opening 'CON'" + } else { + puts stderr "|repl> Attempting reconnection of console to stdin by opening '/dev/tty'" + } + #puts stderr "channels:[chan names]" + #flush stderr + #catch {chan close stdin} + chan close stdin + + if {$::tcl_platform(platform) eq "windows"} { + #set s [open "CON" r] + set s [open {CONIN$} r] + if {[package provide twapi] ne ""} { + set h [twapi::get_tcl_channel_handle $s in] + twapi::SetStdHandle -10 $h + } + puts stderr "restarting repl on inputchannel:$s" + return [repl::start $s -title "reopen_stdin a"] + } else { + #/dev/tty - reference to the controlling terminal for a process + #review/test + set s [open "/dev/tty" r] + } + + repl::start stdin -title "reopen_stdin b" +} + +#todo - avoid putting this in gobal namespace? +#collisions with other libraries apps? +proc punk::repl::quit {args} { + set ::repl::done "quit {*}$args" + #puts stderr "quit called" + return "" ;#make sure to return nothing so "quit" doesn't land on stdout +} + +#just a failed experiment.. tried various things +proc repl::reopen_stdinX {} { + #windows - todo unix + package require twapi + + if 0 { + if {[catch {package require Memchan} errM]} { + #package require tcl::chan::fifo2 + #lassign [tcl::chan::fifo2] a b + package require tcl::chan::fifo + set x [tcl::chan::fifo] + } else { + #lassign [fifo2] a b + set x [fifo] + } + #first channel opened after stdin closed becomes stdin + #use a fifo or fifo2 because [chan pipe] assigns the wrong end first! + #a will be stdin + } + #these can't replace proper stdin (filehandle 0) because they're not 'file backed' or 'os level' + #try opening a named pipe server to become stdin + set pipename {\\.\pipe\stdin_%id%} + set pipename [string map [list %id% [pid]] $pipename] + + + + package require tcl::chan::fifo + + chan close stdin + lassign [tcl::chan::fifo] a + + + puts stderr "newchan: $a" + puts stderr "|test> $a [chan conf $a]" + + #set server [twapi::namedpipe_server $pipename] + #set client [twapi::namedpipe_client $pipename] ;#open a client and connect to the server we just made + + puts stderr "chan names: [chan names]" + + #by now $server not valid? + #set server stdin + + #chan configure $server -buffering line -encoding unicode + #chan configure $client -buffering line -encoding unicode + + #puts stderr "|test>ns-server $server [chan conf $server]" + #puts stderr "|test>ns-client $client [chan conf $client]" + + set conin [twapi::get_console_handle stdin] + twapi::set_standard_handle stdin $conin + + set h_in [twapi::get_standard_handle stdin] + + puts stderr "|test> $a [chan conf $a]" + + #chan configure $client -blocking 0 + after 2 repl::start $a + +} + +#add to sliding buffer of last x chars emmitted to screen by repl +#(we could maintain only one char - more kept merely for debug assistance) +#will not detect emissions from exec with stdout redirected and presumably some extensions etc +proc repl::screen_last_char_add {c what {why ""}} { + variable screen_last_chars + variable screen_last_char_list + if {![string length $c]} { + return [string index $screen_last_chars end] + } + if {[string length $screen_last_chars] > 10} { + set screen_last_chars [string range $screen_last_chars 1 end] ;#evict first char + set screen_last_char_list [lrange $screen_last_char_list 1 end] + } + append screen_last_chars $c + lappend screen_last_char_list [list $c $what $why] + #return [string index $screen_last_chars end] + #return [lindex $screen_last_char_list 0 0] + return [lindex $screen_last_char_list end 0] +} +proc repl::screen_last_char_get {} { + variable screen_last_char_list + return [lindex $screen_last_char_list end 0] +} +proc repl::screen_last_char_getinfo {} { + variable screen_last_char_list + return [lindex $screen_last_char_list end] +} + +#-------------------------------------- +#another experiment +proc repl::newout {} { + namespace eval ::replout { + namespace ensemble create -map { + initialize init + finalize close + watch watch + write write + } + } + proc ::replout::init {id mode} { + return {initialize finalize watch write} + } + proc ::replout::close {id} { + + } + proc ::replout::watch {id spec} { + + } + proc ::replout::write {id data} { + puts -nonewline stderr $data + return [string length $data] + } + + close stdout + set fd [chan create write ::replout] + chan configure $fd -buffering none + return $fd +} +interp alias {} newout {} repl::newout +proc repl::newout2 {} { + close stdout + set s [open "CON" w] + chan configure $s -buffering none +} +#-------------------------------------- + +proc repl::doprompt {prompt {col {green bold}}} { + #prompt to stderr. + #We can pipe commands into repl's stdin without the prompt interfering with the output. + #Although all command output for each line goes to stdout - not just what is emitted with puts + + if {$::tcl_interactive} { + flush stdout; #we are writing this prompt on stderr, but stdout could still be writing to screen + #our first char on stderr is based on the 'lastchar' of stdout which we have recorded but may not have arrived on screen. + #The issue we're trying to avoid is the (stderr)prompt arriving midway through a large stdout chunk + #REVIEW - this basic attempt to get stderr/stdout to cooperate is experimental and unlikely to achieve the desired effect in all situations + #It the above flush does seem to help though. + #note that our 'flush stdout' tcl call does not wait if stdout is non-blocking + #todo - investigate if the overhead is reasonable for a special channel that accepts stdout and stderr records with a reader to send to console in chunk-sizes we know will be emitted correctly + # - reader of such channel could be ok to be blocking (on read? on write to real channels?)... except everything still needs to be interruptable by things like signals? + #? - we want ordinary puts to stderr to be prioritized? to arrive on-screen - just not at arbitrary locations within stdout, and still must be correctly ordered wrt all other stderr + # - in our repl and code threads we don't want to put stderr/stdout writes in blocking mode and have code waiting on it + + set last_char_info [screen_last_char_getinfo] + if {![llength $last_char_info]} { + set needs_clearance 1 + } else { + lassign $last_char_info c what why + if {$why eq "prompt"} { + set needs_clearance 0 + } else { + set needs_clearance [screen_needs_clearance] + #puts -nonewline "-->$needs_clearance $last_char_info" + } + } + if {$needs_clearance == 1} { + set c \n + } else { + set c "" + } + set pre "" + if {[string first \n $prompt] >=0} { + set plines [split $prompt \n] + set pre [join [lrange $plines 0 end-1] \n]\n + set prompt [lindex $plines end] + } + + #this sort of works - but steals some of our stdin data ? review + # + #lassign [punk::console::get_cursor_pos_list] column row + #if {$row != 1} { + # set c "\n" + #} + + set o [a {*}$col] + set r [a] + puts -nonewline stderr $c$pre$o$prompt$r + screen_last_char_add " " "prompt-stderr" prompt + flush stderr + } +} + +#use rputs in repl_handler instead of puts +# - to help ensure we don't emit extra blank lines in info or debug output +#rputs expects the standard tcl 'puts' command to be in place. +# all bets are off if this has been redefined with some other api +# rputs deliberately doesn't check screen_last_chars before emitting data (unless reporting an error in rputs itself) +proc repl::rputs {args} { + variable screen_last_chars + variable last_out_was_newline + variable last_repl_char + + set pseudo_map [dict create\ + debug stderr\ + debugreport stderr\ + ] + + if {[::tcl::mathop::<= 1 [llength $args] 3]} { + set out [lindex $args end] + append out ""; #copy on write + if {([llength $args] > 1) && [lindex $args 0] ne "-nonewline"} { + set this_tail \n + set rputschan [lindex $args 0] + #map pseudo-channels to real + if {$rputschan in [dict keys $pseudo_map]} { + lset args 0 [dict get $pseudo_map $rputschan] + } + } elseif {[llength $args] == 1} { + set this_tail \n + set rputschan "stdout" + } else { + #>1 arg with -nonewline + set this_tail [string index $out end] + set rputschan [lindex $args 1] + #map pseudo-channels to real + if {$rputschan in [dict keys $pseudo_map]} { + lset args 0 [dict get $pseudo_map $rputschan] + } + } + set last_char_info_width 60 + #review - string shouldn't be truncated prior to stripcodes - could chop ansi codes! + #set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" + set out_plain_text [punk::ansi::ansistrip $out] + set summary [string range $out_plain_text 0 $last_char_info_width] + if {[string length $summary] > $last_char_info_width} { + append summary " ..." + } + + #make sure we use supplied rputschan in the screen_las_char_add 'what' - which may not be the underlying chan if it was a pseudo + screen_last_char_add $this_tail repl-$rputschan $summary + + try { + puts {*}$args + } on error {repl_error erropts} { + #possible error depending on -encoding and -profile of the channel + #(e.g -profile strict) + + #REVIEW + #TODO - something better + #failure case: + #set x \ud83c\udf1e + #(2 surrogate pairs - treated as single char in tcl8 - fixed in 9 but won't/can't be backported) - + #see also: https://core.tcl-lang.org/tips/doc/trunk/tip/619.md + puts stderr "$repl_error" + } + } else { + #looks like an invalid puts call - use the normal error produced by the puts command + #This should only occur if the repl itself is being rewritten/debugged, + #so we will use red "!" and not worry about the extra newlines before and after + if {[catch { puts {*}$args } err]} { + set c [a yellow bold] + set n [a] + #possibly non punk-compliant output because we're assuming the repl was the most recent emitter + #could be wrong, in which case we may emit an extra newline + #- shouldn't matter in this case + #set last_char [string range $screen_last_chars end] + set last_char [screen_last_char_get] + if {$last_char eq "\n"} { + set clear "" + } else { + set clear "\n" + } + puts -nonewline stderr "$clear[a red bold]! REPL ERROR IN rputs $c$err$n\n" + screen_last_char_add "\n" replerror "rputs err: '$err'" + return + } else { + #?? shouldn't happen with standard puts command + #do our best and assume final arg is still the data being emitted + #worst that will happen is we won't detect a trailing newline and will later emit an extra blank line. + set out [lindex $args end] + set this_tail [string index $out end] + screen_last_char_add $this_tail replunknown "rputs $args" + return + } + } +} +#whether we need a newline as clearance from previous output +#review - race with copy pasted data, hold-down of enter key +# and data from external process or background script that doesn't go through our stdout filter +#we probably can't use get_cursor_pos - as that needs to emit to stdout and read-loop on stdin which will possibly? make things worse +proc repl::screen_needs_clearance {} { + variable screen_last_chars + + #set last_char [string index $screen_last_chars end] + set last_char_info [screen_last_char_getinfo] + if {![llength $last_char_info]} { + #assumption + return 1 + } + lassign $last_char_info c what why + switch -- $what { + stdout - stderr - stdout/stderr { + return 1 + } + } + return [expr {$c ne "\n"}] +} + +namespace eval repl { + variable startinstance 0 + variable loopinstance 0 + variable in_repl_handler [list] + variable last_controlc_count 0 +} + +namespace eval punk::repl::class { + oo::class create class_bufman { + + } + + #multiline editing buffer + oo::class create class_editbuf { + variable o_context + variable o_config + + variable o_rendered_lines + variable o_remaining ;#? + + #o_chunk_list & o_chunk_info should make timed viewing of replays possible + variable o_chunk_list + variable o_chunk_info ;#arrival timing etc + variable o_cursor_row + variable o_cursor_col + variable o_insert_mode + constructor {configdict {contextdict {}}} { + my clear + set o_config $configdict + if {[dict exists $configdict rendered_initialchunk]} { + #pre-rendered initial chunk + #-- + set o_chunk_list "" ;#replace empty chunk from 'clear' call + set o_chunk_info [dict create] + #-- + set ch [dict get $configdict rendered_initialchunk] + my add_rendered_chunk $ch + } + + set o_context $contextdict + #error "[self class].constructor Unable to interpret config '$o_config'" + } + method cursor_row {} { + return $o_cursor_row + } + method cursor_column {} { + return $o_cursor_col + } + method insert_mode {} { + return $o_insert_mode + } + method clear {} { + set o_rendered_lines [list ""] + set o_chunk_list [list] + set o_chunk_info [dict create] + set o_cursor_row 1 + set o_cursor_col 1 + set o_insert_mode 1 ;#default to insert mode + lappend o_chunk_list "" + dict set o_chunk_info 0 [dict create micros [clock microseconds] type rendered] + } + method add_chunk {chunk} { + #we still split on lf - but each physical line may contain horizontal or vertical movements so we need to feed each line in and possibly get an overflow_right and unapplied and cursor-movent return info + lappend o_chunk_list $chunk ;#may contain newlines,horizontal/vertical movements etc - all ok + dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type raw] + if {$chunk eq ""} { + return + } + + set firstnl [string first \n $chunk] + set newparts [split $chunk \n] + #attempt to render new 'lines' into the editbuffer - taking account of active cursor row & col & insertmode + + #merge based on current cursor row and col + #set lastrline [lindex $o_rendered_lines end] + #set n0 [lindex $newparts 0] + #set merged0 [string cat $lastrline $n0] + + #we should merge first row of newparts differently in case our chunks split a grapheme-combination? + # + if {$o_cursor_row < 1} { + puts stderr "add_chunk warning cursor_row < 1 - changing to minimum value 1" + set o_cursor_row 1 + } + set cursor_row_idx [expr {$o_cursor_row -1}] + set activeline [lindex $o_rendered_lines $cursor_row_idx] + set new0 [lindex $newparts 0] + #set combined [string cat $activeline $new0] + #use -cursor_row to tell renderline it's row context. + if {$firstnl >=0} { + #append combined \n + append new0 \n + } + set underlay [punk::ansi::ansistrip $activeline] + set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] + if {$o_cursor_col > $line_nextchar_col} { + set o_cursor_col $line_nextchar_col + } + + set mergedinfo [overtype::renderline -info 1 -expand_right 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $new0] + + set result [dict get $mergedinfo result] + set o_insert_mode [dict get $mergedinfo insert_mode] + set result_col [dict get $mergedinfo cursor_column] + set result_row [dict get $mergedinfo cursor_row] + set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v + set unapplied [dict get $mergedinfo unapplied] + set instruction [dict get $mergedinfo instruction] + + set insert_lines_below [dict get $mergedinfo insert_lines_below] + set insert_lines_above [dict get $mergedinfo insert_lines_above] + + # -- --- --- --- --- --- + set debug_first_row 2 + #puts "merged: $mergedinfo" + set debug "add_chunk0" + append debug \n $mergedinfo + append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col" + package require textblock + set debug [textblock::frame -checkargs 0 -buildcache 0 $debug] + if {![punk::console::vt52]} { + catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} + } else { + #?? + } + # -- --- --- --- --- --- + + set o_cursor_col $result_col + set cursor_row_idx [expr {$o_cursor_row-1}] + lset o_rendered_lines $cursor_row_idx $result + + set nextrow $result_row + switch -- $instruction { + lf_start { + #for normal commandline - we just add a line below + lappend o_rendered_lines "" + incr nextrow + set o_cursor_col 1 + } + } + + if {$insert_lines_below == 1} { + if {[string length $overflow_right]} { + lappend o_rendered_lines $overflow_right + set o_cursor_col [expr {[punk::ansi::printing_length $overflow_right] +1}] + } else { + lappend o_rendered_lines "" + set o_cursor_col 1 + } + } elseif {$insert_lines_above == 1} { + #for {set i 0} {$i < $insert_lines_above} {incr i} { + # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + # incr nextrow -1 + #} + set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + set o_cursor_col 1 + } + + set o_cursor_row $nextrow + set cursor_row_idx [expr {$o_cursor_row-1}] + if {$cursor_row_idx < [llength $o_rendered_lines]} { + set activeline [lindex $o_rendered_lines $cursor_row_idx] + } else { + lappend o_rendered_lines "" + set activeline "" + } + + + set i 1 + foreach p [lrange $newparts 1 end] { + if {$i < [llength $newparts]-1} { + append p \n + } else { + if {$p eq ""} { + break + } + } + #puts stderr "overtype::renderline -info 1 -expand_right 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $activeline '$p'" + set underlay $activeline + set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] + if {$o_cursor_col > $line_nextchar_col} { + set o_cursor_col $line_nextchar_col + } + set mergedinfo [overtype::renderline -info 1 -expand_right 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $p] + set debug "add_chunk$i" + append debug \n $mergedinfo + append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $p]" + set debug [textblock::frame -checkargs 0 -buildcache 0 $debug] + #catch {punk::console::move_emitblock_return [expr {$debug_first_row + ($i * 6)}] 1 $debug} + + set result [dict get $mergedinfo result] + set o_insert_mode [dict get $mergedinfo insert_mode] + set o_cursor_col [dict get $mergedinfo cursor_column] + set cmove [dict get $mergedinfo cursor_row] + set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v + set unapplied [dict get $mergedinfo unapplied] + set insert_lines_below [dict get $mergedinfo insert_lines_below] + if {[string is integer -strict $cmove]} { + if {$cmove == 0} { + set nextrow [expr {$o_cursor_row + 1}] + set o_cursor_col 1 + } elseif {$cmove == 1} { + #check for overflow_right and unapplied + #leave cursor_column + } elseif {$cmove >= 1} { + + } + + } else { + # = - absolute + set nextrow [string range $cmove 1 end] + } + if {$nextrow eq $o_cursor_row} { + incr nextrow + } + set o_cursor_row $nextrow + if {$insert_lines_below} { + + } + + set cursor_row_idx [expr {$o_cursor_row-1}] + if {$cursor_row_idx < [llength $o_rendered_lines]} { + set activeline [lindex $o_rendered_lines $cursor_row_idx] + } else { + lappend o_rendered_lines "" + set activeline "" + } + lset o_rendered_lines $cursor_row_idx $result + + incr i + } + + } + method add_rendered_chunk {rchunk} { + #split only on lf newlines - movement codes and \b \v \r not expected + #check only for \v \r as chars we don't expect/want in rendered lines + #chunk as been pre-rendered (or is known to be plain ascii without ANSI or \b \v \r) + #but we don't yet have grapheme split info for it + + if {[regexp {[\v\b\r]} $rchunk]} { + error "[self class].add_rendered_chunk chunk contains \\v or \\b or \\r. Rendered chunk shouldn't contain these characters or ANSI movement codes" + } + lappend o_chunk_list $rchunk ;#rchunk may contain newlines - that's ok + dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type rendered] + + set newparts [split $rchunk \n] + #lappend o_chunk_list $rchunk + set lastrline [lindex $o_rendered_lines end] + + #in renderedlines list merge last line of old with first line of new + #we can't just cat the newpart on to existing rendered line - the chunk could have split a grapheme (e.g char+combiner(s)) + #we + #todo - redo grapheme split on merged line + set merged [string cat $lastrline [lindex $newparts 0]] + lset o_rendered_lines end $merged + + #todo + #each newpart needs its grapheme split info to be stored + #jmn + #set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] + lappend o_rendered_lines {*}[lrange $newparts 1 end] + + } + method linecount {} { + return [llength $o_rendered_lines] + } + method line {idx} { + if {[string is integer -strict $idx]} { + incr idx -1 + } + return [lindex $o_rendered_lines $idx] + } + method lines {args} { + switch -- [llength $args] { + 0 {return $o_rendered_lines} + 1 { + set idx [lindex $args 0] + if {[string is integer -strict $idx]} { + incr idx -1 + } + return [list [lindex $o_rendered_lines $idx]] + } + 2 { + lassign $args idx1 idx2 + if {[string is integer -strict $idx1]} { + incr idx1 -1 + } + if {[string is integer -strict $idx2]} { + incr idx2 -1 + } + return [lrange $o_rendered_lines $idx1 $idx2] + } + default {error "lines expected 0,1 or 2 indices"} + } + } + + #todo - index base??? + method lines_numbered {args} { + #build a paired list so we don't have to do various calcs on end+ end- etc checking llength + #punk::lib::range will use lseq if available - else use it's own slower code + set max [llength $o_rendered_lines] ;#assume >=1 + set nums [punk::lib::range 1 $max] + set numline_list [list] + foreach n $nums ln $o_rendered_lines { + lappend numline_list [list $n $ln] + } + + switch -- [llength $args] { + 0 {return $numline_list} + 1 {return [lindex $numline_list [lindex $args 0]]} + 2 {return [lrange $numline_list {*}$args]} + default {error "lines expected 0,1 or 2 indices"} + } + } + + #1-based + method delete_line {linenum} { + error "unimplemented" + if {$linenum eq "end"} { + set linenum [llength $o_rendered_lines] + } + if {![string is integer -strict $linenum]} { + error "delete_line accepts only end or an integer from 1 to linecount" + } + if {$linenum == 0} { + error "minimum line is 1" + } + set o_rendered_lines [lreplace $o_rendered_lines $index $index] + } + #clear data from last line only + method clear_tail {} { + set o_cursor_row [llength $o_rendered_lines] + set o_cursor_col 1 + lset o_rendered_lines end "" + } + #1-based + method view_lines {args} { + set llist [my lines {*}$args] + return [join $llist \n] + } + method view_lines_numbered {args} { + set ANSI_linenum [a+ green] + set RST [a] + set llist [my lines_numbered {*}$args] + set nums [lsearch -all -inline -index 0 -subindices $llist *] + lset nums $o_cursor_row-1 "[a+ bold underline]$o_cursor_row${RST}$ANSI_linenum" + set lines [lsearch -all -inline -index 1 -subindices $llist *] + + set cursorline [lindex $lines $o_cursor_row-1] + set charindex_at_cursor [ansistring COLUMNINDEX $cursorline $o_cursor_col] + if {$charindex_at_cursor ne ""} { + lassign [ansistring INDEXCOLUMNS $cursorline $charindex_at_cursor] col0 col1 + #we now have the column extents of the possibly double-wide character at the cursor + #we can apply ansi just to those columns using a transparent overtype + set prefix [string repeat " " [expr {$col0 -1}]] + set linecols [punk::ansi::printing_length $cursorline] + set suffix [string repeat " " [expr {$linecols -$col1}]] + #capitalised INDEX - for grapheme/control-char index e.g a with diacritic a\u0300 has a single index + set char_at_cursor [ansistring INDEX $cursorline $charindex_at_cursor] ;#this is the char with appropriate ansireset codes + set rawchar [punk::ansi::ansistrip $char_at_cursor] + if {$rawchar eq " "} { + set charhighlight "[punk::ansi::a+ White]_[a]" + } else { + set charhighlight [punk::ansi::a+ reverse]$char_at_cursor[a] + } + set cursorline [overtype::renderline -transparent 1 -insert_mode 0 -expand_right 0 $cursorline $prefix$charhighlight$suffix] + lset lines $o_cursor_row-1 $cursorline + } + + set numcol "$ANSI_linenum[join $nums \n][a]" + set linecol [join $lines \n] + return [textblock::join -- $numcol " " $linecol] + } + method debugview_lines {} { + set result "" + foreach ln $o_rendered_lines { + append result [ansistring VIEW -lf 1 -vt 1 $ln] \n ;#should be no lf or vt - but if there is.. we'd better show it + } + append result \n "cursor row: $o_cursor_row col: $o_cursor_col" + return $result + } + method last_char {} { + return [string index [lindex $o_chunk_list end] end] + } + + #more strictly - last non-ansi? + method last_grapheme {} { + set lastchunk [lindex $o_chunk_list end] + set plaintext_parts [punk::ansi::ta::split_at_codes $lastchunk] + set pt [lindex $plaintext_parts end] + if {$pt eq ""} { + set pt [lindex $plaintext_parts end-1] + } + set graphemes [punk::char::grapheme_split $pt] + return [lindex $graphemes end] + } + method last_ansi {} { + set lastchunk [lindex $o_chunk_list end] + set parts [punk::ansi::ta::split_codes_single $lastchunk] + set lastcode [lindex $parts end-1] + return $lastcode + #return [ansistring VIEW -lf 1 $lastcode] + } + method chunks {args} { + switch -- [llength $args] { + 0 {return $o_chunk_list} + 1 {return [lindex $o_chunk_list [lindex $args 0]]} + 2 {return [lrange $o_chunk_list {*}$args]} + default {error "chunks expected 0,1 or 2 arguments (index or range)"} + } + } + method view_chunks {} { + set result "" + set dashes [string repeat - 20] + foreach arrival_chunk $o_chunk_list chunk_id [dict keys $o_chunk_info] { + set chunk_info [dict get $o_chunk_info $chunk_id] + append result $dashes \n + set micros [dict get $chunk_info micros] + append result "$chunk_id arrival: [clock format [expr {$micros / 1000000}] -format "%Y-%m-%d %H:%M:%S"] ($micros)" \n + append result $dashes \n + append result $arrival_chunk \n + } + return $result + } + + method debugview_chunks {} { + set result "" + foreach ln $o_chunk_list { + append result [ansistring VIEW -lf 1 -vt 1 $ln] \n + } + append result \n "cursor row: $o_cursor_row col: $o_cursor_col" + return $result + } + method view_raw {} { + return [join $o_chunk_list ""] + } + method debugview_raw {} { + set sublf [ansistring VIEW -lf 1 \n] + #set subvt [ansistring VIEW -lvt 1 \v] ;#vt replacement with $subvt\v will not align accurately.. todo ? + return [string map [list $sublf $sublf\n] [ansistring VIEW -lf 1 -vt 0 [join $o_chunk_list ""]]] + } + } + +} + +proc ::punk::repl::repl_handler_checkchannel {inputchan} { + if {[catch {chan eof $inputchan} is_eof]} { + ::repl::rputs stderr "\n|repl> repl_handler_checkchannel error on $inputchan. (closed?) msg:$is_eof" + } else { + if {$is_eof} { + if {$::tcl_interactive} { + ::repl::rputs stderr "\n|repl> repl_handler_checkchannel EOF on $inputchan." + } + } + } +} +proc ::punk::repl::repl_handler_checkcontrolsignal_linemode {inputchan} { + #todo - what? + return + variable signal_control_c + if {$signal_control_c > 0} { + if {$::tcl_interactive} { + ::repl::rputs stderr "\n|repl> repl_handler_checkcontrolsignal_linemode ctrl-c errorCode 0: [lindex $::errorCode 0]" + } + } +} + +#This is not called from the signal handler - so we can't affect the signal handling with return +# +proc ::punk::repl::repl_handler_checkcontrolsignal_rawmode {inputchan} { + variable signal_control_c + variable signal_control_c_msg + if {$signal_control_c > 0 && $signal_control_c_msg ne "" } { + #if {$::tcl_interactive} { + # ::repl::rputs stderr "\n|repl> repl_handler_checkcontrolsignal_rawmode ctrl-c errorCode 0: [lindex $::errorCode 0]" + #} + set msg $signal_control_c_msg + set signal_control_c_msg "" + } else { + set msg "" + } + return [list count $signal_control_c msg $msg] +} + + +proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_input_state} { + if {$inputchan ni [chan names] || [eof $inputchan]} { + return + } + if {[chan conf $inputchan] ne $previous_input_state} { + set restore_input_conf [dict remove $previous_input_state -inputmode] ;#Attempting to set input mode often gives permission denied on windows - why? + if {[catch { + chan conf $inputchan {*}$restore_input_conf + } errM]} { + rputs stderr "|repl>original: [ansistring VIEW $previous_input_state]" + rputs stderr "|repl>current : [ansistring VIEW [chan conf $inputchan]]" + rputs stderr "\n|repl> Failed to return $inputchan to original state" + rputs stderr "|repl>ERR: $errM" + } + } + return [chan conf $inputchan] +} +proc repl::repl_handler {inputchan prompt_config} { + # -- review + variable in_repl_handler + set in_repl_handler [list $inputchan $prompt_config] + # -- + variable last_controlc_count + + upvar ::punk::repl::prompt_reset_flag prompt_reset_flag + if {$prompt_reset_flag == 1} { + set prompt_config [punk::repl::get_prompt_config] + set prompt_reset_flag 0 + } + + fileevent $inputchan readable {} + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + #note -inputmode not available in Tcl 8.6 for chan configure! + #According to DKF - -buffering option doesn't affect input channels + set rawmode 0 + set original_input_conf [chan configure $inputchan] ;#whether repl is in line or raw mode - we restore the inputchan (stdin) state + if {[dict exists $original_input_conf -inputmode]} { + if {[dict get $original_input_conf -inputmode] eq "raw"} { + #user or script has apparently put stdin into raw mode - update punk::console::is_raw to match + set rawmode 1 + #set ::punk::console::is_raw 1 + tsv::set console is_raw 1 + } else { + #set ::punk::console::is_raw 0 + tsv::set console is_raw 0 + } + #what about enable/disable virtualTerminal ? + #using stdin -inputmode to switch modes won't set virtualterminal input state appropriately + #we expect the state of -inputmode to be 'normal' even though we flip it during the read part of our repl loop + #if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal + #by not doing this automatically - we assume the caller has a reason. + } else { + #JMN FIX! + #this returns 0 in rawmode on 8.6 after repl thread changes + #set rawmode [set ::punk::console::is_raw] + set rawmode [tsv::get console is_raw] + } + + if {!$rawmode} { + #linemode + + #stdin with line-mode readable events (at least on windows for Tcl 8.7a6 to 9.0a) can get stuck with bytes pending when input longer than 100chars - even though there is a linefeed further on than that. + #This potentially affects a reasonable number of Tcl8.7 kit/tclsh binaries out in the wild. + #see bug https://core.tcl-lang.org/tcl/tktview/bda99f2393 (gets stdin problem when non-blocking - Windows) + #when in non-blocking mode we will have to read that in to get further - but we don't know if that was the end of line or if there is more - and we may not get a newline even though one was present originally on stdin. + #presence of 8.7 buffering bug will result in unrecoverable situation - even switching to raw and using read will not be able to retrieve tail data. + #the readable event only gives us 200 bytes (same problem may be at 4k/8k in other versions) + #This occurs whether we use gets or read - + set stdinlines [list] + if {[dict get $original_input_conf -blocking] ne "0"} { + chan configure $inputchan -blocking 0 + } + + set waitingchunk "" + #review - input_chunks_waiting in line mode - + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + #puts stderr "repl_handler input_chunks_waiting($inputchan) while in line mode. Had data:[ansistring VIEW -lf 1 $input_chunks_waiting($inputchan)]" + set allwaiting [join $input_chunks_waiting($inputchan) ""] + set input_chunks_waiting($inputchan) [list] + set yellow [punk::ansi::a+ yellow bold] + set waitinglines [split $allwaiting \n] + foreach ln [lrange $waitinglines 0 end-1] { + lappend stdinlines $ln + } + set waitingchunk [lindex $waitinglines end] + # -- + #set chunksize [gets $inputchan chunk] + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- + if {$chunksize > 0} { + if {[string index $chunk end] eq "\n"} { + lappend stdinlines $waitingchunk[string range $chunk 0 end-1] + #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" + + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + set input_chunks_waiting($inputchan) [list $allwaiting] + lappend input_chunks_waiting($inputchan) $chunk + } + } else { + #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' + if {[chan blocked $inputchan]} { + #REVIEW - + #todo - figure out why we're here. + #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) + #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? + ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows + set outconf [chan configure stdout] + set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] + if {"windows" eq $::tcl_platform(platform)} { + set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + } else { + set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" + } + set cols "" + set rows "" + if {[dict exists $outconf -winsize]} { + lassign [dict get $outconf -winsize] cols rows + } else { + #fallback - try external executable. Which is a bit ugly + #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) + + #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 + #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! + #stty -a is 400ms+ vs 500us+ on FreeBSD + + if {"windows" eq $::tcl_platform(platform)} { + set tputcmd [auto_execok tput] + if {$tputcmd ne ""} { + if {![catch {exec {*}$tputcmd cols lines} values]} { + lassign $values cols rows + } + } + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + #same for all platforms? tested on windows, wsl, FreeBSD + #exec stty -a gives a result on the first line like: + #speed xxxx baud; rows rr; columns cc; + #review - more robust parsing - do we know it's first line? + set sttycmd [auto_execok stty] + if {$sttycmd ne ""} { + #the more parseable: stty -g doesn't give rows/columns + if {![catch {exec {*}$sttycmd -a} result]} { + lassign [split $result \n] firstline + set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? + set rowinfo [lsearch -index end -inline $lineparts rows] + if {[llength $rowinfo] == 2} { + set rows [lindex $rowinfo 0] + } + set colinfo [lsearch -index end -inline $lineparts columns] + if {[llength $colinfo] == 2} { + set cols [lindex $colinfo 0] + } + } + } + } + } + if {[string is integer -strict $cols] && [string is integer -strict $rows]} { + #got_dimensions - todo - try spinner? + #puts -nonewline stdout [punk::ansi::move $rows 4]$msg + #use cursorsave_ version which avoids get_cursor_pos_list call + set msglen [ansistring length $msg] + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg + } else { + #no mechanism to get console dimensions + #we are reduced to continuously spewing lines. + puts stderr $msg + } + + after 100 + } + set input_chunks_waiting($inputchan) [list $allwaiting] + } + + } else { + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan + # -- --- --- + #set chunksize [gets $inputchan chunk] + # -- --- --- + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- --- --- + if {$chunksize > 0} { + #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" + set ln $chunk ;#temp + #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] + if {[string index $ln end] eq "\n"} { + lappend stdinlines [string range $ln 0 end-1] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + lappend input_chunks_waiting($inputchan) $ln + } + } + } + + } else { + #rawmode + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + #we could concat and process as if one chunk - but for now at least - we want to preserve the 'chunkiness' + set chunkwaiting_zero [lpop input_chunks_waiting($inputchan) 0] ;#pop off lhs of wait list (tcl 8.6 is tcl imp of lpop - a little slower) + uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $chunkwaiting_zero [list] $prompt_config] + } else { + + punk::repl::repl_handler_checkchannel $inputchan + set signalinfo [punk::repl::repl_handler_checkcontrolsignal_rawmode $inputchan] + if {[dict get $signalinfo count] > $last_controlc_count} { + set continue 0 + set last_controlc_count [dict get $signalinfo count] + } else { + set continue 1 + } + + if {$continue} { + if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { + chan configure $inputchan -blocking 0 + chan configure $inputchan -translation lf + } + set chunk [read $inputchan] + #we expect a chan configured with -blocking 0 to be blocked immediately after reads + #test - just bug console for now - try to understand when/how/if a non blocking read occurs. + if {![chan blocked $inputchan]} { + puts stderr "repl_handler->$inputchan not blocked after read" + } + + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + while {[llength $input_chunks_waiting($inputchan)]} { + set chunkzero [lpop input_chunks_waiting($inputchan) 0] + if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? + uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $chunkzero [list] $prompt_config] + } + } + } + } + + if {![chan eof $inputchan]} { + ################################################################################## + #Re-enable channel read handler only if no waiting chunks - must process in order + ################################################################################## + if {![llength $input_chunks_waiting($inputchan)]} { + fileevent $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + } else { + after idle [list ::repl::repl_handler $inputchan $prompt_config] + } + #################################################### + } else { + #repl_handler_checkchannel $inputchan + fileevent $inputchan readable {} + set reading 0 + thread::send -async $::repl::codethread {set ::punk::repl::codethread::running 0} + if {$::tcl_interactive} { + rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" + #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + } + set [namespace current]::done 1 + after 1 [list repl::reopen_stdin] + } + set in_repl_handler [list] +} + +proc punk::repl::editbuf {index args} { + set editbuf [lindex $::repl::editbuf_list $index] + if {$editbuf ne ""} { + $editbuf {*}$args + } else { + return "No such index in editbuf list" + } +} +interp alias {} editbuf {} ::punk::repl::editbuf + + +proc punk::repl::console_debugview {editbuf consolewidth args} { + if {[punk::console::vt52]} { + #topleft? + return [dict create width 0 height 0 topleft 0] + } + package require textblock + variable debug_repl + if {$debug_repl <= 0} { + return [dict create width 0 height 0 topleft {}] + } + set defaults {-row 10 -rightmargin 2 -chunktype raw-read} + #dict for {k v} $args { + # switch -- $k { + # -row - -chunktype {} + # default { + # error "console_debugview unrecognised option '$k'. Known-options [dict keys $defaults]" + # } + # } + #} + set opts [dict merge $defaults $args] + set opt_row [dict get $opts -row] + set opt_chunktype [dict get $opts -chunktype] + set opt_rightmargin [dict get $opts -rightmargin] + + #debugview_raw frame + set RST [a] + if {[catch { + set info [$editbuf debugview_raw] + if {$opt_chunktype eq "raw-waiting"} { + set info [a+ bold yellow]$info$RST + } else { + set info [a+ green]$info$RST + } + #set lines [lines_as_list -ansireplays 1 $info] + set lines [lines_as_list -ansireplays 0 $info] + if {[llength $lines] > 20} { + set lines [lrange $lines end-19 end] + set info [::join $lines \n] + } + set debug_height [expr {[llength $lines]+2}] ;#framed height + } errM]} { + set info [textblock::frame -checkargs 0 -buildcache 0 -title "[a red]error$RST" $errM] + set debug_height [textblock::height $info] + } else { + #treat as ephemeral (unreusable) frames due to varying width & height - therefore set -buildcache 0 + set info [textblock::frame -checkargs 0 -buildcache 0 -ansiborder [a+ bold green] -title "[a cyan]debugview_raw$RST" $info] + } + + set debug_width [textblock::widthtopline $info] + set patch_height [expr {2 + $debug_height + 2}] + set spacepatch [textblock::block $debug_width $patch_height " "] + #puts -nonewline [punk::ansi::cursor_off] + punk::console::cursor_off + #use non cursorsave versions - cursor save/restore will interfere with any concurrent ansi rendering that uses save/restore - because save/restore is a single item, not a stack. + set debug_offset [expr {$consolewidth - $debug_width - $opt_rightmargin}] + set row_clear [expr {$opt_row -2}] + punk::console::move_emitblock_return $row_clear $debug_offset $spacepatch + punk::console::move_emitblock_return $opt_row $debug_offset $info + set topleft [list $debug_offset $opt_row] ;#col,row REVIEW + #puts -nonewline [punk::ansi::cursor_on] + punk::console::cursor_on + flush stdout + + return [dict create width $debug_width height $debug_height topleft $topleft] +} +proc punk::repl::console_editbufview {editbuf consolewidth args} { + if {[punk::console::vt52]} { + return [dict create width 0] + } + package require textblock + upvar ::repl::editbuf_list editbuf_list + + set defaults {-row 10 -rightmargin 0} + set opts [dict merge $defaults $args] + set opt_row [dict get $opts -row] + set opt_rightmargin [dict get $opts -rightmargin] + + if {[catch { + set info [$editbuf view_lines_numbered] + set lines [lines_as_list -ansireplays 1 $info] + if {[llength $lines] > 20} { + set lines [lrange $lines end-19 end] + set info [punk::lib::list_as_lines $lines] + } + } editbuf_error]} { + set info [textblock::frame -checkargs 0 -buildcache 0 -title "[a red]error[a]" "$editbuf_error\n$::errorInfo"] + } else { + set title "[a cyan]editbuf [expr {[llength $editbuf_list]-1}] lines [$editbuf linecount][a]" + append title "[a+ yellow bold] col:[format %3s [$editbuf cursor_column]] row:[$editbuf cursor_row][a]" + set row1 " lastchar:[ansistring VIEW -lf 1 [$editbuf last_char]] lastgrapheme:[ansistring VIEW -lf 1 [$editbuf last_grapheme]]" + set row2 " lastansi:[ansistring VIEW -lf 1 [$editbuf last_ansi]]" + set info [a+ green bold]$row1\n$row2[a]\n$info + set info [textblock::frame -checkargs 0 -buildcache 0 -ansiborder [a+ green bold] -title $title $info] + } + set editbuf_width [textblock::widthtopline $info] + set spacepatch [textblock::block $editbuf_width 2 " "] + + #set editbuf_offset [expr {$consolewidth - $editbuf_width - $debug_width - 2}] + set editbuf_offset [expr {$consolewidth - $editbuf_width - $opt_rightmargin}] + + set row_clear [expr {$opt_row -2}] + punk::console::cursorsave_move_emitblock_return $row_clear $editbuf_offset $spacepatch + punk::console::cursorsave_move_emitblock_return $opt_row $editbuf_offset $info + + return [dict create width $editbuf_width] +} +proc punk::repl::console_controlnotification {message consolewidth consoleheight args} { + package require textblock + set defaults {-bottommargin 0 -rightmargin 0} + set opts [dict merge $defaults $args] + set opt_bottommargin [dict get $opts -bottommargin] + set opt_rightmargin [dict get $opts -rightmargin] + set messagelines [split $message \n] + set message [lindex $messagelines 0] ;#only allow single line + set info "[a+ bold red]$message[a]" + set hlt [dict get [textblock::framedef light] hlt] + set box [textblock::frame -checkargs 0 -boxmap [list tlc $hlt trc $hlt] -title $message -height 1] + set notification_width [textblock::widthtopline $info] + set box_offset [expr {$consolewidth - $notification_width - $opt_rightmargin}] + set row [expr {$consoleheight - $opt_bottommargin}] + punk::console::cursorsave_move_emitblock_return $row $box_offset $info + return [dict create width $notification_width] +} + +proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config} { + if {[info exists ::punk::console::is_vt52]} { + set is_vt52 $::punk::console::is_vt52 + } else { + set is_vt52 0 + } + + variable loopinstance + incr loopinstance + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + + upvar ::punk::repl::prompt_reset_flag prompt_reset_flag + + variable last_repl_char "" ;#last char emitted by this handler to stdout/stderr + variable lastoutchar "" + variable lasterrchar "" + variable commandstr + # --- + variable editbuf + variable editbuf_list + variable editbuf_linenum_submitted + + # --- + variable reading + variable id_outstack + upvar ::punk::config::running running_config + + try { + #catch {puts stderr "xx--->[rep $::arglej]"} + if {$prompt_reset_flag == 1} { + set prompt_config [punk::repl::get_prompt_config] + set prompt_reset_flag 0 + } + + set resultprompt [dict get $prompt_config resultprompt] + set nlprompt [dict get $prompt_config nlprompt] + set infoprompt [dict get $prompt_config infoprompt] + set debugprompt [dict get $prompt_config debugprompt] + + + #set rawmode [set ::punk::console::is_raw] + set rawmode [tsv::get console is_raw] + if {!$rawmode} { + #puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--" + + } else { + #raw + set chunklen [string length $chunk] + set onetime 1 + #single loop while to allow break on escape + while {$onetime && [string length $chunk] >= 0 } { + set onetime 0 + #punk::console::move_emitblock_return 20 120 $chunklen-->[chan conf stdin]<-- + + #if {$chunklen == 0} { + # #document examples of when we expect zero-byte chunk + # #1) ctrl-z + # #review + # rputs stderr "->0byte read stdin" + # if {[chan eof $inputchan]} { + # fileevent $inputchan readable {} + # set reading 0 + # #set running 0 + # if {$::tcl_interactive} { + # rputs stderr "\n|repl> EOF on $inputchan." + # } + # set [namespace current]::done 1 + # #test + # #JMN + # #tailcall repl::reopen_stdin + # } + # break + #} + + #set info1 "read $chunklen bytes->[ansistring VIEW -lf 1 -vt 1 $chunk]" + #consider also the terminal linefeed mode. + #https://vt100.net/docs/vt510-rm/LNM.html + # terminals (by default) generally use a lone cr to represent enter (LNM reset ie CSI 20l) + #(as per above doc: "For compatibility with Digital's software you should keep LNM reset (line feed)") + + #You can insert an lf using ctrl-j - and of course stdin could have crlf or lf + #pasting from notepad++ with mixed line endings seems to paste everything ok + #we don't really know the source of input keyboard vs paste vs pipe - and whether a read has potentially chopped a crl in half.. + #possibly no real way to determine that. We could wait a small time to see if there's more data coming.. and potentially impact performance. + #Instead we'll try to make sense of it here. + + if {$chunklen == 1} { + #presume it's a keypress from terminal + set chunk [string map {\r \n} $chunk] + } else { + #maybe a paste? (or stdin to active shell loop - possibly with no terminal ? ) + #we'd better check for crlf and/or plain lf. If found - presume any lone CR is to be left as is. + if {[string first \n $chunk] < 0} { + set chunk [string map {\r \n} $chunk] + } + #else - + #has lf - but what if last char is cr? + #It may require user to hit enter - probably ok. + #could be a sequence of cr's from holding enter key + } + + #review - we can receive chars such as escapes or arrow inline with other data even from keyboard if keys are pushed quickly (or automated?) + # - so we probably shouldn't really rely on whether a char arrives alone in a chunk as a factor in its behaviour + #On the other hand - timing of keystrokes could be legitimate indications of intention in a cli ? + + #esc or ctrl-lb + if {$chunk eq "\x1b"} { + #return + set stdinlines [list "\x1b"] + set commandstr "" + set chunk "" + $editbuf clear_tail + screen_last_char_add \x1b stdin escape + break + } + + #if ProcessedInput is disabled - we can get ctrl-c, but then we wouldn't be in raw mode and wouldn't be here. + #e.g with punk::console::disableProcessedInput + #if we get just ctrl-c in one chunk + #ctrl-c + if {$chunk eq "\x03"} { + #::punk::repl::handler_console_control "ctrl-c_via_rawloop" + error "character 03 -> ctrl-c" + } + + if {$chunk eq "\x7f"} { + #review - configurable? + #translate raw del to backspace del for those terminals that send plain del + set chunk "\b\x7f" + } elseif {$chunk eq "\x7f\x7f"} { + #commonly if key held down we will get 2 dels in a row + #review - could get more in a row depending on hardware/os + set chunk "\b\x7f\b\x7f" + } elseif {$chunk eq "\x1c"} { + #ctrl-bslash + #try to brutally terminate process + #attempt to leave terminal in a reasonable state + mode line ;#may be aliased to ::repl::interphelpers::mode + after 250 {exit 42} + return + } elseif {$chunk eq "\x1a"} { + #for now - exit with small delay for tidyup + #ctrl-z + #::punk::repl::handler_console_control "ctrl-z_via_rawloop" + if {[catch {mode line}]} { + interp eval code {mode line} + } + after 1000 {exit 43} + return + } + + #we *could* intercept arrow keys here before they are handled in the editbuf + #but there should only be the need to do so for situations where we aren't editing a commandline + #if {$chunk eq "\x1b\[D"} { + # #rputs stderr "${debugprompt}arrow-left D" + # #set commandstr "" + # #punk::console::move_back 1 ;#terminal does it anyway? + #} + #if {$chunk eq "\x1b\[C"} { + #} + + $editbuf add_chunk $chunk + + #-------------------------- + # editbuf and debugview rhs frames + #for now disable entirely on vt52 - we can only do cursor save restore - nothing that requires responses on stdin (?) + if {!$is_vt52 && [set ::punk::console::ansi_available]} { + #experimental - use punk::console::get_size to determine current visible width. + #This should ideally be using sigwinch or some equivalent to set a value somewhere. + #testing each time is very inefficient (1+ms) + #unfortunately there isn't an easy way to get such an event on windows console based systems - REVIEW. + set do_checkwidth 1 ;#make configurable if performance hit is too severe? TODO + set consolewidth 132 + if {$do_checkwidth} { + if {[catch {set consolewidth [dict get [punk::console::get_size] columns]} errM]} { + #review + if {!$is_vt52} { + puts stderr "repl_process_data failed on call to punk::console::get_size :$errM" + } + } + #if chan conf stdout doesn't give dimensions and console doesn't respond to queries - we can get empty results in get_size dict + if {$consolewidth eq ""} { + set consolewidth 132 + } + } + set debug_width 0 + set rightmargin 0 + set space_occupied [punk::repl::console_debugview $editbuf $consolewidth -row 10 -chunktype $chunktype -rightmargin $rightmargin] ;#contains cursor movements + set debug_width [dict get $space_occupied width] + set clearance [expr {$debug_width + $rightmargin}] + set space_occupied [punk::repl::console_editbufview $editbuf $consolewidth -row 10 -rightmargin $clearance] + } + #-------------------------- + + + set lines_unsubmitted [expr {[$editbuf linecount] - $editbuf_linenum_submitted}] + #there is always one 'line' unsubmitted - although it may be the current one being built, which may be empty string + if {$lines_unsubmitted < 1} { + puts stderr "repl editbuf_linenum_submitted out of sync with editbuf" + } + + #set trailing_line_index [expr {[$editbuf linecount] -1}] + set last_line_num [$editbuf linecount] + #set nextsubmit_index [expr {$editbuf_lineindex_submitted + 1}] + set nextsubmit_line_num [expr {$editbuf_linenum_submitted + 1}] + + set cursor_row [$editbuf cursor_row] + set cursor_index [expr {$cursor_row -1}] + set lastansi [$editbuf last_ansi] + if {$lastansi eq "\x1b\[A"} { + if {$cursor_row > 1} { + puts -nonewline stdout "\x1b\[A" + } + } elseif {$lastansi eq "\x1b\[B"} { + puts -nonewline stdout "\x1b\[B" + } + flush stdout + + + + set leftmargin 3 + if {!$is_vt52} { + puts -nonewline stdout [a+ cyan][punk::ansi::move_column [expr {$leftmargin +1}]][punk::ansi::erase_eol][$editbuf line $cursor_row][a][punk::ansi::move_column [expr {$leftmargin + [$editbuf cursor_column]}]] + } else { + puts -nonewline stdout [a+ cyan][punk::ansi::vt52move_column [expr {$leftmargin +1}]][punk::ansi::vt52erase_eol][$editbuf line $cursor_row][punk::ansi::vt52move_column [expr {$leftmargin + [$editbuf cursor_column]}]] + } + #puts -nonewline stdout $chunk + flush stdout + if {[$editbuf last_char] eq "\n"} { + set linelen [punk::ansi::printing_length [$editbuf line $nextsubmit_line_num]] + if {!$is_vt52} { + puts -nonewline stdout [a+ cyan bold][punk::ansi::move_column [expr {$leftmargin +1}]][$editbuf line $nextsubmit_line_num][a][punk::ansi::move_column [expr {$leftmargin + $linelen +1}]] + #screen_last_char_add "\n" input inputline + puts -nonewline stdout [punk::ansi::erase_eol]\n + } else { + puts -nonewline stdout [a+ cyan bold][punk::ansi::vt52move_column [expr {$leftmargin +1}]][$editbuf line $nextsubmit_line_num][punk::ansi::vt52move_column [expr {$leftmargin + $linelen +1}]] + puts -nonewline stdout [punk::ansi::vt52erase_eol]\n + } + + + #puts -nonewline stdout \n + screen_last_char_add "\n" input inputline + set waiting [$editbuf line end] + if {[string length $waiting] > 0} { + set waiting [a+ yellow bold]$waiting[a] + #puts stderr "waiting $waiting" + $editbuf clear_tail + lappend input_chunks_waiting($inputchan) $waiting + } + } + if {$editbuf_linenum_submitted == 0} { + #(there is no line 0 - lines start at 1) + if {[$editbuf last_char] eq "\n"} { + lappend stdinlines [$editbuf line 1] + set editbuf_linenum_submitted 1 + } + } else { + if {$nextsubmit_line_num < $last_line_num} { + foreach ln [$editbuf lines $nextsubmit_line_num end-1] { + lappend stdinlines $ln + incr editbuf_linenum_submitted + } + } + } + set last_cursor_column [$editbuf cursor_column] + } + } + + } trap {POSIX} {e eopts} { + rputs stderr "trap1 POSIX '$e' eopts:'$eopts" + flush stderr + } on error {repl_error erropts} { + rputs stderr "error1 in repl_handler: $repl_error" + rputs stderr "-------------" + rputs stderr "$::errorInfo" + rputs stderr "-------------" + set stdinreader [fileevent $inputchan readable] + if {![string length $stdinreader]} { + rputs stderr "*> $inputchan reader inactive" + } else { + rputs stderr "*> $inputchan reader active" + } + if {[chan eof $inputchan]} { + rputs stderr "todo - attempt restart of repl on input channel: $inputchan in next loop" + catch {set ::punk::ns::ns_current "::"} + #todo set flag to restart repl ? + } else { + rputs stderr "continuing.." + } + flush stderr + } + + + try { + set maxlinenum [expr {[llength $stdinlines] -1}] + set linenum 0 + foreach line $stdinlines { + #puts stderr "----->line: [ansistring VIEW -lf 1 $line] commandstr:[ansistring VIEW -lf 1 $commandstr]" + set last_repl_char "" ;#last char emitted by this handler to stdout/stderr + set lastoutchar "" + set lasterrchar "" + + + #consider \x1b as text on console vs \x1b the character + #review - if we're getting these actual escape characters in line mode.. something is off - let's emit something instead of trying to interpret as a command and failing. + #This tends to happen when some sort of readline not avaialbe ie on unix or mintty in windows + #this only captures leading escape.. as an aid to diagnosis e.g won't be caught and the user will need to close the right bracket to complete the bogus command + #we may need to think about legitimate raw escapes in commands e.g from pipes or script files, vs via console? + + #esc key or ctrl-lb followed by enter + if {$line eq "\x1b"} { + #abort current command + if {$linenum == 0} { + doprompt "E% " {yellow bold} + set line "" + #screen_last_char_add " " empty empty + } else { + doprompt "\nE% " {yellow bold} + #screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required + } + incr linenum + continue + } else { + if {$line eq "\x1b\[C"} { + rputs stderr "${debugprompt}arrow-right C" + #set commandstr "" + } + if {$line eq "\x1b\[D"} { + #rputs stderr "${debugprompt}arrow-left D" + #set commandstr "" + #punk::console::move_back 1 + } + if {$line eq "\x1b\[A"} { + rputs stderr "${debugprompt}arrow-up A" + } + if {$line eq "\x1b\[B"} { + rputs stderr "arrow-down B" + } + if {[string match "\x1b*" $line]} { + rputs stderr "${debugprompt}esc - '[punk::ansi::ansistring::VIEW $line]'" + #set commandstr [punk::ansi::ansistrip $commandstr] + } + } + + if {$commandstr ne ""} { + append commandstr \n + } + + set stdinconf [fconfigure $inputchan] + if {$::tcl_platform(platform) eq "windows" && [dict get $stdinconf -encoding] ni [list unicode utf-16 utf-8]} { + #some long console inputs are split weirdly when -encoding and -translation are left at defaults - requiring extra enter-key to get repl to process. + #experiment to see if using iso8859-1 (raw bytes) and handling line endings manually gives insight. + # - do: chan conf stdin -encoding iso859-1 -translation lf + + #first command after configuring stdin this way seems to be interpreted with wrong encoding - subsequent commands work - review + + #this branch only works on tcl8.7+ + #It seems to fix the issue with holding down enter-key and getting extra blank lines, but + # it breaks copy-paste (encoding issue?) + + + #puts "--inputchan:$inputchan> [fconfigure $inputchan]" + + append commandstr $line + puts "1=============>[string length $commandstr] bytes , [ansistring VIEW $commandstr] , info complete:[info complete $line] stdinconf:$stdinconf" + set commandstr [string range $commandstr 0 end-3] + set commandstr [encoding convertfrom utf-16be $commandstr] ;#This is weird - but it seems to be big endian? + set commandstr [string trimright $commandstr] + #puts "2=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + } else { + #append commandstr $line + #puts "0=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + append commandstr $line + } + + #puts "=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + set last_repl_char "\n" ;#this is actually the eol from stdin + screen_last_char_add "\n" stdin $line + + + + #append commandstr \n + + + if {[info complete $commandstr] && [string index $commandstr end] ne "\\"} { + #set commandstr [overtype::renderline -expand_right 1 "" $commandstr] + + + set ::repl::output_stdout "" + set ::repl::output_stderr "" + set outstack [list] + set errstack [list] + + + #oneshot repl debug + set wordparts [regexp -inline -all {\S+} $commandstr] + lassign $wordparts cmd_firstword cmd_secondword + if {$cmd_firstword eq "debugrepl"} { + if {$cmd_secondword in [list 0 cancel]} { + set ::punk::repl::debug_repl 0 + } else { + if {[string is integer -strict $cmd_secondword]} { + incr ::punk::repl::debug_repl $cmd_secondword + } else { + incr ::punk::repl::debug_repl + } + } + #set commandstr "set ::punk::repl::debug_repl" + set commandstr "" + } + if {$::punk::repl::debug_repl > 100} { + proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { + set p %p% + #don't auto-append \n even if missing. + #we may want to use debug_repl_emit with multiple calls for one output line + #if {[string index $msg end] ne "\n"} { + # set msg "$msg\n" + #} + #set last_char [string index $::repl::screen_last_chars end] + set last_char [screen_last_char_get] + if {$last_char ne "\n"} { + set clearance "\n" + } else { + set clearance "" + } + #use pseudo-channel debugreport + rputs debugreport $clearance$p[string map [list \n \n$p] $msg] + }] + set info "" + append info "repl loopinstance: $loopinstance debugrepl remaining: [expr {[set ::punk::repl::debug_repl]-1}]\n" + append info "commandstr: [punk::ansi::ansistring::VIEW $commandstr]\n" + set lastrunchunks [tsv::get repl runchunks-[tsv::get repl runid]] + append info "lastrunchunks\n" + append info "chunks: [llength $lastrunchunks]\n" + append info "namespace: $::punk::ns::ns_current" + debug_repl_emit $info + } else { + proc debug_repl_emit {msg} {return} + } + + #----------------------------------------- + #review! + #work around weird behaviour in tcl 8.6 & 8.7a5 (at least) part1 + #https://wiki.tcl-lang.org/page/representation + #/scriptlib/tests/listrep_bug.tcl + #after the uplevel #0 $commandstr call + # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value + #review - although the rep change is weird - what actual problem was caused aside from an unexpected shimmer? + #probably just that the repl can't then be used to debug representation issues and possibly that the performance is not ideal for list pipeline commands(?) + #now that we eval in another thread and interp - we seem to lose the list rep anyway. + #(unless we also save the script in that interp too in a run_command_cache) + global run_command_string + set run_command_string "$commandstr\n" ;#add anything that won't affect script. + global run_command_cache + #----------------------------------------- + + set repl_runid [tsv::incr repl runid] + tsv::set repl runchunks-$repl_runid [list] ;#last_run_display + catch { + #REVIEW - when we launch a subshell and run more than 10 commands, + #we delete runchunks from the outer shell that we'll return to! + #we should use a toplevel key pertaining to the shell/subshell instead of just 'repl' + tsv::unset repl runchunks-[expr {$repl_runid - 10}] + } + + #set ::repl::last_unknown "" + tsv::set repl last_unknown "" + #*********************************************************** + #don't use puts,rputs or debug_repl_emit in this block + #*********************************************************** + + #if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { + # lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + #} + #lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output_stdout}] + #if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { + # lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + #} + + variable codethread + variable codethread_cond + variable codethread_mutex + + lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] + #thread::transfer $codethread stderr + + #chan configure stdout -buffering none + #JMN + fileevent $inputchan readable {} + set reading 0 + #don't let unknown use 'args' to convert commandstr to list + #=============================================================================== + #Actual command call + #puts "____>[rep $commandstr]" + #=============================================================================== + if {[string equal -length [string length "repl_runraw "] "repl_runraw " $commandstr]} { + #pass unevaluated command to runraw + set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] + } else { + #puts stderr "repl uplevel 0 '$run_command_string'" + #JMN + #puts stderr "sending to codethread::runscript $run_command_string" + tsv::set codethread_$codethread status -1 + thread::send -async $codethread [list punk::repl::codethread::runscript $run_command_string] + thread::mutex lock $codethread_mutex + while {[set status [tsv::get codethread_$codethread status]] == -1} { + thread::cond wait $codethread_cond $codethread_mutex 50 + update ;#we need a full update here to allow interrupts to be processed + #While update is often considered risky - here we know our input channel readable event has been disabled - so re-entrancy shouldn't be possible. + #however - child thread can send quit - transferring processing from here back to repl::start - which then ends - making a mess (child not yet finished when trying to tidy up) + #we should give the child a way to quit by setting a tsv we pick up here *after the while loop* - and then we can set done. + } + thread::mutex unlock $codethread_mutex + set raw_result [tsv::get codethread_$codethread result] + lassign [tsv::get codethread_$codethread info] _o lastoutchar_codethread _e lasterrchar_codethread + + #set status [catch { + # thread::send $ + # uplevel 1 {namespace inscope $::punk::ns::ns_current $run_command_string} + #} raw_result] + + } + #puts stderr "repl raw_result: $raw_result" + #set result $raw_result + #append result ""; #copy on write + #copy on write + + #append result $raw_result "" + set result [string cat $raw_result ""] + #puts stderr "-->>$result<--" + #=============================================================================== + + flush stdout + flush stderr + #foreach s [lreverse $outstack] { + # shellfilter::stack::remove stdout $s + #} + #foreach s [lreverse $errstack] { + # shellfilter::stack::remove stderr $s + #} + + #----------------------------------------- + #list/string-rep bug workaround part 2 + #todo - set flag based on punk::lib::check::has_tclbug_script_var + lappend run_command_cache $run_command_string + #puts stderr "run_command_string rep: [rep $run_command_string]" + if {[llength $run_command_cache] > 2000} { + set run_command_cache [lrange $run_command_cache 1750 end] + } + #----------------------------------------- + + #screen_last_char_add [string index $lastoutchar_codethread$lasterrchar_codethread end] "stdout/stderr" + + + #set lastoutchar [string index [punk::ansi::ansistrip $::repl::output_stdout] end] + #set lasterrchar [string index [punk::ansi::ansistrip $::repl::output_stderr] end] + + #to determine whether cursor is back at col0 of newline + #screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr" + + + #??? + #screen_last_char_add [string index $lastoutchar$lastoutchar_codethread$lasterrchar$lasterrchar_codethread end] "stdout/stderr" + screen_last_char_add [string index $lastoutchar_codethread$lasterrchar_codethread end] "stdout/stderr" + + + set result_is_chunk_list 0 + #------ + #todo - fix. It doesn't make much sense to only detect if the unknown command occurred in first word. + #e.g set x [something arg] not detected vs something arg + #also - unknown commands aren't the only things that can write directly to the os handles stderr & stdout + set last_unknown [tsv::get repl last_unknown] + if { + [string length $last_unknown] && \ + [string equal -length [string length $last_unknown] $last_unknown $line] + } { + #can't currently detect stdout/stderr writes from unknown's call to exec + #add a clearance newline for direct unknown calls for now + #there is usually output anyway - but we will get an extra blank line now even for a call that only had an exit code + # + # + set unknown_clearance "\n* repl newline" + screen_last_char_add "\uFFFF" clearance "clearance after direct unknown call" + if {[tsv::llength repl runchunks-$repl_runid]} { + if {$status == 0} { + set result [tsv::get repl runchunks-$repl_runid] ;#last_run_display + } else { + + } + set result_is_chunk_list 1 + } + } + #------ + #ok to use repl::screen_needs_clearance from here down.. (code smell - proc only valid use in narrow context) + #*********************************************************** + #rputs -nonewline stderr $unknown_clearance + if {$::punk::repl::debug_repl > 0} { + set lastcharinfo "\n" + set whatcol [string repeat " " 12] + foreach cinfo $::repl::screen_last_char_list { + lassign $cinfo c whatinfo whyinfo + set cdisplay [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $c] + #assertion cdisplay has no raw newlines + if {[punk::char::ansifreestring_width $cdisplay] == 1} { + set cdisplay "$cdisplay " ;#make 2 wide + } + if {[string match repl-debugreport* $whatinfo]} { + #exclude noise debug_repl_emit - but still show the last_char + set whysummary "" + } else { + #set whysummary [string map [list \n "-n-"] $whyinfo] + set whysummary [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $whyinfo] + } + set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] + append lastcharinfo "$cdisplay $whatinfo $whysummary\n" + } + debug_repl_emit "screen_last_chars: $lastcharinfo" + } + + debug_repl_emit "lastoutchar:'$lastoutchar' lasterrchar: '$lasterrchar'" + if {$status == 0} { + debug_repl_emit "command call status: $status OK" + } else { + debug_repl_emit "command call status: $status ERR" + } + + + + + #puts stderr "'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" + #$command is an unevaluated script at this point + # so may not be a well formed list e.g 'set x [list a "b"]' + #- lindex $command would sometimes fail + #if {[lindex $command 0] eq "runx"} {} + + + if { + [string equal -length [string length "d/ "] "d/ " $commandstr] || \ + [string equal "d/\n" $commandstr] || \ + [string equal -length [string length "dd/ "] "dd/ " $commandstr] || \ + [string equal "dd/\n" $commandstr] || \ + [string equal -length [string length "./ "] "./ " $commandstr] || \ + [string equal "./\n" $commandstr] || \ + [string equal -length [string length "../ "] "../ " $commandstr] || \ + [string equal "../\n" $commandstr] || \ + [string equal -length [string length "runx "] "runx " $commandstr] || \ + [string equal -length [string length "sh_runx "] "sh_runx " $commandstr] || \ + [string equal -length [string length "runout "] "runout " $commandstr] || \ + [string equal -length [string length "sh_runout "] "sh_runout " $commandstr] || \ + [string equal -length [string length "runerr "] "runerr " $commandstr] || \ + [string equal -length [string length "sh_runerr "] "sh_runerr " $commandstr] + + } { + if {[tsv::llength repl runchunks-$repl_runid]} { + set result [tsv::get repl runchunks-$repl_runid] ;#last_run_display + set result_is_chunk_list 1 + } + } + + # -- --- --- --- --- --- --- --- --- --- + ##an attempt to preserve underlying rep + ##this is not for performance - just to be less disruptive to underlying rep to aid in learning/debugging + # -- --- --- --- --- --- --- --- --- --- + # JN 2023 - The lrange operation is destructive to path internal representation + # The lrange operation is destructive to strings with leading/trailing newlines + # -- --- --- --- --- --- --- --- --- --- + #set saved_errorCode $::errorCode + #set saved_errorInfo $::errorInfo + #if {[catch {lrange $result 0 end} result_as_list]} { + # set is_result_empty [expr {$result eq ""}] + # set ::errorCode $saved_errorCode + # set ::errorInfo $saved_errorInfo + #} else { + # set is_result_empty [expr {[llength $result_as_list] == 0}] + #} + # -- --- --- --- --- --- --- --- --- --- + #set resultrep [::tcl::unsupported::representation $result] + + set is_result_empty [expr {$result eq ""}] + + #catch {puts stderr "yy--->[rep $::arglej]"} + + set reading 1 + if {!$is_result_empty} { + if {$status == 0} { + if {[screen_needs_clearance]} { + rputs -nonewline stderr \n + } + if {$result_is_chunk_list} { + foreach c $result { + lassign $c termchan text + if {[string length $text]} { + switch -- $termchan { + result { + #rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + set h [textblock::height $text] + set promptcol [string repeat $resultprompt\n $h] + set promptcol [string range $promptcol 0 end-1] + rputs [textblock::join_basic -- $promptcol $text] + + #puts -nonewline stdout $text + } + resulterr { + rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] + } + info { + rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] + } + default { + #rputs -nonewline $termchan $text + set chanprompt "_ " + rputs $termchan ${chanprompt}[string map [list \n "\n${chanprompt}"] $text] + } + } + } + } + + } else { + #----------------------------------------------------------- + # avoid repl forcing string rep of simple results. This is just to aid analysis using tcl::unsupported::representation + #set rparts [split $result {}] + #if {[lsearch $rparts \n] < 0} { + # #type of $result unaffected + # rputs "$resultprompt $result" + #} else { + # #$result will be a string due to use of string map + # rputs $resultprompt[string map [list \n "\n$resultprompt"] $result] + #} + #----------------------------------------------------------- + + #we have copied rawresult using append with empty string - so our string interaction with result var here shouldn't affect the returned value + #empty-string result handled in other branch + if {![tsv::llength repl runchunks-$repl_runid]} { + #write back to tsv var for use by punk::get_runchunks (underscore command) + tsv::set repl runchunks-$repl_runid [list [list result $result]] + } + set flat [string map [list \r\n "" \n ""] $result] + if {[string length $flat] == [string length $result]} { + #no line-endings in data + rputs "$resultprompt$result" + } else { + #if {[string index $result end] eq "\n"} { + # set result [string range $result 0 end-1] + #} + if {[string length $flat] == 0} { + if {[string range $result end-1 end] eq "\r\n"} { + set result [string range $result 0 end-2] + } else { + set result [string range $result 0 end-1] + } + } + #NOTE - textblock::height is the line height - not reflective of height of data with ansi-moves or things like sixels + set h [textblock::height $result] + set promptcol [string repeat $resultprompt\n $h] + set promptcol [string range $promptcol 0 end-1] + #promptcol is uniform-width lines, result may not be. We are ok to join with ragged rhs col here, so use join_basic instead of join + rputs [textblock::join_basic -- $promptcol $result] + + #orig + #rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] + } + } + doprompt "P% " + } else { + #tcl err + if {$result_is_chunk_list} { + foreach c [tsv::get repl runchunks-$repl_runid] { + #last_run_display + lassign $c termchan text + if {[string length $text]} { + switch -- $termchan { + result { + rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + #puts -nonewline stdout $text + } + resulterr { + rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] + } + info { + rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] + } + default { + rputs -nonewline $termchan $text + } + } + } + } + } + + set c [a yellow bold] + set n [a] + rputs stderr $c$result$n + #tcl err hint prompt - lowercase + doprompt "p% " + } + } else { + #doprompt "P% " "green normal" + if {$linenum == 0} { + doprompt "P% " "green normal" + screen_last_char_add " " empty empty + } else { + doprompt "\nP% " "green normal" + screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required + } + } + #catch {puts stderr "zz1--->[rep $::arglej]"} + #puts stderr "??? $commandstr" + if {$::punk::repl::debug_repl > 0} { + incr ::punk::repl::debug_repl -1 + } + set commandstr "" + #catch {puts stderr "zz2---->[rep $::arglej]"} + + set lines [$editbuf lines] + set buf_has_data 0 + foreach ln $lines { + if {[string trim $ln] ne ""} { + set buf_has_data 1 + } + } + if {$buf_has_data} { + set editbufnext [punk::repl::class::class_editbuf new {}] + lappend editbuf_list $editbufnext + set editbuf_linenum_submitted 0 + set editbuf $editbufnext + } + #editbuf + + } else { + #append commandstr \n + if {$::punk::repl::signal_control_c} { + set ::punk::repl::signal_control_c 0 + fileevent $inputchan readable {} + rputs stderr "* console_control: control-c" + flush stderr + set c [a yellow bold] + set n [a] + rputs stderr "${c}repl interrupted$n" + #set commandstr [list error "repl interrupted"] + set commandstr "" + doprompt ">_ " + flush stdout + + } else { + #Incomplete command + # parse and determine outermost unclosed quote/bracket and include in prompt + if {$linenum == $maxlinenum} { + if {$rawmode} { + #review + #we haven't put the data following last le into commandstr - but we want to display proper completion status prior to enter being hit or more data coming in. + #this could give spurious results for large pastes where buffering chunks it in odd places.? + #it does however give sensible output for the common case of a small paste where the last line ending wasn't included + set waiting [punk::lib::system::incomplete $commandstr[$editbuf line end]] + } else { + set waiting [punk::lib::system::incomplete $commandstr] + } + if {[llength $waiting]} { + set c [lindex $waiting end] + } else { + #set c " " + set c \u240a + } + doprompt ">$c " + } + } + } + + incr linenum + } + + + if {$maxlinenum == -1} { + #when in raw mode - no linefeed yet received + #rputs stderr "repl: no complete input line: $commandstr" + #screen_last_char_add "\n" empty empty + + screen_last_char_add [string index [$editbuf line end] end] stdinchunk stdinchunk + + } + + + #fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] + #catch {puts stderr "zend--->[rep $::arglej]"} + + + } trap {POSIX} {e eopts} { + rputs stderr "trap POSIX '$e' eopts:'$eopts" + flush stderr + } on error {repl_error erropts} { + rputs stderr "error in repl_handler: $repl_error" + rputs stderr "-------------" + rputs stderr "$::errorInfo" + rputs stderr "-------------" + set stdinreader [fileevent $inputchan readable] + if {![string length $stdinreader]} { + rputs stderr "*> $inputchan reader inactive" + } else { + rputs stderr "*> $inputchan reader active" + } + if {[chan eof $inputchan]} { + rputs stderr "todo - attempt restart of repl on input channel: $inputchan in next loop" + catch {set ::punk::ns::ns_current "::"} + #todo set flag to restart repl ? + } else { + rputs stderr "continuing.." + } + flush stderr + } +} + +proc repl::completion {context ebuf} { + +} + +namespace eval repl { + + + proc init {args} { + if {![info exists ::argv0]} { + #error out before we create a thread - punk requires this - review + error "::argv0 not set" + } + #in case -callback_interp wasn't explicitly defined - we make a guess based on how init was called as to whether this is being launched from a 'code' or root ("") interp. + if {[catch {info level -1} caller]} { + #todo logger + #puts "repl::init from: global" + set default_callback_interp "" + } else { + #puts "repl::init from: $caller" + set default_callback_interp "code" + } + variable codethread + variable codethread_cond + variable codethread_mutex + + set opts [list -force 0 -safe 0 -safelog 0 -paths {} -callback_interp $default_callback_interp] + foreach {k v} $args { + switch -- $k { + -force - -safe - -safelog - -paths - -callback_interp { + dict set opts $k $v + } + default { + error "repl::init unknown option '$k'. Known-options: [dict keys $opts]" + } + } + } + set opt_force [dict get $opts -force] + set opt_safe [dict get $opts -safe] + set opt_safelog [dict get $opts -safelog] + if {$opt_safelog eq "0"} { + set opt_safelog "" + } + if {[string is boolean -strict $opt_safelog]} { + if {$opt_safelog} { + set opt_safelog ::repl::interpextras::safe_msg + } + } + dict set opts -safelog $opt_safelog + + #If we are launching a repl from within an interp - we need to tell the childthread how to call-back to the parent repl + set opt_callback_interp [dict get $opts -callback_interp] + + if {$codethread ne "" && !$opt_force && [thread::exists $codethread] } { + error "repl:init codethread: $codethread already exists. use -force 1 to override" + } + set codethread [thread::create -preserved] + #review - naming of the possibly 2 cond variables parent and child thread + set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread) + set codethread_mutex [thread::mutex create] + + + set scriptmap [list %args% [list $opts] \ + %argv0% [list $::argv0] \ + %argv% [list $::argv] \ + %argc% [list $::argc] \ + %replthread% [thread::id] \ + %replthread_cond% $codethread_cond \ + %replthread_interp% [list $opt_callback_interp] \ + %tmlist% [list [tcl::tm::list]] \ + %autopath% [list $::auto_path] \ + ] + #scriptmap applied at end to satisfy silly editor highlighting. + set init_script { + set ::argv0 %argv0% + set ::argv %argv% + set ::argc %argc% + tcl::tm::remove {*}[tcl::tm::list] + tcl::tm::add {*}[lreverse %tmlist%] ;#Must be added in reverse order to get same order as original list! + + #this sets the auto_path in the thread but outside of the code interp that will be created. + #It will also need to be added in that interp + set ::auto_path %autopath% + set tclmajorv [lindex [split [tcl::info::tclversion] .] 0] + #jmn2 + #puts stdout "CODETHREAD tm list" + #puts stdout [join [tcl::tm::list] \n] + #puts stdout "====================" + #flush stdout + #puts stdout "CODETHREAD autopath" + #puts stdout [join $::auto_path \n] + #puts stdout "====================" + #flush stdout + #if {[llength [info commands tcl::zipfs::root]]} { + # set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing + # if {"$zipbase" in [tcl::zipfs::mount]} { + # puts stdout "//zipfs:/app/modules_tcl$tclmajorv exists: [file exists //zipfs:/app/modules_tcl$tclmajorv]" + # } + #} + #puts stdout "====================" + package require punk::packagepreference + punk::packagepreference::install + + package require punk::args + package require Thread + package require snit + if {[catch {package require punk::icomm} errM]} { + puts stdout "---icomm $errM" + } + namespace eval ::punk::repl::codethread {} + #todo - review. According to fifo2 docs Memchan involves one less thread (may offer better performance/resource use) + catch {package require tcl::chan::fifo2} + if {[catch { + #first use can raise error being a version number e.g 0.1.0 - why? + lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside + } errMsg]} { + #puts stdout "---tcl::chan::fifo2 error: $errM" + } else { + #puts stdout "transferring chan $replside to thread %replthread%" + #flush stdout + if {[catch { + #after 0 [list thread::transfer %replthread% $replside] + } errMsg]} { + #puts stdout "---thread::transfer error: $errMsg" + } + } + + package require punk::console + package require punk::repl::codethread + package require shellfilter + #package require shellrun + package require textblock + + #md5 uses open so can't be directly called in a safe interp + #it will need to delegate to a call here in the main interp of the codethread using an installed alias + set md5version [package require md5] + #we also need to 'package provide md5 $md5version' in the safe interp itself so that it won't override + + + #punk::configure_unknown ;#must be called because we hacked the tcl 'unknown' proc + + #child codethread (outside of code interp) needs to know details of the calling repl + set ::punk::repl::codethread::replthread %replthread% ;#point to thread id of parent thread (repl) + set ::punk::repl::codethread::replthread_cond %replthread_cond% + set ::punk::repl::codethread::replthread_interp %replthread_interp% + + # -- --- --- --- + #procs to alias into the codethread interp + #as we are doing string substitution on the whole block anyway, and these values are contant for the life of the thread, we may as well substitute hard values for things like replthread into these procs where possible + # -- --- --- --- + namespace eval ::repl::interphelpers { + proc quit {args} { + #child codethreads run in a 'code' interp therefore if they started another repl - it is within the 'code' interp in that thread + # whereas the first repl launched in the process runs in root interp "" + thread::send -async %replthread% [list interp eval %replthread_interp% ::punk::repl::quit] + } + proc editbuf args { + thread::send %replthread% [list punk::repl::editbuf {*}$args] + } + proc escapeeval {script} { + eval $script + } + proc do_after {args} { + if {[llength $args] == 1} { + return after {*}$args + } + set scr [lindex $args 1] + after [lindex $args 0] [list punk::repl::codethread::runscript $scr] + } + proc repl_ensemble_unknown args { + puts $args + if {[llength $args] == 1} { + return [namespace ensemble configure ::repl::interphelpers::repl_ensemble] + } + } + proc colour args { + set colour_state [thread::send %replthread% [list punk::console::colour]] + if {[llength $args]} { + #colour call was not a query + set new_state [thread::send %replthread% [list punk::console::colour {*}$args]] + if {[expr {$new_state}] ne [expr {$colour_state}]} { + interp eval code [list punk::console::colour {*}$args] ;#align code interp's view of colour state with repl thread + + #we don't want to run a raw script directly in our code interp if we're using variables + #because we will potentially collide with user vars in that context (or create vars there) - so use apply + interp eval code [list apply {docolour { + #adjust channel transform stack + if {!$docolour} { + set s [lindex $::codeinterp::outstack end] + if {$s ne ""} { + shellfilter::stack::remove stdout $s + } + set s [lindex $::codeinterp::errstack end] + if {$s ne ""} { + shellfilter::stack::remove stderr $s + } + } else { + set running_config $::punk::config::running + if {[string length [dict get $running_config color_stdout]]} { + lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + } + if {[string length [dict get $running_config color_stderr]]} { + lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + } + + } + }} $new_state] + } + return $new_state + } else { + return $colour_state + } + #todo - add/remove shellfilter stacked ansiwrap + } + proc vt52 {args} { + return [thread::send %replthread% [list punk::console::vt52 {*}$args]] + } + proc mode args { + #with tsv::set console is_raw we don't need to call mode in both the replthread and the codethread + # REVIEW - call in local interp? how about if codethread is safe interp? + #interp eval code [list ::punk::console::mode {*}$args] + thread::send %replthread% [list punk::console::mode {*}$args] + } + proc cmdtype cmd { + code invokehidden tcl:info:cmdtype $cmd + } + + #punk repl tsv wrappers + proc set_repl_last_unknown args { + tsv::set repl last_unknown {*}$args + } + proc get_repl_runid args { + if {[tsv::exists repl runid]} { + return [tsv::get repl runid] + } else { + return 0 + } + } + proc md5 args { + ::md5::md5 {*}$args + } + proc fconfigure {args} { + code invokehidden fconfigure {*}$args + } + proc fnormalize name { + code invokehidden tcl:file:normalize $name + } + proc fdirname name { + code invokehidden tcl:file:dirname $name + } + } + namespace eval ::repl::interpextras { + #install using safe::setLogCmd + proc safe_msg {msg} { + puts stderr "safebase: $msg" + } + } + + namespace eval ::repl::interphelpers::repl_ensemble { + namespace export {[a-z]*} + namespace ensemble create + namespace ensemble configure [namespace current] -unknown ::repl::interphelpers::repl_ensemble_unknown + variable replinfo + set replinfo [dict create thread %replthread% interp %replthread_interp%] + proc thread {} { + return %replthread% + } + proc info {} { + variable replinfo + return $replinfo + } + proc eval {script} { + thread::send %replthread% $script + } + proc stack {} { + set iname %replthread_interp% + set tid %replthread% + lappend stack [list thread $tid interp $iname] + while {$iname eq "code"} { + set iname [thread::send $tid {set ::punk::repl::codethread::replthread_interp}] + set tid [thread::send $tid {set ::punk::repl::codethread::replthread}] + lappend stack [list thread $tid interp $iname] + } + return $stack + } + } + namespace eval ::repl::interphelpers::subshell_ensemble { + namespace export {[a-z]*} + namespace ensemble create + proc punk {} { + set ts_start [clock seconds] + set replresult [interp eval code { + package require punk::repl + repl::init -safe punk + repl::start stdin + }] + return [list replresult $replresult elapsed [expr {[clock seconds]-$ts_start}]] + } + proc safe {args} { + set ts_start [clock seconds] + interp eval code { + package require punk::repl + } + interp eval code [list repl::init -safe safe {*}$args] + set replresult [interp eval code [list repl::start stdin]] + + return [list replresult $replresult elapsed [expr {[clock seconds]-$ts_start}]] + } + proc safebase {args} { + set ts_start [clock seconds] + interp eval code { + package require punk::repl + } + set codethread [interp eval code [list repl::init -safe safebase {*}$args]] + puts stdout "safebase codethread:$codethread" + set replresult [interp eval code [list repl::start stdin]] + + return [list replresult $replresult elapsed [expr {[clock seconds]-$ts_start}]] + } + proc punksafe {args} { + set ts_start [clock seconds] + interp eval code { + package require punk::repl + } + interp eval code [list repl::init -safe punksafe {*}$args] + set replresult [interp eval code [list repl::start stdin]] + + return [list replresult $replresult elapsed [expr {[clock seconds]-$ts_start}]] + } + } + # -- --- --- --- --- + + #puts "codethread:[thread::id] parent replthread:%replthread%" + #flush stdout + + set args %args% + set safe [dict get $args -safe] + set safelog [dict get $args -safelog] + set paths [list] + if {[dict exists $args -paths]} { + set paths [dict get $args -paths] + } + + switch -- $safe { + safe { + interp create -safe -- code + package require punk::args + } + safebase { + safe::interpCreate code -nested 1 -autoPath %autopath% + code alias "file normalize" "file normalize" + code alias "file dirname" "file dirname" + code alias "file exists" "file exists" + code alias ::tcl::file::normalize ::tcl::file::normalize + code alias ::tcl::file::dirname ::tcl::file::dirname + code alias ::tcl::file::exists ::tcl::file::exists + #code alias ::punk::console::colour ::punk::console::colour + } + punksafe { + #less safe than safebase - we need file normalize and info script to handle modpod? + package require punk::safe + punk::safe::interpCreate code -autoPath %autopath% + code alias "file normalize" "file normalize" + code alias "file dirname" "file dirname" + code alias "file exists" "file exists" + code alias ::tcl::file::normalize ::tcl::file::normalize + code alias ::tcl::file::dirname ::tcl::file::dirname + code alias ::tcl::file::exists ::tcl::file::exists + code alias ::punk::console::colour ::punk::console::colour + } + punk - 0 { + interp create code + } + punkisland { + interp create code + #todo + #when no island paths specified - should be like safebase, but without folder hiding and with expanded read to ::auto_path folders + } + } + + interp eval code { + namespace eval codeinterp { + variable errstack {} + variable outstack {} + variable run_command_cache + proc set_clone {varname obj} { + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + } + } + + switch -- $safe { + safe { + if {[llength $paths]} { + package require punk::island + foreach p $paths { + punk::island::add code $p + } + } + interp share "" stdout code + interp share "" stderr code + interp share "" stdin code ;#needed for ANSI queries + + set codehidden [code hidden] + code alias file file + if {"source" in $codehidden} { + code expose source + } + if {"encoding" in $codehidden} { + code expose encoding ;#leave enabled + } + if {"tcl:encoding:system" in $codehidden} { + code expose tcl:encoding:system + code eval {rename ::tcl::encoding::system ""} + code eval {rename tcl:encoding:system ::tcl::encoding::system} + } + #interp alias is available in safe - so it seems unreasonable to disallow 'info cmdtype' + if {"tcl:info:cmdtype" in $codehidden} { + code eval {rename ::tcl::info::cmdtype ""} + code expose tcl:info:cmdtype + code eval {rename tcl:info:cmdtype ::tcl::info::cmdtype} + } + set pkgs [list\ + punk::args\ + punk::pipe\ + cmdline\ + struct::list\ + struct::set\ + textutil::wcswidth\ + textutil::trim\ + textutil::repeat\ + textutil::tabify\ + textutil::split\ + textutil::string\ + textutil::adjust\ + textutil\ + punk::encmime\ + punk::char\ + punk::assertion\ + punk::ansi\ + punk::lib\ + overtype\ + dictutils\ + debug\ + punk::ns\ + textblock\ + punk::args::tclcore\ + punk::aliascore\ + ] + + #pattern looks up versions available of patternlib before loading (but we don't have an index for tm files) todo fix pattern. + # patterncmd\ + # metaface\ + # patternpredator2\ + # patternlib\ + # pattern + + # - no longer required by textblock + # term::ansi::code\ + # term::ansi::code::attr\ + # term::ansi::code::ctrl\ + # term::ansi::code::macros + + #---------- + #all this scanning and loading core packages - we should possibly cache the file data for other interps? + #make sure codethread has scanned for packages - must do for each namespace level + #catch {package require flubber_nonexistent} + set ns_scanned [dict create] + #---------- + set prior_infoscript [code eval {info script}] ;#probably empty that's ok + foreach pkg $pkgs { + if {[catch { + set nsquals [namespace qualifiers $pkg] + if {$nsquals ne ""} { + if {![dict exists $ns_scanned $nsquals]} { + catch {package require ${nsquals}::flubber_nonexistant} ;#force scan + dict set ns_scanned $nsquals 1 + } + } + set versions [lsort -command {package vcompare} [package versions $pkg]] + if {[llength $versions]} { + set v [lindex $versions end] + set path [lindex [package ifneeded $pkg $v] end] + if {[file extension $path] in {.tcl .tm}} { + if {[file exists $path]} { + set data [readFile $path] + code eval [list info script $path] + code eval $data + code eval [list info script $prior_infoscript] + } else { + error "safe - failed to find $path" + } + } else { + error "safe - refusing to attempt load of $pkg from $path - (allowed extensions .tcl .tm)" + } + } else { + error "safe - no versions of $pkg found" + } + } errMsg]} { + puts stderr "safe - failed to load package $pkg\n$errMsg\n$::errorInfo" + } else { + #puts stdout "safe - loaded $pkg from $path" + } + } + code alias file "" + code hide source + + + #review argv0,argv,argc + #interp eval code { + # set ::argv0 %argv0% + # set ::auto_path %autopath% + #} + interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)] + interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] + interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] + if {"stdout" in [chan names]} { + interp share {} stdout code + } else { + interp share {} [shellfilter::stack::item_tophandle stdout] code + } + if {"stderr" in [chan names]} { + interp share {} stderr code + } else { + interp share {} [shellfilter::stack::item_tophandle stderr] code + } + + #review + code alias ::shellfilter::stack ::shellfilter::stack + #code alias ::punk::lib::set_clone ::punk::lib::set_clone + #code alias ::aliases ::punk::lib::aliases + code alias ::punk::lib::aliases ::punk::lib::aliases + namespace eval ::codeinterp {} + + code alias ::md5::md5 ::repl::interphelpers::md5 + code alias exit ::repl::interphelpers::quit + } + safebase { + #safebase + #safe::setLogCmd ::repl::interpextras::safe_msg ;#using setLogcmd early will show the auto_path notice - which is *verbose* + #while it may conceivably be useful in debugging safe itself - auto_path and tcl::tm::list can be inspected to show these values in the safe interp itself anyway - so early logging is of limited utility here. + if {[llength $paths]} { + package require punk::island + foreach p $paths { + punk::island::add code $p + } + } + interp eval code { + set ::argv0 %argv0% + set ::argc 0 + set ::argv {} + #puts stdout "safebase interp" + #flush stdout + } + interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)] + interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] + interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] + + code alias ::fconfigure ::repl::interphelpers::fconfigure ;#needed for shellfilter + + #code invokehidden package require punk::lib + if {"stdout" in [chan names]} { + interp share {} stdout code + } else { + interp share {} [shellfilter::stack::item_tophandle stdout] code + } + if {"stderr" in [chan names]} { + interp share {} stderr code + } else { + interp share {} [shellfilter::stack::item_tophandle stderr] code + } + interp eval code { + package require punk::lib + package require textblock + } + + #JMN + interp eval code { + package require shellfilter + } + + + #work around bug in safe base which won't load Tcl libs that have deeper nesting + #(also affects tcllib page/plugins folder) + set termversions [package versions term] + set termv [lindex $termversions end] + if {$termv ne ""} { + set path [lindex [package ifneeded term $termv] end] ;#assuming path at end of something like "source .../term.tcl" + set termbase [file dirname $path] + safe::interpAddToAccessPath code [file join $termbase ansi] + safe::interpAddToAccessPath code [file join $termbase ansi code] + } + #safe::interpAddToAccessPath code NUL + if {$safelog ne ""} { + #setting setLogCmd here gives potentially interesting feedback regarding behaviour of things such as glob + safe::setLogCmd $safelog + } + #code invokehidden source c:/repo/jn/shellspy/modules/punk/lib-0.1.1.tm + + code alias detok ::safe::DetokPath code ;#temp - this violates the point of the {$p(:X:)} paths + + #review - exit should do something slightly different + # see ::safe::interpDelete + code alias exit ::repl::interphelpers::quit + + code alias ::md5::md5 ::repl::interphelpers::md5 + code alias ::file ::file + interp eval code [list package provide md5 $md5version] + + } + punksafe { + interp eval code { + set ::argv0 %argv0% + set ::argc 0 + set ::argv {} + #set ::auto_path %autopath% ;#jmn + #tcl::tm::remove {*}[tcl::tm::list] + #tcl::tm::add {*}[lreverse %tmlist%] + } + interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)] + interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] + interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] + + + code alias ::fconfigure ::repl::interphelpers::fconfigure ;#needed for shellfilter + + if {"stdout" in [chan names]} { + interp share {} stdout code + } else { + interp share {} [shellfilter::stack::item_tophandle stdout] code + } + if {"stderr" in [chan names]} { + interp share {} stderr code + } else { + interp share {} [shellfilter::stack::item_tophandle stderr] code + } + + interp eval code { + package require punk::lib + package require punk::args + package require punk::args::tclcore + package require textblock + } + + interp eval code { + if {[catch { + #package require packagetrace + #packagetrace::init + } errM]} { + puts stderr "========================" + puts stderr "code interp error 1:" + puts stderr $errM + puts stderr $::errorInfo + puts stderr "========================" + #error "$errM" + } + } + + + interp eval code { + if {[catch { + package require punk::config ;#requires: none + #package require punk::console ;#requires: Thread,punk::ansi,punk::args + #set running_config $::punk::config::running + package require shellfilter ;#requires: shellthread,Thread + apply {running_config { + if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { + lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + } + if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { + lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + } + }} $::punk::config::running + + } errM]} { + puts stderr "========================" + puts stderr "code interp error 2:" + puts stderr $errM + puts stderr $::errorInfo + puts stderr "========================" + error "$errM" + } + } + + interp eval code { + if {[catch { + + #puts stderr "loading natsort" + #natsort has 'application mode' which can exit. + #Requiring it shouldn't trigger application - but zipfs/vfs interactions confused it in some early versions + package require natsort + + #package require punk ;# Thread + #package require shellrun ;#subcommand exists of file + + + #----------------------------------------------------------------------------------------------------------------------------------------- + package require punk::ns ;#requires:punk::lib,punk::args,struct::list,cmdline+(tcllibc),struct::set,punk::ansi,punk::char, + #textutil,textutil::string,textutil::adjust,textutil::repeat,textutil::string,textutil::split,textutil::tabify,textutil::wcswidth + #punk::encmime,punk::assertion + #twapi,platform,registry,debug,overtype,patternpunk,pattern,patterncmd,metaface,patternpredator2,patternlib,dictutils + #----------------------------------------------------------------------------------------------------------------------------------------- + + #package require textblock + } errM]} { + puts stderr "========================" + puts stderr "code interp error 3:" + puts stderr $errM + puts stderr $::errorInfo + puts stderr "========================" + error "$errM" + } + + } + + } + punk - 0 { + interp eval code { + #safe !=1 and safe !=2, tmlist: %tmlist% + set ::argv0 %argv0% + set ::argv %argv% + set ::argc %argc% + set ::auto_path %autopath% + tcl::tm::remove {*}[tcl::tm::list] + tcl::tm::add {*}[lreverse %tmlist%] + #puts "code interp chan names-->[chan names]" + + # -- --- + #review + #we have to blow some time on a rescan to provide more deterministic ordering (match behaviour of initial thread regarding pkg precedence) + #review - can we speed that scan up? + ##catch {package require flobrudder-nonexistant} + # -- --- + + if {[catch { + package require vfs + package require vfs::zip + } errM]} { + puts stderr "repl code interp can't load vfs,vfs::zip" + } + + #puts stderr ----- + #puts stderr [join $::auto_path \n] + #puts stderr ----- + + if {[catch { + package require punk::config + package require punk::ns + #puts stderr "loading natsort" + #natsort has 'application mode' which can exit. + #Requiring it shouldn't trigger application - but zipfs/vfs interactions confused it in some early versions + package require natsort + #catch {package require packageTrace} + package require punk + package require punk::args + package require punk::args::tclcore + package require shellrun + package require shellfilter + #set running_config $::punk::config::running + apply {running_config { + if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { + lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + } + if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { + lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + } + }} $::punk::config::running + + package require textblock + } errM]} { + puts stderr "========================" + puts stderr "code interp error:" + puts stderr $errM + puts stderr $::errorInfo + puts stderr "========================" + error "$errM" + } + } + } + default { + } + } + code alias repl ::repl::interphelpers::repl_ensemble + code alias subshell ::repl::interphelpers::subshell_ensemble + code alias quit ::repl::interphelpers::quit + code alias editbuf ::repl::interphelpers::editbuf + code alias colour ::repl::interphelpers::colour + code alias mode ::repl::interphelpers::mode + code alias vt52 ::repl::interphelpers::vt52 + #code alias after ::repl::interphelpers::do_after + + code alias ::punk::set_repl_last_unknown ::repl::interphelpers::set_repl_last_unknown + code alias ::punk::get_repl_runid ::repl::interphelpers::get_repl_runid + + #JMN + #code alias cmdtype ::repl::interphelpers::cmdtype + #temporary debug aliases - deliberate violation of safety provided by safe interp + code alias escapeeval ::repl::interphelpers::escapeeval + + + #experiment + #code alias ::shellfilter::stack ::shellfilter::stack + + #puts stderr "returning threadid" + #puts stderr [thread::id] + + thread::id + } + set init_script [string map $scriptmap $init_script] + + + #thread::send $codethread $init_script + if {![catch { + thread::send $codethread $init_script result ;#use a result var when wrapping in a catch - without it we can get a return code of 2 (TCL_RETURN) + } errMsg]} { + return $result + } else { + puts stderr "repl::init Failed during thread::send" + puts stderr "$::errorInfo" + thread::release $codethread + error $errMsg + } + } + #init - don't auto init - require init with possible options e.g -safe +} +package provide punk::repl [namespace eval punk::repl { + variable version + set version 999999.0a1.0 +}] + +#repl::start $program_read_stdin_pipe + + + diff --git a/src/modules/punk/repl-buildversion.txt b/src/modules/punk/repl-buildversion.txt new file mode 100644 index 00000000..781c895b --- /dev/null +++ b/src/modules/punk/repl-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config index 816f3331..247371ee 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config @@ -23,6 +23,7 @@ set bootsupport_modules [list\ src/vendormodules patterncmd\ src/vendormodules patternlib\ src/vendormodules patternpredator2\ + src/vendormodules promise\ src/vendormodules sha1\ src/vendormodules tomlish\ src/vendormodules test::tomlish\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm new file mode 100644 index 00000000..a4b82e45 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm @@ -0,0 +1,1311 @@ +# Copyright (c) 2015-2023, Ashok P. Nadkarni +# All rights reserved. + +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: + +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. + +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. + +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +package require Tcl 8.6- + +namespace eval promise { + proc version {} { return 1.2.0 } +} + +proc promise::lambda {params body args} { + # Creates an anonymous procedure and returns a command prefix for it. + # params - parameter definitions for the procedure + # body - body of the procedures + # args - additional arguments to be passed to the procedure when it + # is invoked + # + # This is just a convenience command since anonymous procedures are + # commonly useful with promises. The lambda package from tcllib + # is identical in function. + + return [list ::apply [list $params $body] {*}$args] +} + +catch {promise::Promise destroy} +oo::class create promise::Promise { + + # The promise state can be one of + # PENDING - Initial state where it has not yet been assigned a + # value or error + # FULFILLED - The promise has been assigned a value + # REJECTED - The promise has been assigned an error + # CHAINED - The promise is attached to another promise + variable _state + + # Stores data that is accessed through the setdata/getdata methods. + # The Promise class itself does not use this. + variable _clientdata + + # The promise value once it is fulfilled or rejected. In the latter + # case, it should be an the error message + variable _value + + # The error dictionary in case promise is rejected + variable _edict + + # Reactions to be notified when the promise is rejected. Each element + # in this list is a pair consisting of the fulfilment reaction + # and the rejection reaction. Either element of the pair could be + # empty signifying no reaction for that case. The list is populated + # via the then method. + variable _reactions + + # Reference counting to free up promises since Tcl does not have + # garbage collection for objects. Garbage collection via reference + # counting only takes place after at least one done/then reaction + # is placed on the event queue, not before. Else promises that + # are immediately resolved on construction would be freed right + # away before the application even gets a chance to call done/then. + variable _do_gc + variable _nrefs + + # If no reject reactions are registered, then the Tcl bgerror + # handler is invoked. But don't want to do this more than once + # so track it + variable _bgerror_done + + constructor {cmd} { + # Create a promise for the asynchronous operation to be initiated + # by $cmd. + # cmd - a command prefix that should initiate an asynchronous + # operation. + # The command prefix $cmd is passed an additional argument - the + # name of this Promise object. It should arrange for one of the + # object's settle methods [fulfill], [chain] or + # [reject] to be called when the operation completes. + + set _state PENDING + set _reactions [list ] + set _do_gc 0 + set _bgerror_done 0 + set _nrefs 0 + array set _clientdata {} + + # Errors in the construction command are returned via + # the standard mechanism of reject. + # + if {[catch { + # For some special cases, $cmd may be "" if the async operation + # is initiated outside the constructor. This is not a good + # thing because the error in the initiator will not be + # trapped via the standard promise error catching mechanism + # but that's the application's problem (actually pgeturl also + # uses this). + if {[llength $cmd]} { + uplevel #0 [linsert $cmd end [self]] + } + } msg edict]} { + my reject $msg $edict + } + } + + destructor { + # Destroys the object. + # + # This method should not be generally called directly as [Promise] + # objects are garbage collected either automatically or via the [ref] + # and [unref] methods. + } + + method state {} { + # Returns the current state of the promise. + # + # The promise state may be one of the values `PENDING`, + # `FULFILLED`, `REJECTED` or `CHAINED` + return $_state + } + + method getdata {key} { + # Returns data previously stored through the setdata method. + # key - key whose associated values is to be returned. + # An error will be raised if no value is associated with the key. + return $_clientdata($key) + } + + method setdata {key value} { + # Sets a value to be associated with a key. + # key - the lookup key + # value - the value to be associated with the key + # A promise internally maintains a dictionary whose values can + # be accessed with the [getdata] and [setdata] methods. This + # dictionary is not used by the Promise class itself but is meant + # to be used by promise library specializations or applications. + # Callers need to take care that keys used for a particular + # promise are sufficiently distinguishable so as to not clash. + # + # Returns the value stored with the key. + set _clientdata($key) $value + } + + method value {} { + # Returns the settled value for the promise. + # + # The returned value may be the fulfilled value or the rejected + # value depending on whether the associated operation was successfully + # completed or failed. + # + # An error is raised if the promise is not settled yet. + if {$_state ni {FULFILLED REJECTED}} { + error "Value is not set." + } + return $_value + } + + method ref {} { + # Increments the reference count for the object. + incr _nrefs + } + + method unref {} { + # Decrements the reference count for the object. + # + # The object may have been destroyed when the call returns. + incr _nrefs -1 + my GC + } + + method nrefs {} { + # Returns the current reference count. + # + # Use for debugging only! Note, internal references are not included. + return $_nrefs + } + + method GC {} { + if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { + my destroy + } + } + + method FulfillAttached {value} { + if {$_state ne "CHAINED"} { + return + } + set _value $value + set _state FULFILLED + my ScheduleReactions + return + } + + method RejectAttached {reason edict} { + if {$_state ne "CHAINED"} { + return + } + set _value $reason + set _edict $edict + set _state REJECTED + my ScheduleReactions + return + } + + # Method to invoke to fulfil a promise with a value or another promise. + method fulfill {value} { + # Fulfills the promise. + # value - the value with which the promise is fulfilled + # + # Returns `0` if promise had already been settled and `1` if + # it was fulfilled by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `FULFILLED` state with + # the value specified by $value. If there are any fulfillment + # reactions registered by the [Promise.done] or [Promise.then] methods, they + # are scheduled to be run. + set _value $value + set _state FULFILLED + my ScheduleReactions + return 1 + } + + # Method to invoke to fulfil a promise with a value or another promise. + method chain {promise} { + # Chains the promise to another promise. + # promise - the [Promise] object to which this promise is to + # be chained + # + # Returns `0` if promise had already been settled and `1` otherwise. + + #ruff + # If the promise on which this method is called + # has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; + } + + #ruff + # Otherwise, it is chained to $promise so that it reflects that + # other promise's state. + if {[catch { + $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] + } msg edict]} { + my reject $msg $edict + } else { + set _state CHAINED + } + + return 1 + } + + method reject {reason {edict {}}} { + # Rejects the promise. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # + # The $reason and $edict values are passed on to the rejection + # reactions. By convention, these should be of the form returned + # by the `catch` or `try` commands in case of errors. + # + # Returns `0` if promise had already been settled and `1` if + # it was rejected by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `REJECTED` state. If + # there are any reject reactions registered by the [Promise.done] or + # [Promise.then] methods, they are scheduled to be run. + + set _value $reason + #ruff + # If $edict is not specified, or specified as an empty string, + # a suitable error dictionary is constructed in its place + # to be passed to the reaction. + if {$edict eq ""} { + catch {throw {PROMISE REJECTED} $reason} - edict + } + set _edict $edict + set _state REJECTED + my ScheduleReactions + return 1 + } + + # Internal method to queue all registered reactions based on + # whether the promise is succesfully fulfilled or not + method ScheduleReactions {} { + if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { + # Promise is not settled or no reactions registered + return + } + + # Note on garbage collection: garbage collection is to be enabled if + # at least one FULFILLED or REJECTED reaction is registered. + # Also if the promise is REJECTED but no rejection handlers are run + # we also schedule a background error. + # In all cases, CLEANUP reactions do not count. + foreach reaction $_reactions { + foreach type {FULFILLED REJECTED} { + if {[dict exists $reaction $type]} { + set _do_gc 1 + if {$type eq $_state} { + set cmd [dict get $reaction $type] + if {[llength $cmd]} { + if {$type eq "FULFILLED"} { + lappend cmd $_value + } else { + lappend cmd $_value $_edict + } + set ran_reaction($type) 1 + # Enqueue the reaction via the event loop + after 0 [list after idle $cmd] + } + } + } + } + if {[dict exists $reaction CLEANUP]} { + set cmd [dict get $reaction CLEANUP] + if {[llength $cmd]} { + # Enqueue the cleaner via the event loop passing the + # *state* as well as the value + if {$_state eq "REJECTED"} { + lappend cmd $_state $_value $_edict + } else { + lappend cmd $_state $_value + } + after 0 [list after idle $cmd] + # Note we do not set _do_gc if we only run cleaners + } + } + } + set _reactions [list ] + + # Check for need to background error (see comments above) + if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { + # TBD - should we also check _nrefs before backgrounding error? + + # Wrap in catch in case $_edict does not follow error conventions + # or is not even a dictionary + if {[catch { + dict get $_edict -level + dict get $_edict -code + }]} { + catch {throw {PROMISE REJECT} $_value} - edict + } else { + set edict $_edict + } + # TBD - how exactly is level to be handled? + # If -level is not 0, bgerror barfs because it treates + # it as TCL_RETURN no matter was -code is + dict set edict -level 0 + after idle [interp bgerror {}] [list $_value $edict] + set _bgerror_done 1 + } + + my GC + return + } + + method RegisterReactions {args} { + # Registers the specified reactions. + # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` + # with values being the corresponding reaction callback + + lappend _reactions $args + my ScheduleReactions + return + } + + method done {{on_fulfill {}} {on_reject {}}} { + # Registers reactions to be run when the promise is settled. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. + # Reactions are called with an additional argument which is + # the value with which the promise was settled. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # The method triggers garbage collection of the object if the + # promise has been settled and any registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Note that both $on_fulfill and $on_reject may be specified + # as empty strings if no further action needs to be taken on + # settlement of the promise. If the promise is rejected, and + # no rejection reactions are registered, the error is reported + # via the Tcl `interp bgerror` facility. + + # TBD - as per the Promise/A+ spec, errors in done should generate + # a background error (unlike then). + + my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject + + #ruff + # The method does not return a value. + return + } + + method then {on_fulfill {on_reject {}}} { + # Registers reactions to be run when the promise is settled + # and returns a new [Promise] object that will be settled by the + # reactions. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. If an empty string, no fulfill + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. If unspecified or an empty string, + # no reject reaction is registered. + # Both reactions are passed the value with which the promise was settled. + # The reject reaction is passed an additional argument which is + # the error dictionary. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # If the reaction that is invoked runs without error, its return + # value fulfills the new promise returned by the `then` method. + # If it raises an exception, the new promise will be rejected + # with the error message and dictionary from the exception. + # + # Alternatively, the reactions can explicitly invoke commands + # [then_fulfill], [then_reject] or [then_chain] to + # resolve the returned promise. In this case, the return value + # (including exceptions) from the reactions are ignored. + # + # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), + # the new promise is created and fulfilled (or rejected) with + # the same value that would have been passed in to the reactions. + # + # The method triggers garbage collection of the object if the + # promise has been settled and registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Returns a new promise that is settled by the registered reactions. + + set then_promise [[self class] new ""] + my RegisterReactions \ + FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ + REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] + return $then_promise + } + + # This could be a forward, but then we cannot document it via ruff! + method catch {on_reject} { + # Registers reactions to be run when the promise is rejected. + # on_reject - command prefix for the reaction + # reaction to run if the promise is rejected. If unspecified + # or an empty string, no reject reaction is registered. The + # reaction is called with an additional argument which is the + # value with which the promise was settled. + # This method is just a wrapper around [Promise.then] with the + # `on_fulfill` parameter defaulting to an empty string. See + # the description of that method for details. + return [my then "" $on_reject] + } + + method cleanup {cleaner} { + # Registers a reaction to be executed for running cleanup + # code when the promise is settled. + # cleaner - command prefix to run on settlement + # This method is intended to run a clean up script + # when a promise is settled. Its primary use is to avoid duplication + # of code in the `then` and `catch` handlers for a promise. + # It may also be called multiple times + # to clean up intermediate steps when promises are chained. + # + # The method returns a new promise that will be settled + # as per the following rules. + # - if the cleaner runs without errors, the returned promise + # will reflect the settlement of the promise on which this + # method is called. + # - if the cleaner raises an exception, the returned promise + # is rejected with a value consisting of the error message + # and dictionary pair. + # + # Returns a new promise that is settled based on the cleaner + set cleaner_promise [[self class] new ""] + my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] + return $cleaner_promise + } +} + +proc promise::_then_reaction {target_promise status cmd value {edict {}}} { + # Run the specified command and fulfill/reject the target promise + # accordingly. If the command is empty, the passed-in value is passed + # on to the target promise. + + # IMPORTANT!!!! + # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else + # promise::then_fulfill/then_reject/then_chain will not work + # Also, Do NOT change the param name target_promise without changing + # those procs. + # Oh what a hack to get around lack of closures. Alternative would have + # been to pass an additional parameter (target_promise) + # to the application code but then that script would have had to + # carry that around. + + if {[info level] != 1} { + error "Internal error: _then_reaction not at level 1" + } + + if {[llength $cmd] == 0} { + switch -exact -- $status { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict} + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid status $state" + } + } + } else { + # Invoke the real reaction code and fulfill/reject the target promise. + # Note the reaction code may have called one of the promise::then_* + # commands itself and reactions run resulting in the object being + # freed. Hence resolve using the safe* variants + # TBD - ideally we would like to execute at global level. However + # the then_* commands retrieve target_promise from level 1 (here) + # which they cannot if uplevel #0 is done. So directly invoke. + if {$status eq "REJECTED"} { + lappend cmd $value $edict + } else { + lappend cmd $value + } + if {[catch $cmd reaction_value reaction_edict]} { + safe_reject $target_promise $reaction_value $reaction_edict + } else { + safe_fulfill $target_promise $reaction_value + } + } + return +} + +proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { + # Run the specified cleaner and fulfill/reject the target promise + # accordingly. If the cleaner executes without error, the original + # value and state is passed on. If the cleaner executes with error + # the promise is rejected. + + if {[llength $cleaner] == 0} { + switch -exact -- $state { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict } + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid state $state" + } + } + } else { + if {[catch {uplevel #0 $cleaner} err edict]} { + # Cleaner failed. Reject the target promise + $target_promise reject $err $edict + } else { + # Cleaner completed without errors, pass on the original value + if {$state eq "FULFILLED"} { + $target_promise fulfill $value + } else { + $target_promise reject $value $edict + } + } + } + return +} + +proc promise::then_fulfill {value} { + # Fulfills the promise returned by a [Promise.then] method call from + # within its reaction. + # value - the value with which to fulfill the promise + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - `then_fulfill`, + # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + + # TBD - what if someone calls this from within a uplevel #0 ? The + # upvar will be all wrong + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_fulfill called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise fulfill $value +} + +proc promise::then_chain {promise} { + # Chains the promise returned by a [Promise.then] method call to + # another promise. + # promise - the promise to which the promise returned by [Promise.then] is + # to be chained + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_chain` chains + # the promise returned by the `then` method that queued the currently + # running reaction to $promise so that the former will be settled + # based on the latter. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_chain called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise chain $promise +} + +proc promise::then_reject {reason edict} { + # Rejects the promise returned by a [Promise.then] method call from + # within its reaction. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_reject` rejects + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_reject called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise reject $reason $edict +} + +proc promise::all {promises} { + # Returns a promise that fulfills or rejects when all promises + # in the $promises argument have fulfilled or any one has rejected. + # promises - a list of Promise objects + # If any of $promises rejects, then the promise returned by the + # command will reject with the same value. Otherwise, the promise + # will fulfill when all promises have fulfilled. + # The resolved value will be a list of the resolved + # values of the contained promises. + + set all_promise [Promise new [lambda {promises prom} { + set npromises [llength $promises] + if {$npromises == 0} { + $prom fulfill {} + return + } + + # Ask each promise to update us when resolved. + foreach promise $promises { + $promise done \ + [list ::promise::_all_helper $prom $promise FULFILLED] \ + [list ::promise::_all_helper $prom $promise REJECTED] + } + + # We keep track of state with a dictionary that will be + # stored in $prom with the following keys: + # PROMISES - the list of promises in the order passed + # PENDING_COUNT - count of unresolved promises + # RESULTS - dictionary keyed by promise and containing resolved value + set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] + + $prom setdata ALLPROMISES $all_state + } $promises]] + + return $all_promise +} + +proc promise::all* args { + # Returns a promise that fulfills or rejects when all promises + # in the $args argument have fulfilled or any one has rejected. + # args - list of Promise objects + # This command is identical to the all command except that it takes + # multiple arguments, each of which is a Promise object. See [all] + # for a description. + return [all $args] +} + +# Callback for promise::all. +# all_promise - the "master" promise returned by the all call. +# done_promise - the promise whose callback is being serviced. +# resolution - whether the current promise was resolved with "FULFILLED" +# or "REJECTED" +# value - the value of the currently fulfilled promise or error description +# in case rejected +# edict - error dictionary (if promise was rejected) +proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { + if {![info object isa object $all_promise]} { + # The object has been deleted. Naught to do + return + } + if {[$all_promise state] ne "PENDING"} { + # Already settled. This can happen when a tracked promise is + # rejected and another tracked promise gets settled afterwards. + return + } + if {$resolution eq "REJECTED"} { + # This promise failed. Immediately reject the master promise + # TBD - can we somehow indicate which promise failed ? + $all_promise reject $value $edict + return + } + + # Update the state of the resolved tracked promise + set all_state [$all_promise getdata ALLPROMISES] + dict set all_state RESULTS $done_promise $value + dict incr all_state PENDING_COUNT -1 + $all_promise setdata ALLPROMISES $all_state + + # If all promises resolved, resolve the all promise + if {[dict get $all_state PENDING_COUNT] == 0} { + set values {} + foreach prom [dict get $all_state PROMISES] { + lappend values [dict get $all_state RESULTS $prom] + } + $all_promise fulfill $values + } + return +} + +proc promise::race {promises} { + # Returns a promise that fulfills or rejects when any promise + # in the $promises argument is fulfilled or rejected. + # promises - a list of Promise objects + # The returned promise will fulfill and reject with the same value + # as the first promise in $promises that fulfills or rejects. + set race_promise [Promise new [lambda {promises prom} { + if {[llength $promises] == 0} { + catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict + $prom reject $reason $edict + return + } + # Use safe_*, do not directly call methods since $prom may be + # gc'ed once settled + foreach promise $promises { + $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] + } + } $promises]] + + return $race_promise +} + +proc promise::race* {args} { + # Returns a promise that fulfills or rejects when any promise + # in the passed arguments is fulfilled or rejected. + # args - list of Promise objects + # This command is identical to the `race` command except that it takes + # multiple arguments, each of which is a Promise object. See [race] + # for a description. + return [race $args] +} + +proc promise::await {prom} { + # Waits for a promise to be settled and returns its resolved value. + # prom - the promise that is to be waited on + # This command may only be used from within a procedure constructed + # with the [async] command or any code invoked from it. + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + set coro [info coroutine] + if {$coro eq ""} { + throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" + } + $prom done [list $coro success] [list $coro fail] + lassign [yieldto return -level 0] status val ropts + if {$status eq "success"} { + return $val + } else { + return -options $ropts $val + } +} + +proc promise::async {name paramdefs body} { + # Defines an procedure that will run a script asynchronously as a coroutine. + # name - name of the procedure + # paramdefs - the parameter definitions to the procedure in the same + # form as passed to the standard `proc` command + # body - the script to be executed + # + # When the defined procedure $name is called, it runs the supplied $body + # within a new coroutine. The return value from the $name procedure call + # will be a promise that will be fulfilled when the coroutine completes + # normally or rejected if it completes with an error. + # + # Note that the passed $body argument is not the body of the + # the procedure $name. Rather it is run as an anonymous procedure in + # the coroutine but in the same namespace context as $name. Thus the + # caller or the $body script must not make any assumptions about + # relative stack levels, use of `uplevel` etc. + # + # The primary purpose of this command is to make it easy, in + # conjunction with the [await] command, to wrap a sequence of asynchronous + # operations as a single computational unit. + # + # Returns a promise that will be settled with the result of the script. + if {![string equal -length 2 "$name" "::"]} { + set ns [uplevel 1 namespace current] + set name ${ns}::$name + } else { + set ns :: + } + set tmpl { + proc %NAME% {%PARAMDEFS%} { + set p [promise::Promise new [promise::lambda {real_args prom} { + coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { + upvar #1 _current_async_promise current_p + set current_p $p + set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] + if {$status == 0} { + $p fulfill $res + } else { + $p reject $res $ropts + } + } $prom {*}$real_args] + } [lrange [info level 0] 1 end]]] + return $p + } + } + eval [string map [list %NAME% $name \ + %PARAMDEFS% $paramdefs \ + %BODY% $body \ + %NS% $ns] $tmpl] +} + +proc promise::async_fulfill {val} { + # Fulfills a promise for an async procedure with the specified value. + # val - the value with which to fulfill the promise + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_fulfill called from outside an async context." + } + $current_p fulfill $val + return +} + +proc promise::async_reject {val {edict {}}} { + # Rejects a promise for an async procedure with the specified value. + # val - the value with which to reject the promise + # edict - error dictionary for rejection + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_reject called from outside an async context." + } + $current_p reject $val $edict + return +} + +proc promise::async_chain {prom} { + # Chains a promise for an async procedure to the specified promise. + # prom - the promise to which the async promise is to be linked. + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_chain called from outside an async context." + } + $current_p chain $prom + return +} + +proc promise::pfulfilled {value} { + # Returns a new promise that is already fulfilled with the specified value. + # value - the value with which to fulfill the created promise + return [Promise new [lambda {value prom} { + $prom fulfill $value + } $value]] +} + +proc promise::prejected {value {edict {}}} { + # Returns a new promise that is already rejected. + # value - the value with which to reject the promise + # edict - error dictionary for rejection + # By convention, $value should be of the format returned by + # [Promise.reject]. + return [Promise new [lambda {value edict prom} { + $prom reject $value $edict + } $value $edict]] +} + +proc promise::eventloop {prom} { + # Waits in the eventloop until the specified promise is settled. + # prom - the promise to be waited on + # The command enters the event loop in similar fashion to the + # Tcl `vwait` command except that instead of waiting on a variable + # the command waits for the specified promise to be settled. As such + # it has the same caveats as the vwait command in terms of care + # being taken in nested calls etc. + # + # The primary use of the command is at the top level of a script + # to wait for one or more promise based tasks to be completed. Again, + # similar to the vwait forever idiom. + # + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + + set varname [namespace current]::_pwait_[info cmdcount] + $prom done \ + [lambda {varname result} { + set $varname [list success $result] + } $varname] \ + [lambda {varname error ropts} { + set $varname [list fail $error $ropts] + } $varname] + vwait $varname + lassign [set $varname] status result ropts + if {$status eq "success"} { + return $result + } else { + return -options $ropts $result + } +} + +proc promise::pgeturl {url args} { + # Returns a promise that will be fulfilled when the URL is fetched. + # url - the URL to fetch + # args - arguments to pass to the `http::geturl` command + # This command invokes the asynchronous form of the `http::geturl` command + # of the `http` package. If the operation completes with a status of + # `ok`, the returned promise is fulfilled with the contents of the + # http state array (see the documentation of `http::geturl`). If the + # the status is anything else, the promise is rejected with + # the `reason` parameter to the reaction containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # with an additional key `http_state`, containing the + # contents of the http state array. + + uplevel #0 {package require http} + proc pgeturl {url args} { + set prom [Promise new [lambda {http_args prom} { + http::geturl {*}$http_args -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + if {$http_state(status) eq "ok"} { + $prom fulfill [array get http_state] + } else { + if {[info exists http_state(error)]} { + set msg [lindex $http_state(error) 0] + } + if {![info exists msg] || $msg eq ""} { + set msg "Error retrieving URL." + } + catch {throw {PROMISE PGETURL} $msg} msg edict + dict set edict http_state [array get http_state] + $prom reject $msg $edict + } + http::cleanup $tok + } $prom] + } [linsert $args 0 $url]]] + return $prom + } + tailcall pgeturl $url {*}$args +} + +proc promise::ptimer {millisecs {value "Timer expired."}} { + # Returns a promise that will be fulfilled when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be fulfilled + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to an error + # message and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimeout] which is similar but rejects the promise instead + # of fulfilling it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't allow "idle", "cancel" etc. as an argument to after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [list promise::safe_fulfill $prom $value] + } $millisecs $value]] +} + +proc promise::ptimeout {millisecs {value "Operation timed out."}} { + # Returns a promise that will be rejected when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be rejected + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to $value + # and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimer] which is similar but fulfills the promise instead + # of rejecting it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't want to accept "idle", "cancel" etc. for after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [::promise::lambda {prom msg} { + catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict + ::promise::safe_reject $prom $msg $edict + } $prom $value] + } $millisecs $value]] +} + +proc promise::pconnect {args} { + # Returns a promise that will be fulfilled when the socket connection + # is completed. + # args - arguments to be passed to the Tcl `socket` command + # This is a wrapper for the async version of the Tcl `socket` command. + # If the connection completes, the promise is fulfilled with the + # socket handle. + # In case of errors (e.g. if the address cannot be fulfilled), the + # promise is rejected with the `reason` parameter containing the + # error message and the `edict` parameter containing the Tcl error + # dictionary. + # + return [Promise new [lambda {so_args prom} { + set so [socket -async {*}$so_args] + fileevent $so writable [promise::lambda {prom so} { + fileevent $so writable {} + set err [chan configure $so -error] + if {$err eq ""} { + $prom fulfill $so + } else { + catch {throw {PROMISE PCONNECT FAIL} $err} err edict + $prom reject $err $edict + } + } $prom $so] + } $args]] +} + +proc promise::_read_channel {prom chan data} { + set newdata [read $chan] + if {[string length $newdata] || ![eof $chan]} { + append data $newdata + fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] + return + } + + # EOF + set code [catch { + # Need to make the channel blocking else no error is returned + # on the close + fileevent $chan readable {} + fconfigure $chan -blocking 1 + close $chan + } result edict] + if {$code} { + safe_reject $prom $result $edict + } else { + safe_fulfill $prom $data + } +} + +proc promise::pexec {args} { + # Runs an external program and returns a promise for its output. + # args - program and its arguments as passed to the Tcl `open` call + # for creating pipes + # If the program runs without errors, the promise is fulfilled by its + # standard output content. Otherwise + # promise is rejected. + # + # Returns a promise that will be settled by the result of the program + return [Promise new [lambda {open_args prom} { + set chan [open |$open_args r] + fconfigure $chan -blocking 0 + fileevent $chan readable [list promise::_read_channel $prom $chan ""] + } $args]] +} + +proc promise::safe_fulfill {prom value} { + # Fulfills the specified promise. + # prom - the [Promise] object to be fulfilled + # value - the fulfillment value + # This is a convenience command that checks if $prom still exists + # and if so fulfills it with $value. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [fulfill][Promise.fulfill] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return 0 + } + return [$prom fulfill $value] +} + +proc promise::safe_reject {prom value {edict {}}} { + # Rejects the specified promise. + # prom - the [Promise] object to be fulfilled + # value - see [Promise.reject] + # edict - see [Promise.reject] + # This is a convenience command that checks if $prom still exists + # and if so rejects it with the specified arguments. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [reject][Promise.reject] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return + } + $prom reject $value $edict +} + +proc promise::ptask {script} { + # Creates a new Tcl thread to run the specified script and returns + # a promise for the script results. + # script - script to run in the thread + # Returns a promise that will be settled by the result of the script + # + # The `ptask` command runs the specified script in a new Tcl + # thread. The promise returned from this command will be fulfilled + # with the result of the script if it completes + # successfully. Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + # + # The command requires the Thread package to be loaded. + + uplevel #0 package require Thread + proc [namespace current]::ptask script { + return [Promise new [lambda {script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + # ok or return + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + thread::create $thread_script + } $script]] + } + tailcall [namespace current]::ptask $script +} + +proc promise::pworker {tpool script} { + # Runs a script in a worker thread from a thread pool and + # returns a promise for the same. + # tpool - thread pool identifier + # script - script to run in the worker thread + # Returns a promise that will be settled by the result of the script + # + # The Thread package allows creation of a thread pool with the + # `tpool create` command. The `pworker` command runs the specified + # script in a worker thread from a thread pool. The promise + # returned from this command will be fulfilled with the result of + # the script if it completes successfully. + # Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + + # No need for package require Thread since if tpool is passed to + # us, Thread must already be loaded + return [Promise new [lambda {tpool script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + tpool::post -detached -nowait $tpool $thread_script + } $tpool $script]] +} + +if {0} { + package require http + proc checkurl {url} { + set prom [promise::Promise new [promise::lambda {url prom} { + http::geturl $url -method HEAD -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + $prom fulfill [list $http_state(url) $http_state(status)] + ::http::cleanup $tok + } $prom] + } $url]] + return $prom + } + + proc checkurls {urls} { + return [promise::all [lmap url $urls {checkurl $url}]] + } + + [promise::all [ + list [ + promise::ptask {expr 1+1} + ] [ + promise::ptask {expr 2+2} + ] + ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] +} + +package provide promise [promise::version] + +if {[info exists ::argv0] && + [file tail [info script]] eq [file tail $::argv0]} { + set filename [file tail [info script]] + if {[llength $::argv] == 0} { + puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" + exit 1 + } + switch -glob -- [lindex $::argv 0] { + ver* { puts [promise::version] } + tm - + dist* { + if {[file extension $filename] ne ".tm"} { + set dir [file join [file dirname [info script]] .. build] + file mkdir $dir + file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] + } else { + error "Cannot create distribution from a .tm file" + } + } + install { + # Install in first native file system that exists on search path + foreach path [tcl::tm::path list] { + if {[lindex [file system $path] 0] eq "native"} { + set dir $path + if {[file isdirectory $path]} { + break + } + # Else keep looking + } + } + if {![file exists $dir]} { + file mkdir $dir + } + if {[file extension $filename] eq ".tm"} { + # We already are a .tm with version number + set target $filename + } else { + set target [file rootname $filename]-[promise::version].tm + } + file copy -force [info script] [file join $dir $target] + } + default { + puts stderr "Unknown option/command \"[lindex $::argv 0]\"" + exit 1 + } + } +} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index e940dada..74a3ffc8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -4001,7 +4001,17 @@ tcl::namespace::eval punk::args { set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { - set chosen $v_test + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set set choice_in_list 1 } else { #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. @@ -4046,6 +4056,7 @@ tcl::namespace::eval punk::args { } } + #override the optimistic existing val if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 2e10e75b..a8884746 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -740,18 +740,27 @@ namespace eval punk::console { set was_raw 1 set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + puts -nonewline $output $query;flush $output chan configure $input -blocking 0 set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on set tsclock($callid) $tslaunch($callid) - #write before console enableRaw vs after?? - #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it - puts -nonewline $output $query;flush $output + #after 0 + #------------------ + #trying alternatives to get faster read and maintain reliability..REVIEW + #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features + #------------------ + # 1) faster - races? + $this_handler $input $callid $capturingendregex $this_handler $input $callid $capturingendregex - if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } + # 2) more reliable? + #chan event $input readable [list $this_handler $input $callid $capturingendregex] + #------------------ #response from terminal @@ -794,7 +803,7 @@ namespace eval punk::console { if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { - puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" + puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" } if {$was_raw == 0} { @@ -956,9 +965,10 @@ namespace eval punk::console { set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] #review - what is min length of any ansiresponse? + #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z #endregex is capturing - but as we are only testing the match here #it should perform the same as if it were non-capturing - if {[string length $sofar] > 3 && [regexp $endregex $sofar]} { + if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" chan event $chan readable {} set waits($callid) ok @@ -1438,7 +1448,8 @@ namespace eval punk::console { -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 newsize -default "" -help\ - "character cell pixel dimensions WxH" + "character cell pixel dimensions WxH + or omit to query cell size." } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] @@ -1474,6 +1485,31 @@ namespace eval punk::console { } set cell_size ${w}x${h} } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #puts -->$payload<-- + return [expr {$payload in {Z K M}}] + } #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { @@ -1587,7 +1623,6 @@ namespace eval punk::console { } - proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?7\$p" @@ -1683,7 +1718,14 @@ namespace eval punk::console { return } - puts -nonewline stdout $char_or_string + #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error + #e.g contains surrogate pair + if {[catch { + puts -nonewline stdout $char_or_string + } errM]} { + puts stderr "test_char_width couldn't emit this string - \nerror: $errM" + } + set response [punk::console::get_cursor_pos] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config index 816f3331..247371ee 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config @@ -23,6 +23,7 @@ set bootsupport_modules [list\ src/vendormodules patterncmd\ src/vendormodules patternlib\ src/vendormodules patternpredator2\ + src/vendormodules promise\ src/vendormodules sha1\ src/vendormodules tomlish\ src/vendormodules test::tomlish\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/promise-1.2.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/promise-1.2.0.tm new file mode 100644 index 00000000..a4b82e45 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/promise-1.2.0.tm @@ -0,0 +1,1311 @@ +# Copyright (c) 2015-2023, Ashok P. Nadkarni +# All rights reserved. + +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: + +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. + +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. + +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +package require Tcl 8.6- + +namespace eval promise { + proc version {} { return 1.2.0 } +} + +proc promise::lambda {params body args} { + # Creates an anonymous procedure and returns a command prefix for it. + # params - parameter definitions for the procedure + # body - body of the procedures + # args - additional arguments to be passed to the procedure when it + # is invoked + # + # This is just a convenience command since anonymous procedures are + # commonly useful with promises. The lambda package from tcllib + # is identical in function. + + return [list ::apply [list $params $body] {*}$args] +} + +catch {promise::Promise destroy} +oo::class create promise::Promise { + + # The promise state can be one of + # PENDING - Initial state where it has not yet been assigned a + # value or error + # FULFILLED - The promise has been assigned a value + # REJECTED - The promise has been assigned an error + # CHAINED - The promise is attached to another promise + variable _state + + # Stores data that is accessed through the setdata/getdata methods. + # The Promise class itself does not use this. + variable _clientdata + + # The promise value once it is fulfilled or rejected. In the latter + # case, it should be an the error message + variable _value + + # The error dictionary in case promise is rejected + variable _edict + + # Reactions to be notified when the promise is rejected. Each element + # in this list is a pair consisting of the fulfilment reaction + # and the rejection reaction. Either element of the pair could be + # empty signifying no reaction for that case. The list is populated + # via the then method. + variable _reactions + + # Reference counting to free up promises since Tcl does not have + # garbage collection for objects. Garbage collection via reference + # counting only takes place after at least one done/then reaction + # is placed on the event queue, not before. Else promises that + # are immediately resolved on construction would be freed right + # away before the application even gets a chance to call done/then. + variable _do_gc + variable _nrefs + + # If no reject reactions are registered, then the Tcl bgerror + # handler is invoked. But don't want to do this more than once + # so track it + variable _bgerror_done + + constructor {cmd} { + # Create a promise for the asynchronous operation to be initiated + # by $cmd. + # cmd - a command prefix that should initiate an asynchronous + # operation. + # The command prefix $cmd is passed an additional argument - the + # name of this Promise object. It should arrange for one of the + # object's settle methods [fulfill], [chain] or + # [reject] to be called when the operation completes. + + set _state PENDING + set _reactions [list ] + set _do_gc 0 + set _bgerror_done 0 + set _nrefs 0 + array set _clientdata {} + + # Errors in the construction command are returned via + # the standard mechanism of reject. + # + if {[catch { + # For some special cases, $cmd may be "" if the async operation + # is initiated outside the constructor. This is not a good + # thing because the error in the initiator will not be + # trapped via the standard promise error catching mechanism + # but that's the application's problem (actually pgeturl also + # uses this). + if {[llength $cmd]} { + uplevel #0 [linsert $cmd end [self]] + } + } msg edict]} { + my reject $msg $edict + } + } + + destructor { + # Destroys the object. + # + # This method should not be generally called directly as [Promise] + # objects are garbage collected either automatically or via the [ref] + # and [unref] methods. + } + + method state {} { + # Returns the current state of the promise. + # + # The promise state may be one of the values `PENDING`, + # `FULFILLED`, `REJECTED` or `CHAINED` + return $_state + } + + method getdata {key} { + # Returns data previously stored through the setdata method. + # key - key whose associated values is to be returned. + # An error will be raised if no value is associated with the key. + return $_clientdata($key) + } + + method setdata {key value} { + # Sets a value to be associated with a key. + # key - the lookup key + # value - the value to be associated with the key + # A promise internally maintains a dictionary whose values can + # be accessed with the [getdata] and [setdata] methods. This + # dictionary is not used by the Promise class itself but is meant + # to be used by promise library specializations or applications. + # Callers need to take care that keys used for a particular + # promise are sufficiently distinguishable so as to not clash. + # + # Returns the value stored with the key. + set _clientdata($key) $value + } + + method value {} { + # Returns the settled value for the promise. + # + # The returned value may be the fulfilled value or the rejected + # value depending on whether the associated operation was successfully + # completed or failed. + # + # An error is raised if the promise is not settled yet. + if {$_state ni {FULFILLED REJECTED}} { + error "Value is not set." + } + return $_value + } + + method ref {} { + # Increments the reference count for the object. + incr _nrefs + } + + method unref {} { + # Decrements the reference count for the object. + # + # The object may have been destroyed when the call returns. + incr _nrefs -1 + my GC + } + + method nrefs {} { + # Returns the current reference count. + # + # Use for debugging only! Note, internal references are not included. + return $_nrefs + } + + method GC {} { + if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { + my destroy + } + } + + method FulfillAttached {value} { + if {$_state ne "CHAINED"} { + return + } + set _value $value + set _state FULFILLED + my ScheduleReactions + return + } + + method RejectAttached {reason edict} { + if {$_state ne "CHAINED"} { + return + } + set _value $reason + set _edict $edict + set _state REJECTED + my ScheduleReactions + return + } + + # Method to invoke to fulfil a promise with a value or another promise. + method fulfill {value} { + # Fulfills the promise. + # value - the value with which the promise is fulfilled + # + # Returns `0` if promise had already been settled and `1` if + # it was fulfilled by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `FULFILLED` state with + # the value specified by $value. If there are any fulfillment + # reactions registered by the [Promise.done] or [Promise.then] methods, they + # are scheduled to be run. + set _value $value + set _state FULFILLED + my ScheduleReactions + return 1 + } + + # Method to invoke to fulfil a promise with a value or another promise. + method chain {promise} { + # Chains the promise to another promise. + # promise - the [Promise] object to which this promise is to + # be chained + # + # Returns `0` if promise had already been settled and `1` otherwise. + + #ruff + # If the promise on which this method is called + # has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; + } + + #ruff + # Otherwise, it is chained to $promise so that it reflects that + # other promise's state. + if {[catch { + $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] + } msg edict]} { + my reject $msg $edict + } else { + set _state CHAINED + } + + return 1 + } + + method reject {reason {edict {}}} { + # Rejects the promise. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # + # The $reason and $edict values are passed on to the rejection + # reactions. By convention, these should be of the form returned + # by the `catch` or `try` commands in case of errors. + # + # Returns `0` if promise had already been settled and `1` if + # it was rejected by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `REJECTED` state. If + # there are any reject reactions registered by the [Promise.done] or + # [Promise.then] methods, they are scheduled to be run. + + set _value $reason + #ruff + # If $edict is not specified, or specified as an empty string, + # a suitable error dictionary is constructed in its place + # to be passed to the reaction. + if {$edict eq ""} { + catch {throw {PROMISE REJECTED} $reason} - edict + } + set _edict $edict + set _state REJECTED + my ScheduleReactions + return 1 + } + + # Internal method to queue all registered reactions based on + # whether the promise is succesfully fulfilled or not + method ScheduleReactions {} { + if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { + # Promise is not settled or no reactions registered + return + } + + # Note on garbage collection: garbage collection is to be enabled if + # at least one FULFILLED or REJECTED reaction is registered. + # Also if the promise is REJECTED but no rejection handlers are run + # we also schedule a background error. + # In all cases, CLEANUP reactions do not count. + foreach reaction $_reactions { + foreach type {FULFILLED REJECTED} { + if {[dict exists $reaction $type]} { + set _do_gc 1 + if {$type eq $_state} { + set cmd [dict get $reaction $type] + if {[llength $cmd]} { + if {$type eq "FULFILLED"} { + lappend cmd $_value + } else { + lappend cmd $_value $_edict + } + set ran_reaction($type) 1 + # Enqueue the reaction via the event loop + after 0 [list after idle $cmd] + } + } + } + } + if {[dict exists $reaction CLEANUP]} { + set cmd [dict get $reaction CLEANUP] + if {[llength $cmd]} { + # Enqueue the cleaner via the event loop passing the + # *state* as well as the value + if {$_state eq "REJECTED"} { + lappend cmd $_state $_value $_edict + } else { + lappend cmd $_state $_value + } + after 0 [list after idle $cmd] + # Note we do not set _do_gc if we only run cleaners + } + } + } + set _reactions [list ] + + # Check for need to background error (see comments above) + if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { + # TBD - should we also check _nrefs before backgrounding error? + + # Wrap in catch in case $_edict does not follow error conventions + # or is not even a dictionary + if {[catch { + dict get $_edict -level + dict get $_edict -code + }]} { + catch {throw {PROMISE REJECT} $_value} - edict + } else { + set edict $_edict + } + # TBD - how exactly is level to be handled? + # If -level is not 0, bgerror barfs because it treates + # it as TCL_RETURN no matter was -code is + dict set edict -level 0 + after idle [interp bgerror {}] [list $_value $edict] + set _bgerror_done 1 + } + + my GC + return + } + + method RegisterReactions {args} { + # Registers the specified reactions. + # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` + # with values being the corresponding reaction callback + + lappend _reactions $args + my ScheduleReactions + return + } + + method done {{on_fulfill {}} {on_reject {}}} { + # Registers reactions to be run when the promise is settled. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. + # Reactions are called with an additional argument which is + # the value with which the promise was settled. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # The method triggers garbage collection of the object if the + # promise has been settled and any registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Note that both $on_fulfill and $on_reject may be specified + # as empty strings if no further action needs to be taken on + # settlement of the promise. If the promise is rejected, and + # no rejection reactions are registered, the error is reported + # via the Tcl `interp bgerror` facility. + + # TBD - as per the Promise/A+ spec, errors in done should generate + # a background error (unlike then). + + my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject + + #ruff + # The method does not return a value. + return + } + + method then {on_fulfill {on_reject {}}} { + # Registers reactions to be run when the promise is settled + # and returns a new [Promise] object that will be settled by the + # reactions. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. If an empty string, no fulfill + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. If unspecified or an empty string, + # no reject reaction is registered. + # Both reactions are passed the value with which the promise was settled. + # The reject reaction is passed an additional argument which is + # the error dictionary. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # If the reaction that is invoked runs without error, its return + # value fulfills the new promise returned by the `then` method. + # If it raises an exception, the new promise will be rejected + # with the error message and dictionary from the exception. + # + # Alternatively, the reactions can explicitly invoke commands + # [then_fulfill], [then_reject] or [then_chain] to + # resolve the returned promise. In this case, the return value + # (including exceptions) from the reactions are ignored. + # + # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), + # the new promise is created and fulfilled (or rejected) with + # the same value that would have been passed in to the reactions. + # + # The method triggers garbage collection of the object if the + # promise has been settled and registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Returns a new promise that is settled by the registered reactions. + + set then_promise [[self class] new ""] + my RegisterReactions \ + FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ + REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] + return $then_promise + } + + # This could be a forward, but then we cannot document it via ruff! + method catch {on_reject} { + # Registers reactions to be run when the promise is rejected. + # on_reject - command prefix for the reaction + # reaction to run if the promise is rejected. If unspecified + # or an empty string, no reject reaction is registered. The + # reaction is called with an additional argument which is the + # value with which the promise was settled. + # This method is just a wrapper around [Promise.then] with the + # `on_fulfill` parameter defaulting to an empty string. See + # the description of that method for details. + return [my then "" $on_reject] + } + + method cleanup {cleaner} { + # Registers a reaction to be executed for running cleanup + # code when the promise is settled. + # cleaner - command prefix to run on settlement + # This method is intended to run a clean up script + # when a promise is settled. Its primary use is to avoid duplication + # of code in the `then` and `catch` handlers for a promise. + # It may also be called multiple times + # to clean up intermediate steps when promises are chained. + # + # The method returns a new promise that will be settled + # as per the following rules. + # - if the cleaner runs without errors, the returned promise + # will reflect the settlement of the promise on which this + # method is called. + # - if the cleaner raises an exception, the returned promise + # is rejected with a value consisting of the error message + # and dictionary pair. + # + # Returns a new promise that is settled based on the cleaner + set cleaner_promise [[self class] new ""] + my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] + return $cleaner_promise + } +} + +proc promise::_then_reaction {target_promise status cmd value {edict {}}} { + # Run the specified command and fulfill/reject the target promise + # accordingly. If the command is empty, the passed-in value is passed + # on to the target promise. + + # IMPORTANT!!!! + # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else + # promise::then_fulfill/then_reject/then_chain will not work + # Also, Do NOT change the param name target_promise without changing + # those procs. + # Oh what a hack to get around lack of closures. Alternative would have + # been to pass an additional parameter (target_promise) + # to the application code but then that script would have had to + # carry that around. + + if {[info level] != 1} { + error "Internal error: _then_reaction not at level 1" + } + + if {[llength $cmd] == 0} { + switch -exact -- $status { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict} + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid status $state" + } + } + } else { + # Invoke the real reaction code and fulfill/reject the target promise. + # Note the reaction code may have called one of the promise::then_* + # commands itself and reactions run resulting in the object being + # freed. Hence resolve using the safe* variants + # TBD - ideally we would like to execute at global level. However + # the then_* commands retrieve target_promise from level 1 (here) + # which they cannot if uplevel #0 is done. So directly invoke. + if {$status eq "REJECTED"} { + lappend cmd $value $edict + } else { + lappend cmd $value + } + if {[catch $cmd reaction_value reaction_edict]} { + safe_reject $target_promise $reaction_value $reaction_edict + } else { + safe_fulfill $target_promise $reaction_value + } + } + return +} + +proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { + # Run the specified cleaner and fulfill/reject the target promise + # accordingly. If the cleaner executes without error, the original + # value and state is passed on. If the cleaner executes with error + # the promise is rejected. + + if {[llength $cleaner] == 0} { + switch -exact -- $state { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict } + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid state $state" + } + } + } else { + if {[catch {uplevel #0 $cleaner} err edict]} { + # Cleaner failed. Reject the target promise + $target_promise reject $err $edict + } else { + # Cleaner completed without errors, pass on the original value + if {$state eq "FULFILLED"} { + $target_promise fulfill $value + } else { + $target_promise reject $value $edict + } + } + } + return +} + +proc promise::then_fulfill {value} { + # Fulfills the promise returned by a [Promise.then] method call from + # within its reaction. + # value - the value with which to fulfill the promise + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - `then_fulfill`, + # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + + # TBD - what if someone calls this from within a uplevel #0 ? The + # upvar will be all wrong + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_fulfill called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise fulfill $value +} + +proc promise::then_chain {promise} { + # Chains the promise returned by a [Promise.then] method call to + # another promise. + # promise - the promise to which the promise returned by [Promise.then] is + # to be chained + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_chain` chains + # the promise returned by the `then` method that queued the currently + # running reaction to $promise so that the former will be settled + # based on the latter. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_chain called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise chain $promise +} + +proc promise::then_reject {reason edict} { + # Rejects the promise returned by a [Promise.then] method call from + # within its reaction. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_reject` rejects + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_reject called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise reject $reason $edict +} + +proc promise::all {promises} { + # Returns a promise that fulfills or rejects when all promises + # in the $promises argument have fulfilled or any one has rejected. + # promises - a list of Promise objects + # If any of $promises rejects, then the promise returned by the + # command will reject with the same value. Otherwise, the promise + # will fulfill when all promises have fulfilled. + # The resolved value will be a list of the resolved + # values of the contained promises. + + set all_promise [Promise new [lambda {promises prom} { + set npromises [llength $promises] + if {$npromises == 0} { + $prom fulfill {} + return + } + + # Ask each promise to update us when resolved. + foreach promise $promises { + $promise done \ + [list ::promise::_all_helper $prom $promise FULFILLED] \ + [list ::promise::_all_helper $prom $promise REJECTED] + } + + # We keep track of state with a dictionary that will be + # stored in $prom with the following keys: + # PROMISES - the list of promises in the order passed + # PENDING_COUNT - count of unresolved promises + # RESULTS - dictionary keyed by promise and containing resolved value + set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] + + $prom setdata ALLPROMISES $all_state + } $promises]] + + return $all_promise +} + +proc promise::all* args { + # Returns a promise that fulfills or rejects when all promises + # in the $args argument have fulfilled or any one has rejected. + # args - list of Promise objects + # This command is identical to the all command except that it takes + # multiple arguments, each of which is a Promise object. See [all] + # for a description. + return [all $args] +} + +# Callback for promise::all. +# all_promise - the "master" promise returned by the all call. +# done_promise - the promise whose callback is being serviced. +# resolution - whether the current promise was resolved with "FULFILLED" +# or "REJECTED" +# value - the value of the currently fulfilled promise or error description +# in case rejected +# edict - error dictionary (if promise was rejected) +proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { + if {![info object isa object $all_promise]} { + # The object has been deleted. Naught to do + return + } + if {[$all_promise state] ne "PENDING"} { + # Already settled. This can happen when a tracked promise is + # rejected and another tracked promise gets settled afterwards. + return + } + if {$resolution eq "REJECTED"} { + # This promise failed. Immediately reject the master promise + # TBD - can we somehow indicate which promise failed ? + $all_promise reject $value $edict + return + } + + # Update the state of the resolved tracked promise + set all_state [$all_promise getdata ALLPROMISES] + dict set all_state RESULTS $done_promise $value + dict incr all_state PENDING_COUNT -1 + $all_promise setdata ALLPROMISES $all_state + + # If all promises resolved, resolve the all promise + if {[dict get $all_state PENDING_COUNT] == 0} { + set values {} + foreach prom [dict get $all_state PROMISES] { + lappend values [dict get $all_state RESULTS $prom] + } + $all_promise fulfill $values + } + return +} + +proc promise::race {promises} { + # Returns a promise that fulfills or rejects when any promise + # in the $promises argument is fulfilled or rejected. + # promises - a list of Promise objects + # The returned promise will fulfill and reject with the same value + # as the first promise in $promises that fulfills or rejects. + set race_promise [Promise new [lambda {promises prom} { + if {[llength $promises] == 0} { + catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict + $prom reject $reason $edict + return + } + # Use safe_*, do not directly call methods since $prom may be + # gc'ed once settled + foreach promise $promises { + $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] + } + } $promises]] + + return $race_promise +} + +proc promise::race* {args} { + # Returns a promise that fulfills or rejects when any promise + # in the passed arguments is fulfilled or rejected. + # args - list of Promise objects + # This command is identical to the `race` command except that it takes + # multiple arguments, each of which is a Promise object. See [race] + # for a description. + return [race $args] +} + +proc promise::await {prom} { + # Waits for a promise to be settled and returns its resolved value. + # prom - the promise that is to be waited on + # This command may only be used from within a procedure constructed + # with the [async] command or any code invoked from it. + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + set coro [info coroutine] + if {$coro eq ""} { + throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" + } + $prom done [list $coro success] [list $coro fail] + lassign [yieldto return -level 0] status val ropts + if {$status eq "success"} { + return $val + } else { + return -options $ropts $val + } +} + +proc promise::async {name paramdefs body} { + # Defines an procedure that will run a script asynchronously as a coroutine. + # name - name of the procedure + # paramdefs - the parameter definitions to the procedure in the same + # form as passed to the standard `proc` command + # body - the script to be executed + # + # When the defined procedure $name is called, it runs the supplied $body + # within a new coroutine. The return value from the $name procedure call + # will be a promise that will be fulfilled when the coroutine completes + # normally or rejected if it completes with an error. + # + # Note that the passed $body argument is not the body of the + # the procedure $name. Rather it is run as an anonymous procedure in + # the coroutine but in the same namespace context as $name. Thus the + # caller or the $body script must not make any assumptions about + # relative stack levels, use of `uplevel` etc. + # + # The primary purpose of this command is to make it easy, in + # conjunction with the [await] command, to wrap a sequence of asynchronous + # operations as a single computational unit. + # + # Returns a promise that will be settled with the result of the script. + if {![string equal -length 2 "$name" "::"]} { + set ns [uplevel 1 namespace current] + set name ${ns}::$name + } else { + set ns :: + } + set tmpl { + proc %NAME% {%PARAMDEFS%} { + set p [promise::Promise new [promise::lambda {real_args prom} { + coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { + upvar #1 _current_async_promise current_p + set current_p $p + set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] + if {$status == 0} { + $p fulfill $res + } else { + $p reject $res $ropts + } + } $prom {*}$real_args] + } [lrange [info level 0] 1 end]]] + return $p + } + } + eval [string map [list %NAME% $name \ + %PARAMDEFS% $paramdefs \ + %BODY% $body \ + %NS% $ns] $tmpl] +} + +proc promise::async_fulfill {val} { + # Fulfills a promise for an async procedure with the specified value. + # val - the value with which to fulfill the promise + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_fulfill called from outside an async context." + } + $current_p fulfill $val + return +} + +proc promise::async_reject {val {edict {}}} { + # Rejects a promise for an async procedure with the specified value. + # val - the value with which to reject the promise + # edict - error dictionary for rejection + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_reject called from outside an async context." + } + $current_p reject $val $edict + return +} + +proc promise::async_chain {prom} { + # Chains a promise for an async procedure to the specified promise. + # prom - the promise to which the async promise is to be linked. + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_chain called from outside an async context." + } + $current_p chain $prom + return +} + +proc promise::pfulfilled {value} { + # Returns a new promise that is already fulfilled with the specified value. + # value - the value with which to fulfill the created promise + return [Promise new [lambda {value prom} { + $prom fulfill $value + } $value]] +} + +proc promise::prejected {value {edict {}}} { + # Returns a new promise that is already rejected. + # value - the value with which to reject the promise + # edict - error dictionary for rejection + # By convention, $value should be of the format returned by + # [Promise.reject]. + return [Promise new [lambda {value edict prom} { + $prom reject $value $edict + } $value $edict]] +} + +proc promise::eventloop {prom} { + # Waits in the eventloop until the specified promise is settled. + # prom - the promise to be waited on + # The command enters the event loop in similar fashion to the + # Tcl `vwait` command except that instead of waiting on a variable + # the command waits for the specified promise to be settled. As such + # it has the same caveats as the vwait command in terms of care + # being taken in nested calls etc. + # + # The primary use of the command is at the top level of a script + # to wait for one or more promise based tasks to be completed. Again, + # similar to the vwait forever idiom. + # + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + + set varname [namespace current]::_pwait_[info cmdcount] + $prom done \ + [lambda {varname result} { + set $varname [list success $result] + } $varname] \ + [lambda {varname error ropts} { + set $varname [list fail $error $ropts] + } $varname] + vwait $varname + lassign [set $varname] status result ropts + if {$status eq "success"} { + return $result + } else { + return -options $ropts $result + } +} + +proc promise::pgeturl {url args} { + # Returns a promise that will be fulfilled when the URL is fetched. + # url - the URL to fetch + # args - arguments to pass to the `http::geturl` command + # This command invokes the asynchronous form of the `http::geturl` command + # of the `http` package. If the operation completes with a status of + # `ok`, the returned promise is fulfilled with the contents of the + # http state array (see the documentation of `http::geturl`). If the + # the status is anything else, the promise is rejected with + # the `reason` parameter to the reaction containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # with an additional key `http_state`, containing the + # contents of the http state array. + + uplevel #0 {package require http} + proc pgeturl {url args} { + set prom [Promise new [lambda {http_args prom} { + http::geturl {*}$http_args -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + if {$http_state(status) eq "ok"} { + $prom fulfill [array get http_state] + } else { + if {[info exists http_state(error)]} { + set msg [lindex $http_state(error) 0] + } + if {![info exists msg] || $msg eq ""} { + set msg "Error retrieving URL." + } + catch {throw {PROMISE PGETURL} $msg} msg edict + dict set edict http_state [array get http_state] + $prom reject $msg $edict + } + http::cleanup $tok + } $prom] + } [linsert $args 0 $url]]] + return $prom + } + tailcall pgeturl $url {*}$args +} + +proc promise::ptimer {millisecs {value "Timer expired."}} { + # Returns a promise that will be fulfilled when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be fulfilled + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to an error + # message and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimeout] which is similar but rejects the promise instead + # of fulfilling it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't allow "idle", "cancel" etc. as an argument to after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [list promise::safe_fulfill $prom $value] + } $millisecs $value]] +} + +proc promise::ptimeout {millisecs {value "Operation timed out."}} { + # Returns a promise that will be rejected when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be rejected + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to $value + # and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimer] which is similar but fulfills the promise instead + # of rejecting it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't want to accept "idle", "cancel" etc. for after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [::promise::lambda {prom msg} { + catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict + ::promise::safe_reject $prom $msg $edict + } $prom $value] + } $millisecs $value]] +} + +proc promise::pconnect {args} { + # Returns a promise that will be fulfilled when the socket connection + # is completed. + # args - arguments to be passed to the Tcl `socket` command + # This is a wrapper for the async version of the Tcl `socket` command. + # If the connection completes, the promise is fulfilled with the + # socket handle. + # In case of errors (e.g. if the address cannot be fulfilled), the + # promise is rejected with the `reason` parameter containing the + # error message and the `edict` parameter containing the Tcl error + # dictionary. + # + return [Promise new [lambda {so_args prom} { + set so [socket -async {*}$so_args] + fileevent $so writable [promise::lambda {prom so} { + fileevent $so writable {} + set err [chan configure $so -error] + if {$err eq ""} { + $prom fulfill $so + } else { + catch {throw {PROMISE PCONNECT FAIL} $err} err edict + $prom reject $err $edict + } + } $prom $so] + } $args]] +} + +proc promise::_read_channel {prom chan data} { + set newdata [read $chan] + if {[string length $newdata] || ![eof $chan]} { + append data $newdata + fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] + return + } + + # EOF + set code [catch { + # Need to make the channel blocking else no error is returned + # on the close + fileevent $chan readable {} + fconfigure $chan -blocking 1 + close $chan + } result edict] + if {$code} { + safe_reject $prom $result $edict + } else { + safe_fulfill $prom $data + } +} + +proc promise::pexec {args} { + # Runs an external program and returns a promise for its output. + # args - program and its arguments as passed to the Tcl `open` call + # for creating pipes + # If the program runs without errors, the promise is fulfilled by its + # standard output content. Otherwise + # promise is rejected. + # + # Returns a promise that will be settled by the result of the program + return [Promise new [lambda {open_args prom} { + set chan [open |$open_args r] + fconfigure $chan -blocking 0 + fileevent $chan readable [list promise::_read_channel $prom $chan ""] + } $args]] +} + +proc promise::safe_fulfill {prom value} { + # Fulfills the specified promise. + # prom - the [Promise] object to be fulfilled + # value - the fulfillment value + # This is a convenience command that checks if $prom still exists + # and if so fulfills it with $value. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [fulfill][Promise.fulfill] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return 0 + } + return [$prom fulfill $value] +} + +proc promise::safe_reject {prom value {edict {}}} { + # Rejects the specified promise. + # prom - the [Promise] object to be fulfilled + # value - see [Promise.reject] + # edict - see [Promise.reject] + # This is a convenience command that checks if $prom still exists + # and if so rejects it with the specified arguments. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [reject][Promise.reject] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return + } + $prom reject $value $edict +} + +proc promise::ptask {script} { + # Creates a new Tcl thread to run the specified script and returns + # a promise for the script results. + # script - script to run in the thread + # Returns a promise that will be settled by the result of the script + # + # The `ptask` command runs the specified script in a new Tcl + # thread. The promise returned from this command will be fulfilled + # with the result of the script if it completes + # successfully. Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + # + # The command requires the Thread package to be loaded. + + uplevel #0 package require Thread + proc [namespace current]::ptask script { + return [Promise new [lambda {script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + # ok or return + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + thread::create $thread_script + } $script]] + } + tailcall [namespace current]::ptask $script +} + +proc promise::pworker {tpool script} { + # Runs a script in a worker thread from a thread pool and + # returns a promise for the same. + # tpool - thread pool identifier + # script - script to run in the worker thread + # Returns a promise that will be settled by the result of the script + # + # The Thread package allows creation of a thread pool with the + # `tpool create` command. The `pworker` command runs the specified + # script in a worker thread from a thread pool. The promise + # returned from this command will be fulfilled with the result of + # the script if it completes successfully. + # Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + + # No need for package require Thread since if tpool is passed to + # us, Thread must already be loaded + return [Promise new [lambda {tpool script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + tpool::post -detached -nowait $tpool $thread_script + } $tpool $script]] +} + +if {0} { + package require http + proc checkurl {url} { + set prom [promise::Promise new [promise::lambda {url prom} { + http::geturl $url -method HEAD -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + $prom fulfill [list $http_state(url) $http_state(status)] + ::http::cleanup $tok + } $prom] + } $url]] + return $prom + } + + proc checkurls {urls} { + return [promise::all [lmap url $urls {checkurl $url}]] + } + + [promise::all [ + list [ + promise::ptask {expr 1+1} + ] [ + promise::ptask {expr 2+2} + ] + ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] +} + +package provide promise [promise::version] + +if {[info exists ::argv0] && + [file tail [info script]] eq [file tail $::argv0]} { + set filename [file tail [info script]] + if {[llength $::argv] == 0} { + puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" + exit 1 + } + switch -glob -- [lindex $::argv 0] { + ver* { puts [promise::version] } + tm - + dist* { + if {[file extension $filename] ne ".tm"} { + set dir [file join [file dirname [info script]] .. build] + file mkdir $dir + file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] + } else { + error "Cannot create distribution from a .tm file" + } + } + install { + # Install in first native file system that exists on search path + foreach path [tcl::tm::path list] { + if {[lindex [file system $path] 0] eq "native"} { + set dir $path + if {[file isdirectory $path]} { + break + } + # Else keep looking + } + } + if {![file exists $dir]} { + file mkdir $dir + } + if {[file extension $filename] eq ".tm"} { + # We already are a .tm with version number + set target $filename + } else { + set target [file rootname $filename]-[promise::version].tm + } + file copy -force [info script] [file join $dir $target] + } + default { + puts stderr "Unknown option/command \"[lindex $::argv 0]\"" + exit 1 + } + } +} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index e940dada..74a3ffc8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -4001,7 +4001,17 @@ tcl::namespace::eval punk::args { set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { - set chosen $v_test + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set set choice_in_list 1 } else { #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. @@ -4046,6 +4056,7 @@ tcl::namespace::eval punk::args { } } + #override the optimistic existing val if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 2e10e75b..a8884746 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -740,18 +740,27 @@ namespace eval punk::console { set was_raw 1 set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + puts -nonewline $output $query;flush $output chan configure $input -blocking 0 set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on set tsclock($callid) $tslaunch($callid) - #write before console enableRaw vs after?? - #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it - puts -nonewline $output $query;flush $output + #after 0 + #------------------ + #trying alternatives to get faster read and maintain reliability..REVIEW + #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features + #------------------ + # 1) faster - races? + $this_handler $input $callid $capturingendregex $this_handler $input $callid $capturingendregex - if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } + # 2) more reliable? + #chan event $input readable [list $this_handler $input $callid $capturingendregex] + #------------------ #response from terminal @@ -794,7 +803,7 @@ namespace eval punk::console { if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { - puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" + puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" } if {$was_raw == 0} { @@ -956,9 +965,10 @@ namespace eval punk::console { set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] #review - what is min length of any ansiresponse? + #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z #endregex is capturing - but as we are only testing the match here #it should perform the same as if it were non-capturing - if {[string length $sofar] > 3 && [regexp $endregex $sofar]} { + if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" chan event $chan readable {} set waits($callid) ok @@ -1438,7 +1448,8 @@ namespace eval punk::console { -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 newsize -default "" -help\ - "character cell pixel dimensions WxH" + "character cell pixel dimensions WxH + or omit to query cell size." } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] @@ -1474,6 +1485,31 @@ namespace eval punk::console { } set cell_size ${w}x${h} } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #puts -->$payload<-- + return [expr {$payload in {Z K M}}] + } #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { @@ -1587,7 +1623,6 @@ namespace eval punk::console { } - proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?7\$p" @@ -1683,7 +1718,14 @@ namespace eval punk::console { return } - puts -nonewline stdout $char_or_string + #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error + #e.g contains surrogate pair + if {[catch { + puts -nonewline stdout $char_or_string + } errM]} { + puts stderr "test_char_width couldn't emit this string - \nerror: $errM" + } + set response [punk::console::get_cursor_pos] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index a89e3fe9..1af6958f 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -35,8 +35,9 @@ tclkit-win64-dyn.exe {punk86bawt.vfs punksys kit} #TCL9 #tclsh90b2 {punk9win.vfs punk90b2 zip} #tclsh90b4_piperepl.exe {punk9win.vfs punk90b4 zip} -#tclsh901.exe {punk9win.vfs punk901 zip} -tclsh901t.exe {punk9win.vfs punk901t zipcat} +#tclsh901.exe {punk9win.vfs punk901 zip} +tclsh901t.exe {punk9win.vfs punk901t zipcat} +tclsh90magic.exe {punk9magicsplat.vfs punkmagic zipcat} #tclsh901k.exe {mkzipfix.vfs punktest zip} diff --git a/src/vendormodules/commandstack-0.3.tm b/src/vendormodules/commandstack-0.3.tm index ee486569..a45eaeaf 100644 --- a/src/vendormodules/commandstack-0.3.tm +++ b/src/vendormodules/commandstack-0.3.tm @@ -211,7 +211,7 @@ namespace eval commandstack { set new_code [string trim $procbody] if {$current_code eq $new_code} { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [show_stack $command] + puts stderr [::commandstack::show_stack $command] } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." puts stdout "----------" @@ -236,8 +236,7 @@ namespace eval commandstack { set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } elseif {$next_implementor in {unspecified undetermined}} { - #review - probably don't need a warning anyway - puts stderr "(commandstack::rename_command) WARNING - Something may have renamed the '$command' command. Attempting to cooperate.(untested)" + #could be a standard tcl proc, or from application or package set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } else { @@ -380,7 +379,8 @@ namespace eval commandstack { #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] } - if {[package provide punk::lib] ne ""} { + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] } else { set result "" diff --git a/src/vendormodules/include_modules.config b/src/vendormodules/include_modules.config index ed83ed5c..b7320eb0 100644 --- a/src/vendormodules/include_modules.config +++ b/src/vendormodules/include_modules.config @@ -1,3 +1,5 @@ +#todo - change to include_modules.toml +#aim is to be programatically editable whilst retaining comments set local_modules [list\ c:/repo/nonexistant/tclmodules/blah/modules blah\ diff --git a/src/vendormodules/oolib-0.1.tm b/src/vendormodules/oolib-0.1.tm deleted file mode 100644 index 3756fceb..00000000 --- a/src/vendormodules/oolib-0.1.tm +++ /dev/null @@ -1,195 +0,0 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key > 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - method alias {newAlias existingKeyOrAlias} { - if {[string is integer -strict $newAlias]} { - error "[self object] collection key alias cannot be integer" - } - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } - } - method aliases {{key ""}} { - if {[string length $key]} { - set result [list] - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - return $result - } else { - return [array get o_alias] - } - } - #if the supplied index is an alias, return the underlying key; else return the index supplied. - method realKey {idx} { - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } - } - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse {} { - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - diff --git a/src/vendormodules/overtype-1.6.5.tm b/src/vendormodules/overtype-1.6.5.tm index fb044b3c..9363fb6d 100644 --- a/src/vendormodules/overtype-1.6.5.tm +++ b/src/vendormodules/overtype-1.6.5.tm @@ -216,7 +216,9 @@ tcl::namespace::eval overtype { } set optargs [lrange $args 0 end-2] if {[llength $optargs] % 2 == 0} { - lassign [lrange $args end-1 end] underblock overblock + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock set argsflags [lrange $args 0 end-2] } else { set optargs [lrange $args 0 end-1] @@ -1810,8 +1812,10 @@ tcl::namespace::eval overtype { if {[llength $args] < 2} { error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} } - lassign [lrange $args end-1 end] under over - if {[string first \n $under] >= 0} { + set under [lindex $args end-1] + set over [lindex $args end] + #lassign [lrange $args end-1 end] under over + if {[string last \n $under] >= 0} { error "overtype::renderline not allowed to contain newlines in undertext" } #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { @@ -2920,6 +2924,7 @@ tcl::namespace::eval overtype { set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ \x1b\[ 7CSI\ + \x1bY 7MAP\ \x1bP 7DCS\ \x90 8DCS\ \x9b 8CSI\ @@ -2948,6 +2953,10 @@ tcl::namespace::eval overtype { #8-bit Device Control String set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } 7ESC { #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] set codenorm $leadernorm[tcl::string::range $code 1 end] @@ -2964,6 +2973,30 @@ tcl::namespace::eval overtype { } } + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. switch -- $leadernorm { 1006 { @@ -2982,7 +3015,8 @@ tcl::namespace::eval overtype { {7CSI} - {8CSI} { set param [tcl::string::range $codenorm 4 end-1] #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + switch -exact -- $code_end { A { #Row move - up @@ -3875,6 +3909,7 @@ tcl::namespace::eval overtype { 7ESC { # #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. #also PM \x1b^...(ST) switch -- [tcl::string::index $codenorm 4] { c { @@ -4586,6 +4621,8 @@ tcl::namespace::eval overtype::priv { set o [lreplace $o $i $i] set ustacks [lreplace $ustacks $i $i] set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do } else { puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" } diff --git a/src/vendormodules/promise-1.2.0.tm b/src/vendormodules/promise-1.2.0.tm new file mode 100644 index 00000000..a4b82e45 --- /dev/null +++ b/src/vendormodules/promise-1.2.0.tm @@ -0,0 +1,1311 @@ +# Copyright (c) 2015-2023, Ashok P. Nadkarni +# All rights reserved. + +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: + +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. + +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. + +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +package require Tcl 8.6- + +namespace eval promise { + proc version {} { return 1.2.0 } +} + +proc promise::lambda {params body args} { + # Creates an anonymous procedure and returns a command prefix for it. + # params - parameter definitions for the procedure + # body - body of the procedures + # args - additional arguments to be passed to the procedure when it + # is invoked + # + # This is just a convenience command since anonymous procedures are + # commonly useful with promises. The lambda package from tcllib + # is identical in function. + + return [list ::apply [list $params $body] {*}$args] +} + +catch {promise::Promise destroy} +oo::class create promise::Promise { + + # The promise state can be one of + # PENDING - Initial state where it has not yet been assigned a + # value or error + # FULFILLED - The promise has been assigned a value + # REJECTED - The promise has been assigned an error + # CHAINED - The promise is attached to another promise + variable _state + + # Stores data that is accessed through the setdata/getdata methods. + # The Promise class itself does not use this. + variable _clientdata + + # The promise value once it is fulfilled or rejected. In the latter + # case, it should be an the error message + variable _value + + # The error dictionary in case promise is rejected + variable _edict + + # Reactions to be notified when the promise is rejected. Each element + # in this list is a pair consisting of the fulfilment reaction + # and the rejection reaction. Either element of the pair could be + # empty signifying no reaction for that case. The list is populated + # via the then method. + variable _reactions + + # Reference counting to free up promises since Tcl does not have + # garbage collection for objects. Garbage collection via reference + # counting only takes place after at least one done/then reaction + # is placed on the event queue, not before. Else promises that + # are immediately resolved on construction would be freed right + # away before the application even gets a chance to call done/then. + variable _do_gc + variable _nrefs + + # If no reject reactions are registered, then the Tcl bgerror + # handler is invoked. But don't want to do this more than once + # so track it + variable _bgerror_done + + constructor {cmd} { + # Create a promise for the asynchronous operation to be initiated + # by $cmd. + # cmd - a command prefix that should initiate an asynchronous + # operation. + # The command prefix $cmd is passed an additional argument - the + # name of this Promise object. It should arrange for one of the + # object's settle methods [fulfill], [chain] or + # [reject] to be called when the operation completes. + + set _state PENDING + set _reactions [list ] + set _do_gc 0 + set _bgerror_done 0 + set _nrefs 0 + array set _clientdata {} + + # Errors in the construction command are returned via + # the standard mechanism of reject. + # + if {[catch { + # For some special cases, $cmd may be "" if the async operation + # is initiated outside the constructor. This is not a good + # thing because the error in the initiator will not be + # trapped via the standard promise error catching mechanism + # but that's the application's problem (actually pgeturl also + # uses this). + if {[llength $cmd]} { + uplevel #0 [linsert $cmd end [self]] + } + } msg edict]} { + my reject $msg $edict + } + } + + destructor { + # Destroys the object. + # + # This method should not be generally called directly as [Promise] + # objects are garbage collected either automatically or via the [ref] + # and [unref] methods. + } + + method state {} { + # Returns the current state of the promise. + # + # The promise state may be one of the values `PENDING`, + # `FULFILLED`, `REJECTED` or `CHAINED` + return $_state + } + + method getdata {key} { + # Returns data previously stored through the setdata method. + # key - key whose associated values is to be returned. + # An error will be raised if no value is associated with the key. + return $_clientdata($key) + } + + method setdata {key value} { + # Sets a value to be associated with a key. + # key - the lookup key + # value - the value to be associated with the key + # A promise internally maintains a dictionary whose values can + # be accessed with the [getdata] and [setdata] methods. This + # dictionary is not used by the Promise class itself but is meant + # to be used by promise library specializations or applications. + # Callers need to take care that keys used for a particular + # promise are sufficiently distinguishable so as to not clash. + # + # Returns the value stored with the key. + set _clientdata($key) $value + } + + method value {} { + # Returns the settled value for the promise. + # + # The returned value may be the fulfilled value or the rejected + # value depending on whether the associated operation was successfully + # completed or failed. + # + # An error is raised if the promise is not settled yet. + if {$_state ni {FULFILLED REJECTED}} { + error "Value is not set." + } + return $_value + } + + method ref {} { + # Increments the reference count for the object. + incr _nrefs + } + + method unref {} { + # Decrements the reference count for the object. + # + # The object may have been destroyed when the call returns. + incr _nrefs -1 + my GC + } + + method nrefs {} { + # Returns the current reference count. + # + # Use for debugging only! Note, internal references are not included. + return $_nrefs + } + + method GC {} { + if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { + my destroy + } + } + + method FulfillAttached {value} { + if {$_state ne "CHAINED"} { + return + } + set _value $value + set _state FULFILLED + my ScheduleReactions + return + } + + method RejectAttached {reason edict} { + if {$_state ne "CHAINED"} { + return + } + set _value $reason + set _edict $edict + set _state REJECTED + my ScheduleReactions + return + } + + # Method to invoke to fulfil a promise with a value or another promise. + method fulfill {value} { + # Fulfills the promise. + # value - the value with which the promise is fulfilled + # + # Returns `0` if promise had already been settled and `1` if + # it was fulfilled by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `FULFILLED` state with + # the value specified by $value. If there are any fulfillment + # reactions registered by the [Promise.done] or [Promise.then] methods, they + # are scheduled to be run. + set _value $value + set _state FULFILLED + my ScheduleReactions + return 1 + } + + # Method to invoke to fulfil a promise with a value or another promise. + method chain {promise} { + # Chains the promise to another promise. + # promise - the [Promise] object to which this promise is to + # be chained + # + # Returns `0` if promise had already been settled and `1` otherwise. + + #ruff + # If the promise on which this method is called + # has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; + } + + #ruff + # Otherwise, it is chained to $promise so that it reflects that + # other promise's state. + if {[catch { + $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] + } msg edict]} { + my reject $msg $edict + } else { + set _state CHAINED + } + + return 1 + } + + method reject {reason {edict {}}} { + # Rejects the promise. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # + # The $reason and $edict values are passed on to the rejection + # reactions. By convention, these should be of the form returned + # by the `catch` or `try` commands in case of errors. + # + # Returns `0` if promise had already been settled and `1` if + # it was rejected by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `REJECTED` state. If + # there are any reject reactions registered by the [Promise.done] or + # [Promise.then] methods, they are scheduled to be run. + + set _value $reason + #ruff + # If $edict is not specified, or specified as an empty string, + # a suitable error dictionary is constructed in its place + # to be passed to the reaction. + if {$edict eq ""} { + catch {throw {PROMISE REJECTED} $reason} - edict + } + set _edict $edict + set _state REJECTED + my ScheduleReactions + return 1 + } + + # Internal method to queue all registered reactions based on + # whether the promise is succesfully fulfilled or not + method ScheduleReactions {} { + if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { + # Promise is not settled or no reactions registered + return + } + + # Note on garbage collection: garbage collection is to be enabled if + # at least one FULFILLED or REJECTED reaction is registered. + # Also if the promise is REJECTED but no rejection handlers are run + # we also schedule a background error. + # In all cases, CLEANUP reactions do not count. + foreach reaction $_reactions { + foreach type {FULFILLED REJECTED} { + if {[dict exists $reaction $type]} { + set _do_gc 1 + if {$type eq $_state} { + set cmd [dict get $reaction $type] + if {[llength $cmd]} { + if {$type eq "FULFILLED"} { + lappend cmd $_value + } else { + lappend cmd $_value $_edict + } + set ran_reaction($type) 1 + # Enqueue the reaction via the event loop + after 0 [list after idle $cmd] + } + } + } + } + if {[dict exists $reaction CLEANUP]} { + set cmd [dict get $reaction CLEANUP] + if {[llength $cmd]} { + # Enqueue the cleaner via the event loop passing the + # *state* as well as the value + if {$_state eq "REJECTED"} { + lappend cmd $_state $_value $_edict + } else { + lappend cmd $_state $_value + } + after 0 [list after idle $cmd] + # Note we do not set _do_gc if we only run cleaners + } + } + } + set _reactions [list ] + + # Check for need to background error (see comments above) + if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { + # TBD - should we also check _nrefs before backgrounding error? + + # Wrap in catch in case $_edict does not follow error conventions + # or is not even a dictionary + if {[catch { + dict get $_edict -level + dict get $_edict -code + }]} { + catch {throw {PROMISE REJECT} $_value} - edict + } else { + set edict $_edict + } + # TBD - how exactly is level to be handled? + # If -level is not 0, bgerror barfs because it treates + # it as TCL_RETURN no matter was -code is + dict set edict -level 0 + after idle [interp bgerror {}] [list $_value $edict] + set _bgerror_done 1 + } + + my GC + return + } + + method RegisterReactions {args} { + # Registers the specified reactions. + # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` + # with values being the corresponding reaction callback + + lappend _reactions $args + my ScheduleReactions + return + } + + method done {{on_fulfill {}} {on_reject {}}} { + # Registers reactions to be run when the promise is settled. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. + # Reactions are called with an additional argument which is + # the value with which the promise was settled. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # The method triggers garbage collection of the object if the + # promise has been settled and any registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Note that both $on_fulfill and $on_reject may be specified + # as empty strings if no further action needs to be taken on + # settlement of the promise. If the promise is rejected, and + # no rejection reactions are registered, the error is reported + # via the Tcl `interp bgerror` facility. + + # TBD - as per the Promise/A+ spec, errors in done should generate + # a background error (unlike then). + + my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject + + #ruff + # The method does not return a value. + return + } + + method then {on_fulfill {on_reject {}}} { + # Registers reactions to be run when the promise is settled + # and returns a new [Promise] object that will be settled by the + # reactions. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. If an empty string, no fulfill + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. If unspecified or an empty string, + # no reject reaction is registered. + # Both reactions are passed the value with which the promise was settled. + # The reject reaction is passed an additional argument which is + # the error dictionary. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # If the reaction that is invoked runs without error, its return + # value fulfills the new promise returned by the `then` method. + # If it raises an exception, the new promise will be rejected + # with the error message and dictionary from the exception. + # + # Alternatively, the reactions can explicitly invoke commands + # [then_fulfill], [then_reject] or [then_chain] to + # resolve the returned promise. In this case, the return value + # (including exceptions) from the reactions are ignored. + # + # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), + # the new promise is created and fulfilled (or rejected) with + # the same value that would have been passed in to the reactions. + # + # The method triggers garbage collection of the object if the + # promise has been settled and registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Returns a new promise that is settled by the registered reactions. + + set then_promise [[self class] new ""] + my RegisterReactions \ + FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ + REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] + return $then_promise + } + + # This could be a forward, but then we cannot document it via ruff! + method catch {on_reject} { + # Registers reactions to be run when the promise is rejected. + # on_reject - command prefix for the reaction + # reaction to run if the promise is rejected. If unspecified + # or an empty string, no reject reaction is registered. The + # reaction is called with an additional argument which is the + # value with which the promise was settled. + # This method is just a wrapper around [Promise.then] with the + # `on_fulfill` parameter defaulting to an empty string. See + # the description of that method for details. + return [my then "" $on_reject] + } + + method cleanup {cleaner} { + # Registers a reaction to be executed for running cleanup + # code when the promise is settled. + # cleaner - command prefix to run on settlement + # This method is intended to run a clean up script + # when a promise is settled. Its primary use is to avoid duplication + # of code in the `then` and `catch` handlers for a promise. + # It may also be called multiple times + # to clean up intermediate steps when promises are chained. + # + # The method returns a new promise that will be settled + # as per the following rules. + # - if the cleaner runs without errors, the returned promise + # will reflect the settlement of the promise on which this + # method is called. + # - if the cleaner raises an exception, the returned promise + # is rejected with a value consisting of the error message + # and dictionary pair. + # + # Returns a new promise that is settled based on the cleaner + set cleaner_promise [[self class] new ""] + my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] + return $cleaner_promise + } +} + +proc promise::_then_reaction {target_promise status cmd value {edict {}}} { + # Run the specified command and fulfill/reject the target promise + # accordingly. If the command is empty, the passed-in value is passed + # on to the target promise. + + # IMPORTANT!!!! + # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else + # promise::then_fulfill/then_reject/then_chain will not work + # Also, Do NOT change the param name target_promise without changing + # those procs. + # Oh what a hack to get around lack of closures. Alternative would have + # been to pass an additional parameter (target_promise) + # to the application code but then that script would have had to + # carry that around. + + if {[info level] != 1} { + error "Internal error: _then_reaction not at level 1" + } + + if {[llength $cmd] == 0} { + switch -exact -- $status { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict} + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid status $state" + } + } + } else { + # Invoke the real reaction code and fulfill/reject the target promise. + # Note the reaction code may have called one of the promise::then_* + # commands itself and reactions run resulting in the object being + # freed. Hence resolve using the safe* variants + # TBD - ideally we would like to execute at global level. However + # the then_* commands retrieve target_promise from level 1 (here) + # which they cannot if uplevel #0 is done. So directly invoke. + if {$status eq "REJECTED"} { + lappend cmd $value $edict + } else { + lappend cmd $value + } + if {[catch $cmd reaction_value reaction_edict]} { + safe_reject $target_promise $reaction_value $reaction_edict + } else { + safe_fulfill $target_promise $reaction_value + } + } + return +} + +proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { + # Run the specified cleaner and fulfill/reject the target promise + # accordingly. If the cleaner executes without error, the original + # value and state is passed on. If the cleaner executes with error + # the promise is rejected. + + if {[llength $cleaner] == 0} { + switch -exact -- $state { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict } + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid state $state" + } + } + } else { + if {[catch {uplevel #0 $cleaner} err edict]} { + # Cleaner failed. Reject the target promise + $target_promise reject $err $edict + } else { + # Cleaner completed without errors, pass on the original value + if {$state eq "FULFILLED"} { + $target_promise fulfill $value + } else { + $target_promise reject $value $edict + } + } + } + return +} + +proc promise::then_fulfill {value} { + # Fulfills the promise returned by a [Promise.then] method call from + # within its reaction. + # value - the value with which to fulfill the promise + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - `then_fulfill`, + # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + + # TBD - what if someone calls this from within a uplevel #0 ? The + # upvar will be all wrong + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_fulfill called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise fulfill $value +} + +proc promise::then_chain {promise} { + # Chains the promise returned by a [Promise.then] method call to + # another promise. + # promise - the promise to which the promise returned by [Promise.then] is + # to be chained + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_chain` chains + # the promise returned by the `then` method that queued the currently + # running reaction to $promise so that the former will be settled + # based on the latter. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_chain called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise chain $promise +} + +proc promise::then_reject {reason edict} { + # Rejects the promise returned by a [Promise.then] method call from + # within its reaction. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_reject` rejects + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_reject called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise reject $reason $edict +} + +proc promise::all {promises} { + # Returns a promise that fulfills or rejects when all promises + # in the $promises argument have fulfilled or any one has rejected. + # promises - a list of Promise objects + # If any of $promises rejects, then the promise returned by the + # command will reject with the same value. Otherwise, the promise + # will fulfill when all promises have fulfilled. + # The resolved value will be a list of the resolved + # values of the contained promises. + + set all_promise [Promise new [lambda {promises prom} { + set npromises [llength $promises] + if {$npromises == 0} { + $prom fulfill {} + return + } + + # Ask each promise to update us when resolved. + foreach promise $promises { + $promise done \ + [list ::promise::_all_helper $prom $promise FULFILLED] \ + [list ::promise::_all_helper $prom $promise REJECTED] + } + + # We keep track of state with a dictionary that will be + # stored in $prom with the following keys: + # PROMISES - the list of promises in the order passed + # PENDING_COUNT - count of unresolved promises + # RESULTS - dictionary keyed by promise and containing resolved value + set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] + + $prom setdata ALLPROMISES $all_state + } $promises]] + + return $all_promise +} + +proc promise::all* args { + # Returns a promise that fulfills or rejects when all promises + # in the $args argument have fulfilled or any one has rejected. + # args - list of Promise objects + # This command is identical to the all command except that it takes + # multiple arguments, each of which is a Promise object. See [all] + # for a description. + return [all $args] +} + +# Callback for promise::all. +# all_promise - the "master" promise returned by the all call. +# done_promise - the promise whose callback is being serviced. +# resolution - whether the current promise was resolved with "FULFILLED" +# or "REJECTED" +# value - the value of the currently fulfilled promise or error description +# in case rejected +# edict - error dictionary (if promise was rejected) +proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { + if {![info object isa object $all_promise]} { + # The object has been deleted. Naught to do + return + } + if {[$all_promise state] ne "PENDING"} { + # Already settled. This can happen when a tracked promise is + # rejected and another tracked promise gets settled afterwards. + return + } + if {$resolution eq "REJECTED"} { + # This promise failed. Immediately reject the master promise + # TBD - can we somehow indicate which promise failed ? + $all_promise reject $value $edict + return + } + + # Update the state of the resolved tracked promise + set all_state [$all_promise getdata ALLPROMISES] + dict set all_state RESULTS $done_promise $value + dict incr all_state PENDING_COUNT -1 + $all_promise setdata ALLPROMISES $all_state + + # If all promises resolved, resolve the all promise + if {[dict get $all_state PENDING_COUNT] == 0} { + set values {} + foreach prom [dict get $all_state PROMISES] { + lappend values [dict get $all_state RESULTS $prom] + } + $all_promise fulfill $values + } + return +} + +proc promise::race {promises} { + # Returns a promise that fulfills or rejects when any promise + # in the $promises argument is fulfilled or rejected. + # promises - a list of Promise objects + # The returned promise will fulfill and reject with the same value + # as the first promise in $promises that fulfills or rejects. + set race_promise [Promise new [lambda {promises prom} { + if {[llength $promises] == 0} { + catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict + $prom reject $reason $edict + return + } + # Use safe_*, do not directly call methods since $prom may be + # gc'ed once settled + foreach promise $promises { + $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] + } + } $promises]] + + return $race_promise +} + +proc promise::race* {args} { + # Returns a promise that fulfills or rejects when any promise + # in the passed arguments is fulfilled or rejected. + # args - list of Promise objects + # This command is identical to the `race` command except that it takes + # multiple arguments, each of which is a Promise object. See [race] + # for a description. + return [race $args] +} + +proc promise::await {prom} { + # Waits for a promise to be settled and returns its resolved value. + # prom - the promise that is to be waited on + # This command may only be used from within a procedure constructed + # with the [async] command or any code invoked from it. + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + set coro [info coroutine] + if {$coro eq ""} { + throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" + } + $prom done [list $coro success] [list $coro fail] + lassign [yieldto return -level 0] status val ropts + if {$status eq "success"} { + return $val + } else { + return -options $ropts $val + } +} + +proc promise::async {name paramdefs body} { + # Defines an procedure that will run a script asynchronously as a coroutine. + # name - name of the procedure + # paramdefs - the parameter definitions to the procedure in the same + # form as passed to the standard `proc` command + # body - the script to be executed + # + # When the defined procedure $name is called, it runs the supplied $body + # within a new coroutine. The return value from the $name procedure call + # will be a promise that will be fulfilled when the coroutine completes + # normally or rejected if it completes with an error. + # + # Note that the passed $body argument is not the body of the + # the procedure $name. Rather it is run as an anonymous procedure in + # the coroutine but in the same namespace context as $name. Thus the + # caller or the $body script must not make any assumptions about + # relative stack levels, use of `uplevel` etc. + # + # The primary purpose of this command is to make it easy, in + # conjunction with the [await] command, to wrap a sequence of asynchronous + # operations as a single computational unit. + # + # Returns a promise that will be settled with the result of the script. + if {![string equal -length 2 "$name" "::"]} { + set ns [uplevel 1 namespace current] + set name ${ns}::$name + } else { + set ns :: + } + set tmpl { + proc %NAME% {%PARAMDEFS%} { + set p [promise::Promise new [promise::lambda {real_args prom} { + coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { + upvar #1 _current_async_promise current_p + set current_p $p + set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] + if {$status == 0} { + $p fulfill $res + } else { + $p reject $res $ropts + } + } $prom {*}$real_args] + } [lrange [info level 0] 1 end]]] + return $p + } + } + eval [string map [list %NAME% $name \ + %PARAMDEFS% $paramdefs \ + %BODY% $body \ + %NS% $ns] $tmpl] +} + +proc promise::async_fulfill {val} { + # Fulfills a promise for an async procedure with the specified value. + # val - the value with which to fulfill the promise + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_fulfill called from outside an async context." + } + $current_p fulfill $val + return +} + +proc promise::async_reject {val {edict {}}} { + # Rejects a promise for an async procedure with the specified value. + # val - the value with which to reject the promise + # edict - error dictionary for rejection + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_reject called from outside an async context." + } + $current_p reject $val $edict + return +} + +proc promise::async_chain {prom} { + # Chains a promise for an async procedure to the specified promise. + # prom - the promise to which the async promise is to be linked. + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_chain called from outside an async context." + } + $current_p chain $prom + return +} + +proc promise::pfulfilled {value} { + # Returns a new promise that is already fulfilled with the specified value. + # value - the value with which to fulfill the created promise + return [Promise new [lambda {value prom} { + $prom fulfill $value + } $value]] +} + +proc promise::prejected {value {edict {}}} { + # Returns a new promise that is already rejected. + # value - the value with which to reject the promise + # edict - error dictionary for rejection + # By convention, $value should be of the format returned by + # [Promise.reject]. + return [Promise new [lambda {value edict prom} { + $prom reject $value $edict + } $value $edict]] +} + +proc promise::eventloop {prom} { + # Waits in the eventloop until the specified promise is settled. + # prom - the promise to be waited on + # The command enters the event loop in similar fashion to the + # Tcl `vwait` command except that instead of waiting on a variable + # the command waits for the specified promise to be settled. As such + # it has the same caveats as the vwait command in terms of care + # being taken in nested calls etc. + # + # The primary use of the command is at the top level of a script + # to wait for one or more promise based tasks to be completed. Again, + # similar to the vwait forever idiom. + # + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + + set varname [namespace current]::_pwait_[info cmdcount] + $prom done \ + [lambda {varname result} { + set $varname [list success $result] + } $varname] \ + [lambda {varname error ropts} { + set $varname [list fail $error $ropts] + } $varname] + vwait $varname + lassign [set $varname] status result ropts + if {$status eq "success"} { + return $result + } else { + return -options $ropts $result + } +} + +proc promise::pgeturl {url args} { + # Returns a promise that will be fulfilled when the URL is fetched. + # url - the URL to fetch + # args - arguments to pass to the `http::geturl` command + # This command invokes the asynchronous form of the `http::geturl` command + # of the `http` package. If the operation completes with a status of + # `ok`, the returned promise is fulfilled with the contents of the + # http state array (see the documentation of `http::geturl`). If the + # the status is anything else, the promise is rejected with + # the `reason` parameter to the reaction containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # with an additional key `http_state`, containing the + # contents of the http state array. + + uplevel #0 {package require http} + proc pgeturl {url args} { + set prom [Promise new [lambda {http_args prom} { + http::geturl {*}$http_args -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + if {$http_state(status) eq "ok"} { + $prom fulfill [array get http_state] + } else { + if {[info exists http_state(error)]} { + set msg [lindex $http_state(error) 0] + } + if {![info exists msg] || $msg eq ""} { + set msg "Error retrieving URL." + } + catch {throw {PROMISE PGETURL} $msg} msg edict + dict set edict http_state [array get http_state] + $prom reject $msg $edict + } + http::cleanup $tok + } $prom] + } [linsert $args 0 $url]]] + return $prom + } + tailcall pgeturl $url {*}$args +} + +proc promise::ptimer {millisecs {value "Timer expired."}} { + # Returns a promise that will be fulfilled when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be fulfilled + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to an error + # message and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimeout] which is similar but rejects the promise instead + # of fulfilling it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't allow "idle", "cancel" etc. as an argument to after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [list promise::safe_fulfill $prom $value] + } $millisecs $value]] +} + +proc promise::ptimeout {millisecs {value "Operation timed out."}} { + # Returns a promise that will be rejected when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be rejected + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to $value + # and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimer] which is similar but fulfills the promise instead + # of rejecting it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't want to accept "idle", "cancel" etc. for after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [::promise::lambda {prom msg} { + catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict + ::promise::safe_reject $prom $msg $edict + } $prom $value] + } $millisecs $value]] +} + +proc promise::pconnect {args} { + # Returns a promise that will be fulfilled when the socket connection + # is completed. + # args - arguments to be passed to the Tcl `socket` command + # This is a wrapper for the async version of the Tcl `socket` command. + # If the connection completes, the promise is fulfilled with the + # socket handle. + # In case of errors (e.g. if the address cannot be fulfilled), the + # promise is rejected with the `reason` parameter containing the + # error message and the `edict` parameter containing the Tcl error + # dictionary. + # + return [Promise new [lambda {so_args prom} { + set so [socket -async {*}$so_args] + fileevent $so writable [promise::lambda {prom so} { + fileevent $so writable {} + set err [chan configure $so -error] + if {$err eq ""} { + $prom fulfill $so + } else { + catch {throw {PROMISE PCONNECT FAIL} $err} err edict + $prom reject $err $edict + } + } $prom $so] + } $args]] +} + +proc promise::_read_channel {prom chan data} { + set newdata [read $chan] + if {[string length $newdata] || ![eof $chan]} { + append data $newdata + fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] + return + } + + # EOF + set code [catch { + # Need to make the channel blocking else no error is returned + # on the close + fileevent $chan readable {} + fconfigure $chan -blocking 1 + close $chan + } result edict] + if {$code} { + safe_reject $prom $result $edict + } else { + safe_fulfill $prom $data + } +} + +proc promise::pexec {args} { + # Runs an external program and returns a promise for its output. + # args - program and its arguments as passed to the Tcl `open` call + # for creating pipes + # If the program runs without errors, the promise is fulfilled by its + # standard output content. Otherwise + # promise is rejected. + # + # Returns a promise that will be settled by the result of the program + return [Promise new [lambda {open_args prom} { + set chan [open |$open_args r] + fconfigure $chan -blocking 0 + fileevent $chan readable [list promise::_read_channel $prom $chan ""] + } $args]] +} + +proc promise::safe_fulfill {prom value} { + # Fulfills the specified promise. + # prom - the [Promise] object to be fulfilled + # value - the fulfillment value + # This is a convenience command that checks if $prom still exists + # and if so fulfills it with $value. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [fulfill][Promise.fulfill] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return 0 + } + return [$prom fulfill $value] +} + +proc promise::safe_reject {prom value {edict {}}} { + # Rejects the specified promise. + # prom - the [Promise] object to be fulfilled + # value - see [Promise.reject] + # edict - see [Promise.reject] + # This is a convenience command that checks if $prom still exists + # and if so rejects it with the specified arguments. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [reject][Promise.reject] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return + } + $prom reject $value $edict +} + +proc promise::ptask {script} { + # Creates a new Tcl thread to run the specified script and returns + # a promise for the script results. + # script - script to run in the thread + # Returns a promise that will be settled by the result of the script + # + # The `ptask` command runs the specified script in a new Tcl + # thread. The promise returned from this command will be fulfilled + # with the result of the script if it completes + # successfully. Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + # + # The command requires the Thread package to be loaded. + + uplevel #0 package require Thread + proc [namespace current]::ptask script { + return [Promise new [lambda {script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + # ok or return + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + thread::create $thread_script + } $script]] + } + tailcall [namespace current]::ptask $script +} + +proc promise::pworker {tpool script} { + # Runs a script in a worker thread from a thread pool and + # returns a promise for the same. + # tpool - thread pool identifier + # script - script to run in the worker thread + # Returns a promise that will be settled by the result of the script + # + # The Thread package allows creation of a thread pool with the + # `tpool create` command. The `pworker` command runs the specified + # script in a worker thread from a thread pool. The promise + # returned from this command will be fulfilled with the result of + # the script if it completes successfully. + # Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + + # No need for package require Thread since if tpool is passed to + # us, Thread must already be loaded + return [Promise new [lambda {tpool script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + tpool::post -detached -nowait $tpool $thread_script + } $tpool $script]] +} + +if {0} { + package require http + proc checkurl {url} { + set prom [promise::Promise new [promise::lambda {url prom} { + http::geturl $url -method HEAD -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + $prom fulfill [list $http_state(url) $http_state(status)] + ::http::cleanup $tok + } $prom] + } $url]] + return $prom + } + + proc checkurls {urls} { + return [promise::all [lmap url $urls {checkurl $url}]] + } + + [promise::all [ + list [ + promise::ptask {expr 1+1} + ] [ + promise::ptask {expr 2+2} + ] + ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] +} + +package provide promise [promise::version] + +if {[info exists ::argv0] && + [file tail [info script]] eq [file tail $::argv0]} { + set filename [file tail [info script]] + if {[llength $::argv] == 0} { + puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" + exit 1 + } + switch -glob -- [lindex $::argv 0] { + ver* { puts [promise::version] } + tm - + dist* { + if {[file extension $filename] ne ".tm"} { + set dir [file join [file dirname [info script]] .. build] + file mkdir $dir + file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] + } else { + error "Cannot create distribution from a .tm file" + } + } + install { + # Install in first native file system that exists on search path + foreach path [tcl::tm::path list] { + if {[lindex [file system $path] 0] eq "native"} { + set dir $path + if {[file isdirectory $path]} { + break + } + # Else keep looking + } + } + if {![file exists $dir]} { + file mkdir $dir + } + if {[file extension $filename] eq ".tm"} { + # We already are a .tm with version number + set target $filename + } else { + set target [file rootname $filename]-[promise::version].tm + } + file copy -force [info script] [file join $dir $target] + } + default { + puts stderr "Unknown option/command \"[lindex $::argv 0]\"" + exit 1 + } + } +} diff --git a/src/vendormodules/tomlish-1.1.1.tm b/src/vendormodules/tomlish-1.1.1.tm index 3e13e75d..0c8d0b1a 100644 --- a/src/vendormodules/tomlish-1.1.1.tm +++ b/src/vendormodules/tomlish-1.1.1.tm @@ -716,6 +716,7 @@ namespace eval tomlish { set toml [::tomlish::to_toml $tomlish] } + #TODO use huddle? proc from_json {json} { set jstruct [::tomlish::json_struct $json] return [::tomlish::from_json_struct $jstruct] @@ -1080,11 +1081,13 @@ namespace eval tomlish::decode { # For this reason, we also do absolutely no line-ending transformations based on platform. # All line-endings are maintained as is, and even a file with mixed cr crlf line-endings will be correctly interpreted and can be 'roundtripped' - proc toml {s} { + proc toml {args} { #*** !doctools - #[call [fun toml] [arg s]] + #[call [fun toml] [arg arg...]] #[para] return a Tcl list of tomlish tokens + set s [join $args \n] + namespace upvar ::tomlish::parse is_parsing is_parsing set is_parsing 1 @@ -2380,7 +2383,7 @@ namespace eval tomlish::parse { squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ endinlinetable "POPSPACE"\ startquote "quoted-key"\ - startsquote {TOSTATE "squoted-key" comment "jn-ok"}\ + startsquote {TOSTATE "squoted-key" comment "jn-testing"}\ comma "itable-space"\ comment "err-state"\ eof "err-state"\ diff --git a/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl b/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl index 57296992..95f057bb 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl @@ -233,77 +233,77 @@ namespace eval shellspy { proc get_channel_config {config} { #note tcl script being called from wrong place.. configs don't affect: todo - move it. set params [dict create] - if {$config == 0} { - #bad for: everything. extra cr - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation auto - } - - if {$config == 1} { - #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process - #not ok for: bash,wsl, tcl script - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf - } - if {$config == 2} { - #ok for: cmd, cmd/uc,pwsh,sh , tcl script process - #not ok for: tcl script, bash, wsl - dict set params -inbuffering none ;#default - dict set params -outbuffering none ;#default - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf ;#default - } - if {$config == 3} { - #ok for: cmd - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - if {$config == 4} { - #ok for: cmd,cmd/uc,raw,sh - #not ok for pwsh,bash,wsl, tcl script, tcl script process - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - - if {$config == 5} { - #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process - #not ok for bash,wsl - #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - if {$config == 6} { - #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash - #not ok for: vim with cmd /u/c (?) - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - if {$config == 7} { - #ok for: sh,bash - #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation crlf - } - if {$config == 8} { - #not ok for anything..all have extra cr - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation crlf + switch -- $config { + 0 { + #bad for: everything. extra cr + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation auto + } + 1 { + #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process + #not ok for: bash,wsl, tcl script + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf + } + 2 { + #ok for: cmd, cmd/uc,pwsh,sh , tcl script process + #not ok for: tcl script, bash, wsl + dict set params -inbuffering none ;#default + dict set params -outbuffering none ;#default + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf ;#default + } + 3 { + #ok for: cmd + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 4 { + #ok for: cmd,cmd/uc,raw,sh + #not ok for pwsh,bash,wsl, tcl script, tcl script process + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 5 { + #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process + #not ok for bash,wsl + #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 6 { + #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash + #not ok for: vim with cmd /u/c (?) + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 7 { + #ok for: sh,bash + #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation crlf + } + 8 { + #not ok for anything..all have extra cr + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation crlf + } } return $params } @@ -653,10 +653,27 @@ namespace eval shellspy { set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { ::tcl::tm::add %m% set scriptname %s% -set ::argv [list %a%] -set ::argc [llength $::argv] -source [file normalize $scriptname] - +set normscript [file normalize $scriptname] + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] +set ::argv0 $normscript +info script $normscript +source $normscript + +#restore values +info script $prevscript +dict with prevglobal {} }] set repl_lines "" diff --git a/src/vfs/_vfscommon.vfs/modules/promise-1.2.0.tm b/src/vfs/_vfscommon.vfs/modules/promise-1.2.0.tm new file mode 100644 index 00000000..a4b82e45 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/promise-1.2.0.tm @@ -0,0 +1,1311 @@ +# Copyright (c) 2015-2023, Ashok P. Nadkarni +# All rights reserved. + +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: + +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. + +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. + +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +package require Tcl 8.6- + +namespace eval promise { + proc version {} { return 1.2.0 } +} + +proc promise::lambda {params body args} { + # Creates an anonymous procedure and returns a command prefix for it. + # params - parameter definitions for the procedure + # body - body of the procedures + # args - additional arguments to be passed to the procedure when it + # is invoked + # + # This is just a convenience command since anonymous procedures are + # commonly useful with promises. The lambda package from tcllib + # is identical in function. + + return [list ::apply [list $params $body] {*}$args] +} + +catch {promise::Promise destroy} +oo::class create promise::Promise { + + # The promise state can be one of + # PENDING - Initial state where it has not yet been assigned a + # value or error + # FULFILLED - The promise has been assigned a value + # REJECTED - The promise has been assigned an error + # CHAINED - The promise is attached to another promise + variable _state + + # Stores data that is accessed through the setdata/getdata methods. + # The Promise class itself does not use this. + variable _clientdata + + # The promise value once it is fulfilled or rejected. In the latter + # case, it should be an the error message + variable _value + + # The error dictionary in case promise is rejected + variable _edict + + # Reactions to be notified when the promise is rejected. Each element + # in this list is a pair consisting of the fulfilment reaction + # and the rejection reaction. Either element of the pair could be + # empty signifying no reaction for that case. The list is populated + # via the then method. + variable _reactions + + # Reference counting to free up promises since Tcl does not have + # garbage collection for objects. Garbage collection via reference + # counting only takes place after at least one done/then reaction + # is placed on the event queue, not before. Else promises that + # are immediately resolved on construction would be freed right + # away before the application even gets a chance to call done/then. + variable _do_gc + variable _nrefs + + # If no reject reactions are registered, then the Tcl bgerror + # handler is invoked. But don't want to do this more than once + # so track it + variable _bgerror_done + + constructor {cmd} { + # Create a promise for the asynchronous operation to be initiated + # by $cmd. + # cmd - a command prefix that should initiate an asynchronous + # operation. + # The command prefix $cmd is passed an additional argument - the + # name of this Promise object. It should arrange for one of the + # object's settle methods [fulfill], [chain] or + # [reject] to be called when the operation completes. + + set _state PENDING + set _reactions [list ] + set _do_gc 0 + set _bgerror_done 0 + set _nrefs 0 + array set _clientdata {} + + # Errors in the construction command are returned via + # the standard mechanism of reject. + # + if {[catch { + # For some special cases, $cmd may be "" if the async operation + # is initiated outside the constructor. This is not a good + # thing because the error in the initiator will not be + # trapped via the standard promise error catching mechanism + # but that's the application's problem (actually pgeturl also + # uses this). + if {[llength $cmd]} { + uplevel #0 [linsert $cmd end [self]] + } + } msg edict]} { + my reject $msg $edict + } + } + + destructor { + # Destroys the object. + # + # This method should not be generally called directly as [Promise] + # objects are garbage collected either automatically or via the [ref] + # and [unref] methods. + } + + method state {} { + # Returns the current state of the promise. + # + # The promise state may be one of the values `PENDING`, + # `FULFILLED`, `REJECTED` or `CHAINED` + return $_state + } + + method getdata {key} { + # Returns data previously stored through the setdata method. + # key - key whose associated values is to be returned. + # An error will be raised if no value is associated with the key. + return $_clientdata($key) + } + + method setdata {key value} { + # Sets a value to be associated with a key. + # key - the lookup key + # value - the value to be associated with the key + # A promise internally maintains a dictionary whose values can + # be accessed with the [getdata] and [setdata] methods. This + # dictionary is not used by the Promise class itself but is meant + # to be used by promise library specializations or applications. + # Callers need to take care that keys used for a particular + # promise are sufficiently distinguishable so as to not clash. + # + # Returns the value stored with the key. + set _clientdata($key) $value + } + + method value {} { + # Returns the settled value for the promise. + # + # The returned value may be the fulfilled value or the rejected + # value depending on whether the associated operation was successfully + # completed or failed. + # + # An error is raised if the promise is not settled yet. + if {$_state ni {FULFILLED REJECTED}} { + error "Value is not set." + } + return $_value + } + + method ref {} { + # Increments the reference count for the object. + incr _nrefs + } + + method unref {} { + # Decrements the reference count for the object. + # + # The object may have been destroyed when the call returns. + incr _nrefs -1 + my GC + } + + method nrefs {} { + # Returns the current reference count. + # + # Use for debugging only! Note, internal references are not included. + return $_nrefs + } + + method GC {} { + if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { + my destroy + } + } + + method FulfillAttached {value} { + if {$_state ne "CHAINED"} { + return + } + set _value $value + set _state FULFILLED + my ScheduleReactions + return + } + + method RejectAttached {reason edict} { + if {$_state ne "CHAINED"} { + return + } + set _value $reason + set _edict $edict + set _state REJECTED + my ScheduleReactions + return + } + + # Method to invoke to fulfil a promise with a value or another promise. + method fulfill {value} { + # Fulfills the promise. + # value - the value with which the promise is fulfilled + # + # Returns `0` if promise had already been settled and `1` if + # it was fulfilled by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `FULFILLED` state with + # the value specified by $value. If there are any fulfillment + # reactions registered by the [Promise.done] or [Promise.then] methods, they + # are scheduled to be run. + set _value $value + set _state FULFILLED + my ScheduleReactions + return 1 + } + + # Method to invoke to fulfil a promise with a value or another promise. + method chain {promise} { + # Chains the promise to another promise. + # promise - the [Promise] object to which this promise is to + # be chained + # + # Returns `0` if promise had already been settled and `1` otherwise. + + #ruff + # If the promise on which this method is called + # has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; + } + + #ruff + # Otherwise, it is chained to $promise so that it reflects that + # other promise's state. + if {[catch { + $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] + } msg edict]} { + my reject $msg $edict + } else { + set _state CHAINED + } + + return 1 + } + + method reject {reason {edict {}}} { + # Rejects the promise. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # + # The $reason and $edict values are passed on to the rejection + # reactions. By convention, these should be of the form returned + # by the `catch` or `try` commands in case of errors. + # + # Returns `0` if promise had already been settled and `1` if + # it was rejected by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `REJECTED` state. If + # there are any reject reactions registered by the [Promise.done] or + # [Promise.then] methods, they are scheduled to be run. + + set _value $reason + #ruff + # If $edict is not specified, or specified as an empty string, + # a suitable error dictionary is constructed in its place + # to be passed to the reaction. + if {$edict eq ""} { + catch {throw {PROMISE REJECTED} $reason} - edict + } + set _edict $edict + set _state REJECTED + my ScheduleReactions + return 1 + } + + # Internal method to queue all registered reactions based on + # whether the promise is succesfully fulfilled or not + method ScheduleReactions {} { + if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { + # Promise is not settled or no reactions registered + return + } + + # Note on garbage collection: garbage collection is to be enabled if + # at least one FULFILLED or REJECTED reaction is registered. + # Also if the promise is REJECTED but no rejection handlers are run + # we also schedule a background error. + # In all cases, CLEANUP reactions do not count. + foreach reaction $_reactions { + foreach type {FULFILLED REJECTED} { + if {[dict exists $reaction $type]} { + set _do_gc 1 + if {$type eq $_state} { + set cmd [dict get $reaction $type] + if {[llength $cmd]} { + if {$type eq "FULFILLED"} { + lappend cmd $_value + } else { + lappend cmd $_value $_edict + } + set ran_reaction($type) 1 + # Enqueue the reaction via the event loop + after 0 [list after idle $cmd] + } + } + } + } + if {[dict exists $reaction CLEANUP]} { + set cmd [dict get $reaction CLEANUP] + if {[llength $cmd]} { + # Enqueue the cleaner via the event loop passing the + # *state* as well as the value + if {$_state eq "REJECTED"} { + lappend cmd $_state $_value $_edict + } else { + lappend cmd $_state $_value + } + after 0 [list after idle $cmd] + # Note we do not set _do_gc if we only run cleaners + } + } + } + set _reactions [list ] + + # Check for need to background error (see comments above) + if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { + # TBD - should we also check _nrefs before backgrounding error? + + # Wrap in catch in case $_edict does not follow error conventions + # or is not even a dictionary + if {[catch { + dict get $_edict -level + dict get $_edict -code + }]} { + catch {throw {PROMISE REJECT} $_value} - edict + } else { + set edict $_edict + } + # TBD - how exactly is level to be handled? + # If -level is not 0, bgerror barfs because it treates + # it as TCL_RETURN no matter was -code is + dict set edict -level 0 + after idle [interp bgerror {}] [list $_value $edict] + set _bgerror_done 1 + } + + my GC + return + } + + method RegisterReactions {args} { + # Registers the specified reactions. + # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` + # with values being the corresponding reaction callback + + lappend _reactions $args + my ScheduleReactions + return + } + + method done {{on_fulfill {}} {on_reject {}}} { + # Registers reactions to be run when the promise is settled. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. + # Reactions are called with an additional argument which is + # the value with which the promise was settled. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # The method triggers garbage collection of the object if the + # promise has been settled and any registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Note that both $on_fulfill and $on_reject may be specified + # as empty strings if no further action needs to be taken on + # settlement of the promise. If the promise is rejected, and + # no rejection reactions are registered, the error is reported + # via the Tcl `interp bgerror` facility. + + # TBD - as per the Promise/A+ spec, errors in done should generate + # a background error (unlike then). + + my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject + + #ruff + # The method does not return a value. + return + } + + method then {on_fulfill {on_reject {}}} { + # Registers reactions to be run when the promise is settled + # and returns a new [Promise] object that will be settled by the + # reactions. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. If an empty string, no fulfill + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. If unspecified or an empty string, + # no reject reaction is registered. + # Both reactions are passed the value with which the promise was settled. + # The reject reaction is passed an additional argument which is + # the error dictionary. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # If the reaction that is invoked runs without error, its return + # value fulfills the new promise returned by the `then` method. + # If it raises an exception, the new promise will be rejected + # with the error message and dictionary from the exception. + # + # Alternatively, the reactions can explicitly invoke commands + # [then_fulfill], [then_reject] or [then_chain] to + # resolve the returned promise. In this case, the return value + # (including exceptions) from the reactions are ignored. + # + # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), + # the new promise is created and fulfilled (or rejected) with + # the same value that would have been passed in to the reactions. + # + # The method triggers garbage collection of the object if the + # promise has been settled and registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Returns a new promise that is settled by the registered reactions. + + set then_promise [[self class] new ""] + my RegisterReactions \ + FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ + REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] + return $then_promise + } + + # This could be a forward, but then we cannot document it via ruff! + method catch {on_reject} { + # Registers reactions to be run when the promise is rejected. + # on_reject - command prefix for the reaction + # reaction to run if the promise is rejected. If unspecified + # or an empty string, no reject reaction is registered. The + # reaction is called with an additional argument which is the + # value with which the promise was settled. + # This method is just a wrapper around [Promise.then] with the + # `on_fulfill` parameter defaulting to an empty string. See + # the description of that method for details. + return [my then "" $on_reject] + } + + method cleanup {cleaner} { + # Registers a reaction to be executed for running cleanup + # code when the promise is settled. + # cleaner - command prefix to run on settlement + # This method is intended to run a clean up script + # when a promise is settled. Its primary use is to avoid duplication + # of code in the `then` and `catch` handlers for a promise. + # It may also be called multiple times + # to clean up intermediate steps when promises are chained. + # + # The method returns a new promise that will be settled + # as per the following rules. + # - if the cleaner runs without errors, the returned promise + # will reflect the settlement of the promise on which this + # method is called. + # - if the cleaner raises an exception, the returned promise + # is rejected with a value consisting of the error message + # and dictionary pair. + # + # Returns a new promise that is settled based on the cleaner + set cleaner_promise [[self class] new ""] + my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] + return $cleaner_promise + } +} + +proc promise::_then_reaction {target_promise status cmd value {edict {}}} { + # Run the specified command and fulfill/reject the target promise + # accordingly. If the command is empty, the passed-in value is passed + # on to the target promise. + + # IMPORTANT!!!! + # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else + # promise::then_fulfill/then_reject/then_chain will not work + # Also, Do NOT change the param name target_promise without changing + # those procs. + # Oh what a hack to get around lack of closures. Alternative would have + # been to pass an additional parameter (target_promise) + # to the application code but then that script would have had to + # carry that around. + + if {[info level] != 1} { + error "Internal error: _then_reaction not at level 1" + } + + if {[llength $cmd] == 0} { + switch -exact -- $status { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict} + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid status $state" + } + } + } else { + # Invoke the real reaction code and fulfill/reject the target promise. + # Note the reaction code may have called one of the promise::then_* + # commands itself and reactions run resulting in the object being + # freed. Hence resolve using the safe* variants + # TBD - ideally we would like to execute at global level. However + # the then_* commands retrieve target_promise from level 1 (here) + # which they cannot if uplevel #0 is done. So directly invoke. + if {$status eq "REJECTED"} { + lappend cmd $value $edict + } else { + lappend cmd $value + } + if {[catch $cmd reaction_value reaction_edict]} { + safe_reject $target_promise $reaction_value $reaction_edict + } else { + safe_fulfill $target_promise $reaction_value + } + } + return +} + +proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { + # Run the specified cleaner and fulfill/reject the target promise + # accordingly. If the cleaner executes without error, the original + # value and state is passed on. If the cleaner executes with error + # the promise is rejected. + + if {[llength $cleaner] == 0} { + switch -exact -- $state { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict } + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid state $state" + } + } + } else { + if {[catch {uplevel #0 $cleaner} err edict]} { + # Cleaner failed. Reject the target promise + $target_promise reject $err $edict + } else { + # Cleaner completed without errors, pass on the original value + if {$state eq "FULFILLED"} { + $target_promise fulfill $value + } else { + $target_promise reject $value $edict + } + } + } + return +} + +proc promise::then_fulfill {value} { + # Fulfills the promise returned by a [Promise.then] method call from + # within its reaction. + # value - the value with which to fulfill the promise + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - `then_fulfill`, + # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + + # TBD - what if someone calls this from within a uplevel #0 ? The + # upvar will be all wrong + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_fulfill called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise fulfill $value +} + +proc promise::then_chain {promise} { + # Chains the promise returned by a [Promise.then] method call to + # another promise. + # promise - the promise to which the promise returned by [Promise.then] is + # to be chained + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_chain` chains + # the promise returned by the `then` method that queued the currently + # running reaction to $promise so that the former will be settled + # based on the latter. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_chain called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise chain $promise +} + +proc promise::then_reject {reason edict} { + # Rejects the promise returned by a [Promise.then] method call from + # within its reaction. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_reject` rejects + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_reject called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise reject $reason $edict +} + +proc promise::all {promises} { + # Returns a promise that fulfills or rejects when all promises + # in the $promises argument have fulfilled or any one has rejected. + # promises - a list of Promise objects + # If any of $promises rejects, then the promise returned by the + # command will reject with the same value. Otherwise, the promise + # will fulfill when all promises have fulfilled. + # The resolved value will be a list of the resolved + # values of the contained promises. + + set all_promise [Promise new [lambda {promises prom} { + set npromises [llength $promises] + if {$npromises == 0} { + $prom fulfill {} + return + } + + # Ask each promise to update us when resolved. + foreach promise $promises { + $promise done \ + [list ::promise::_all_helper $prom $promise FULFILLED] \ + [list ::promise::_all_helper $prom $promise REJECTED] + } + + # We keep track of state with a dictionary that will be + # stored in $prom with the following keys: + # PROMISES - the list of promises in the order passed + # PENDING_COUNT - count of unresolved promises + # RESULTS - dictionary keyed by promise and containing resolved value + set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] + + $prom setdata ALLPROMISES $all_state + } $promises]] + + return $all_promise +} + +proc promise::all* args { + # Returns a promise that fulfills or rejects when all promises + # in the $args argument have fulfilled or any one has rejected. + # args - list of Promise objects + # This command is identical to the all command except that it takes + # multiple arguments, each of which is a Promise object. See [all] + # for a description. + return [all $args] +} + +# Callback for promise::all. +# all_promise - the "master" promise returned by the all call. +# done_promise - the promise whose callback is being serviced. +# resolution - whether the current promise was resolved with "FULFILLED" +# or "REJECTED" +# value - the value of the currently fulfilled promise or error description +# in case rejected +# edict - error dictionary (if promise was rejected) +proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { + if {![info object isa object $all_promise]} { + # The object has been deleted. Naught to do + return + } + if {[$all_promise state] ne "PENDING"} { + # Already settled. This can happen when a tracked promise is + # rejected and another tracked promise gets settled afterwards. + return + } + if {$resolution eq "REJECTED"} { + # This promise failed. Immediately reject the master promise + # TBD - can we somehow indicate which promise failed ? + $all_promise reject $value $edict + return + } + + # Update the state of the resolved tracked promise + set all_state [$all_promise getdata ALLPROMISES] + dict set all_state RESULTS $done_promise $value + dict incr all_state PENDING_COUNT -1 + $all_promise setdata ALLPROMISES $all_state + + # If all promises resolved, resolve the all promise + if {[dict get $all_state PENDING_COUNT] == 0} { + set values {} + foreach prom [dict get $all_state PROMISES] { + lappend values [dict get $all_state RESULTS $prom] + } + $all_promise fulfill $values + } + return +} + +proc promise::race {promises} { + # Returns a promise that fulfills or rejects when any promise + # in the $promises argument is fulfilled or rejected. + # promises - a list of Promise objects + # The returned promise will fulfill and reject with the same value + # as the first promise in $promises that fulfills or rejects. + set race_promise [Promise new [lambda {promises prom} { + if {[llength $promises] == 0} { + catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict + $prom reject $reason $edict + return + } + # Use safe_*, do not directly call methods since $prom may be + # gc'ed once settled + foreach promise $promises { + $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] + } + } $promises]] + + return $race_promise +} + +proc promise::race* {args} { + # Returns a promise that fulfills or rejects when any promise + # in the passed arguments is fulfilled or rejected. + # args - list of Promise objects + # This command is identical to the `race` command except that it takes + # multiple arguments, each of which is a Promise object. See [race] + # for a description. + return [race $args] +} + +proc promise::await {prom} { + # Waits for a promise to be settled and returns its resolved value. + # prom - the promise that is to be waited on + # This command may only be used from within a procedure constructed + # with the [async] command or any code invoked from it. + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + set coro [info coroutine] + if {$coro eq ""} { + throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" + } + $prom done [list $coro success] [list $coro fail] + lassign [yieldto return -level 0] status val ropts + if {$status eq "success"} { + return $val + } else { + return -options $ropts $val + } +} + +proc promise::async {name paramdefs body} { + # Defines an procedure that will run a script asynchronously as a coroutine. + # name - name of the procedure + # paramdefs - the parameter definitions to the procedure in the same + # form as passed to the standard `proc` command + # body - the script to be executed + # + # When the defined procedure $name is called, it runs the supplied $body + # within a new coroutine. The return value from the $name procedure call + # will be a promise that will be fulfilled when the coroutine completes + # normally or rejected if it completes with an error. + # + # Note that the passed $body argument is not the body of the + # the procedure $name. Rather it is run as an anonymous procedure in + # the coroutine but in the same namespace context as $name. Thus the + # caller or the $body script must not make any assumptions about + # relative stack levels, use of `uplevel` etc. + # + # The primary purpose of this command is to make it easy, in + # conjunction with the [await] command, to wrap a sequence of asynchronous + # operations as a single computational unit. + # + # Returns a promise that will be settled with the result of the script. + if {![string equal -length 2 "$name" "::"]} { + set ns [uplevel 1 namespace current] + set name ${ns}::$name + } else { + set ns :: + } + set tmpl { + proc %NAME% {%PARAMDEFS%} { + set p [promise::Promise new [promise::lambda {real_args prom} { + coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { + upvar #1 _current_async_promise current_p + set current_p $p + set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] + if {$status == 0} { + $p fulfill $res + } else { + $p reject $res $ropts + } + } $prom {*}$real_args] + } [lrange [info level 0] 1 end]]] + return $p + } + } + eval [string map [list %NAME% $name \ + %PARAMDEFS% $paramdefs \ + %BODY% $body \ + %NS% $ns] $tmpl] +} + +proc promise::async_fulfill {val} { + # Fulfills a promise for an async procedure with the specified value. + # val - the value with which to fulfill the promise + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_fulfill called from outside an async context." + } + $current_p fulfill $val + return +} + +proc promise::async_reject {val {edict {}}} { + # Rejects a promise for an async procedure with the specified value. + # val - the value with which to reject the promise + # edict - error dictionary for rejection + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_reject called from outside an async context." + } + $current_p reject $val $edict + return +} + +proc promise::async_chain {prom} { + # Chains a promise for an async procedure to the specified promise. + # prom - the promise to which the async promise is to be linked. + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_chain called from outside an async context." + } + $current_p chain $prom + return +} + +proc promise::pfulfilled {value} { + # Returns a new promise that is already fulfilled with the specified value. + # value - the value with which to fulfill the created promise + return [Promise new [lambda {value prom} { + $prom fulfill $value + } $value]] +} + +proc promise::prejected {value {edict {}}} { + # Returns a new promise that is already rejected. + # value - the value with which to reject the promise + # edict - error dictionary for rejection + # By convention, $value should be of the format returned by + # [Promise.reject]. + return [Promise new [lambda {value edict prom} { + $prom reject $value $edict + } $value $edict]] +} + +proc promise::eventloop {prom} { + # Waits in the eventloop until the specified promise is settled. + # prom - the promise to be waited on + # The command enters the event loop in similar fashion to the + # Tcl `vwait` command except that instead of waiting on a variable + # the command waits for the specified promise to be settled. As such + # it has the same caveats as the vwait command in terms of care + # being taken in nested calls etc. + # + # The primary use of the command is at the top level of a script + # to wait for one or more promise based tasks to be completed. Again, + # similar to the vwait forever idiom. + # + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + + set varname [namespace current]::_pwait_[info cmdcount] + $prom done \ + [lambda {varname result} { + set $varname [list success $result] + } $varname] \ + [lambda {varname error ropts} { + set $varname [list fail $error $ropts] + } $varname] + vwait $varname + lassign [set $varname] status result ropts + if {$status eq "success"} { + return $result + } else { + return -options $ropts $result + } +} + +proc promise::pgeturl {url args} { + # Returns a promise that will be fulfilled when the URL is fetched. + # url - the URL to fetch + # args - arguments to pass to the `http::geturl` command + # This command invokes the asynchronous form of the `http::geturl` command + # of the `http` package. If the operation completes with a status of + # `ok`, the returned promise is fulfilled with the contents of the + # http state array (see the documentation of `http::geturl`). If the + # the status is anything else, the promise is rejected with + # the `reason` parameter to the reaction containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # with an additional key `http_state`, containing the + # contents of the http state array. + + uplevel #0 {package require http} + proc pgeturl {url args} { + set prom [Promise new [lambda {http_args prom} { + http::geturl {*}$http_args -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + if {$http_state(status) eq "ok"} { + $prom fulfill [array get http_state] + } else { + if {[info exists http_state(error)]} { + set msg [lindex $http_state(error) 0] + } + if {![info exists msg] || $msg eq ""} { + set msg "Error retrieving URL." + } + catch {throw {PROMISE PGETURL} $msg} msg edict + dict set edict http_state [array get http_state] + $prom reject $msg $edict + } + http::cleanup $tok + } $prom] + } [linsert $args 0 $url]]] + return $prom + } + tailcall pgeturl $url {*}$args +} + +proc promise::ptimer {millisecs {value "Timer expired."}} { + # Returns a promise that will be fulfilled when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be fulfilled + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to an error + # message and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimeout] which is similar but rejects the promise instead + # of fulfilling it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't allow "idle", "cancel" etc. as an argument to after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [list promise::safe_fulfill $prom $value] + } $millisecs $value]] +} + +proc promise::ptimeout {millisecs {value "Operation timed out."}} { + # Returns a promise that will be rejected when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be rejected + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to $value + # and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimer] which is similar but fulfills the promise instead + # of rejecting it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't want to accept "idle", "cancel" etc. for after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [::promise::lambda {prom msg} { + catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict + ::promise::safe_reject $prom $msg $edict + } $prom $value] + } $millisecs $value]] +} + +proc promise::pconnect {args} { + # Returns a promise that will be fulfilled when the socket connection + # is completed. + # args - arguments to be passed to the Tcl `socket` command + # This is a wrapper for the async version of the Tcl `socket` command. + # If the connection completes, the promise is fulfilled with the + # socket handle. + # In case of errors (e.g. if the address cannot be fulfilled), the + # promise is rejected with the `reason` parameter containing the + # error message and the `edict` parameter containing the Tcl error + # dictionary. + # + return [Promise new [lambda {so_args prom} { + set so [socket -async {*}$so_args] + fileevent $so writable [promise::lambda {prom so} { + fileevent $so writable {} + set err [chan configure $so -error] + if {$err eq ""} { + $prom fulfill $so + } else { + catch {throw {PROMISE PCONNECT FAIL} $err} err edict + $prom reject $err $edict + } + } $prom $so] + } $args]] +} + +proc promise::_read_channel {prom chan data} { + set newdata [read $chan] + if {[string length $newdata] || ![eof $chan]} { + append data $newdata + fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] + return + } + + # EOF + set code [catch { + # Need to make the channel blocking else no error is returned + # on the close + fileevent $chan readable {} + fconfigure $chan -blocking 1 + close $chan + } result edict] + if {$code} { + safe_reject $prom $result $edict + } else { + safe_fulfill $prom $data + } +} + +proc promise::pexec {args} { + # Runs an external program and returns a promise for its output. + # args - program and its arguments as passed to the Tcl `open` call + # for creating pipes + # If the program runs without errors, the promise is fulfilled by its + # standard output content. Otherwise + # promise is rejected. + # + # Returns a promise that will be settled by the result of the program + return [Promise new [lambda {open_args prom} { + set chan [open |$open_args r] + fconfigure $chan -blocking 0 + fileevent $chan readable [list promise::_read_channel $prom $chan ""] + } $args]] +} + +proc promise::safe_fulfill {prom value} { + # Fulfills the specified promise. + # prom - the [Promise] object to be fulfilled + # value - the fulfillment value + # This is a convenience command that checks if $prom still exists + # and if so fulfills it with $value. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [fulfill][Promise.fulfill] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return 0 + } + return [$prom fulfill $value] +} + +proc promise::safe_reject {prom value {edict {}}} { + # Rejects the specified promise. + # prom - the [Promise] object to be fulfilled + # value - see [Promise.reject] + # edict - see [Promise.reject] + # This is a convenience command that checks if $prom still exists + # and if so rejects it with the specified arguments. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [reject][Promise.reject] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return + } + $prom reject $value $edict +} + +proc promise::ptask {script} { + # Creates a new Tcl thread to run the specified script and returns + # a promise for the script results. + # script - script to run in the thread + # Returns a promise that will be settled by the result of the script + # + # The `ptask` command runs the specified script in a new Tcl + # thread. The promise returned from this command will be fulfilled + # with the result of the script if it completes + # successfully. Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + # + # The command requires the Thread package to be loaded. + + uplevel #0 package require Thread + proc [namespace current]::ptask script { + return [Promise new [lambda {script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + # ok or return + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + thread::create $thread_script + } $script]] + } + tailcall [namespace current]::ptask $script +} + +proc promise::pworker {tpool script} { + # Runs a script in a worker thread from a thread pool and + # returns a promise for the same. + # tpool - thread pool identifier + # script - script to run in the worker thread + # Returns a promise that will be settled by the result of the script + # + # The Thread package allows creation of a thread pool with the + # `tpool create` command. The `pworker` command runs the specified + # script in a worker thread from a thread pool. The promise + # returned from this command will be fulfilled with the result of + # the script if it completes successfully. + # Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + + # No need for package require Thread since if tpool is passed to + # us, Thread must already be loaded + return [Promise new [lambda {tpool script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + tpool::post -detached -nowait $tpool $thread_script + } $tpool $script]] +} + +if {0} { + package require http + proc checkurl {url} { + set prom [promise::Promise new [promise::lambda {url prom} { + http::geturl $url -method HEAD -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + $prom fulfill [list $http_state(url) $http_state(status)] + ::http::cleanup $tok + } $prom] + } $url]] + return $prom + } + + proc checkurls {urls} { + return [promise::all [lmap url $urls {checkurl $url}]] + } + + [promise::all [ + list [ + promise::ptask {expr 1+1} + ] [ + promise::ptask {expr 2+2} + ] + ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] +} + +package provide promise [promise::version] + +if {[info exists ::argv0] && + [file tail [info script]] eq [file tail $::argv0]} { + set filename [file tail [info script]] + if {[llength $::argv] == 0} { + puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" + exit 1 + } + switch -glob -- [lindex $::argv 0] { + ver* { puts [promise::version] } + tm - + dist* { + if {[file extension $filename] ne ".tm"} { + set dir [file join [file dirname [info script]] .. build] + file mkdir $dir + file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] + } else { + error "Cannot create distribution from a .tm file" + } + } + install { + # Install in first native file system that exists on search path + foreach path [tcl::tm::path list] { + if {[lindex [file system $path] 0] eq "native"} { + set dir $path + if {[file isdirectory $path]} { + break + } + # Else keep looking + } + } + if {![file exists $dir]} { + file mkdir $dir + } + if {[file extension $filename] eq ".tm"} { + # We already are a .tm with version number + set target $filename + } else { + set target [file rootname $filename]-[promise::version].tm + } + file copy -force [info script] [file join $dir $target] + } + default { + puts stderr "Unknown option/command \"[lindex $::argv 0]\"" + exit 1 + } + } +} diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm index e940dada..74a3ffc8 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm @@ -4001,7 +4001,17 @@ tcl::namespace::eval punk::args { set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { - set chosen $v_test + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set set choice_in_list 1 } else { #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. @@ -4046,6 +4056,7 @@ tcl::namespace::eval punk::args { } } + #override the optimistic existing val if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm index 3b8f0c87..5f1b813a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm @@ -70,7 +70,7 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cesu { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - #variable xyz + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::cesu}] @@ -96,6 +96,8 @@ tcl::namespace::eval punk::cesu { } proc mapReply string { + package rquire http + http::config variable ::http::formMap set string [encoding convertto utf-8 $string] @@ -104,19 +106,21 @@ tcl::namespace::eval punk::cesu { } - + #where did original come from? wiki? proc cesu2utf str { #hacked by JMN - as original seemed broken and intention as to input is unclear if {[regexp {\xED([\xA0-\xAF])([\x80-\xBF])\xED([\xB0-\xBF])([\x80-\xBF])} $str]} { #set str [string map {\ \\ \[ \\\[ \] \\\]} $str] ;#original -broken - unsure of usecase/intention set str [string map {\\ \\\\ \[ \\\[ \] \\\]} $str] ;#guess intention is to stop premature substitution of escapes and commands #return [subst -novariables [regsub -all {^\xED([\xA0-\xAF])([\x80-\xBF])\xED([\xB0-\xBF])([\x80-\xBF])$} $str {[cesu2utfR \1 \2 \3 \4]} ]] ;#original. anchoring seems unlikely to be desirable + #capture the relevant 4 of the 6 bytes return [subst -novariables [regsub -all {\xED([\xA0-\xAF])([\x80-\xBF])\xED([\xB0-\xBF])([\x80-\xBF])} $str {[cesu2utfR \1 \2 \3 \4]} ]] } else { return $str } } + #4 captured bytes (excludes the 2 \xED leaders) proc cesu2utfR {1 2 3 4} { # UTF-8: 11110xxx 10xx xxxx 10xx xxxx 10xxxxxx # CESU-8: 11101101 1010 yy yy 10xxxx xx 11101101 1011xxxx 10xxxxxx @@ -125,7 +129,7 @@ tcl::namespace::eval punk::cesu { binary scan $3 c 3 puts [list $1 $2 $3] #binary scan $4 c 4 - incr 1 + incr 1 ;#// Effectively adds 0x10000 to the codepoint ? return [binary format ccca \ [expr {0xF0 | (($1 & 0xC) >> 2)}] \ @@ -171,17 +175,106 @@ tcl::namespace::eval punk::cesu { encoding convertfrom utf-8 $x } - #e.g test2 "note \ud83f\udd1e etc" - #e.g test2 "faces \ud83d\ude10 \ud83d\ude21 \ud83d\ude31" - #note: test2 \U1f600 returns a mouse (\U1f400) instead of smiley - # but test2 \U1f400 returns a mouse. - # Either surrogated_string shouldn't include non BMP chars anyway (G.I.G.O?).. or we're doing something wrong. - proc test2 {surrogated_string} { - #JMN + #e.g from_surrogatestring "note \ud83f\udd1e etc" + #e.g from_surrogatestring "faces \ud83d\ude10 \ud83d\ude21 \ud83d\ude31" + #note: from_surrogatestring \U1f600 returns a mouse (\U1f400) instead of smiley + # but from_surrogatestring \U1f400 returns a mouse. + # Tcl bug - fixed some time in 9.x + # surrogated_string shouldn't include non BMP chars anyway (G.I.G.O?) + lappend PUNKARGS [list { + @id -id ::punk::cesu::from_surrogatestring + @cmd -name punk::cesu::from_surrogatestring -help\ + "Convert a string containing surrogate pairs + to string with pairs converted to unicode non-BMP + characters" + @values + surrogated_string -help\ + "May contain a mix of surrogate pairs and other + characters - only the surrogate pairs will be converted." + }] + proc from_surrogatestring {surrogated_string} { set cesu [encoding convertto cesu-8 $surrogated_string] set x [cesu2utf $cesu] encoding convertfrom utf-8 $x } + proc _to_test {emoji} { + puts stderr "_to_test incomplete" + set cesu [encoding convertto cesu-8 $e] + puts stderr "cesu-8: $cesu" + + } + lappend PUNKARGS [list { + @id -id ::punk::cesu::to_surrogatestring + @opts + -format -default escape -choices {raw escape} -choicelabels { + raw\ + " emit raw surrogate pairs + may not be writable to + output channels" + escape\ + " emit unprocessed backslash hex + escape sequences for surrogate + pairs created for non-BMP chars. + (Does not convert existing surrogates + in the input into escape sequences!)" + } + @values -min 1 -max 1 + string -help\ + "String possibly containing non-BMP codepoints to be converted + e.g + >to_surrogatestring -format escape \"mouse: \\U1f400\" + mouse: \\uD83D\\uDC00 + " + }] + proc to_surrogatestring {args} { + set argd [punk::args::parse $args withid ::punk::cesu::to_surrogatestring] + lassign [dict values $argd] leaders opts values received + set opt_format [dict get $opts -format] + set string [dict get $values string] + set out "" + foreach c [split $string ""] { + set dec [scan $c %c] + if {$dec < 65536} { + append out $c + #if {$opt_format eq "escape"} { + #todo - detect existing surrogates in input? + #} + } else { + set pairinfo [nonbmp_surrogate_info $c] + if {$opt_format eq "raw"} { + append out [dict get $pairinfo raw] + } else { + append out [dict get $pairinfo escapes] + } + } + } + return $out + } + + proc nonbmp_surrogate_info {char} { + #set cinfo [punk::char::char_info $char] + #set dec [dict get $cinfo dec] + lassign [scan $char %c%s] dec remainder + if {$remainder ne "" || $dec < 65536} { + error "nonbmp_surrogate_info takes a single non-BMP char (codepoint in the range U+10000 to U+10FFFF)" + } + #U - 0x10000 + set less [expr {$dec - 0x10000}] + set lsb10 [expr {$less & 0b11111_11111}] ;#Least significant 10 bits of 20 + set msb10 [expr {($less & 0b11111_11111_00000_00000) >> 10}] ;#most significant 10 bits of 20 + + #apply 'base' values + set msbfinal [expr {$msb10 + 0xd800}] + set lsbfinal [expr {$lsb10 + 0xdc00}] + + set msbhex [format %4.4llX $msbfinal] + #set msbinfo [punk::char::char_info_dec $msbfinal -fields all -except testwidth] ;#don't use all/testwidth will try to emit the char and fail/show error + set lsbhex [format %4.4llX $lsbfinal] + #set lsbinfo [punk::char::char_info_dec $lsbfinal -fields all -except testwidth] ;#don't use all/testwidth will try to emit the char and fail/show error + set esc "\\u$msbhex\\u$lsbhex" + set raw [format %c $msbfinal][format %c $lsbfinal] + return [dict create escapes $esc msbdec $msbfinal msbhex $msbhex lsbdec $lsbfinal lsbhex $lsbhex raw $raw] + } # #test_enc_equivalency \U1f400 \U1f600 @@ -191,7 +284,7 @@ tcl::namespace::eval punk::cesu { foreach enc [lsort [encoding names]] { puts stdout "testing $enc" if {$enc in "iso2022 iso2022-jp iso2022-kr"} { - puts stderr "skipping $enc - crashes tcl9 on non BMP codepoints" + puts stderr "skipping $enc - crashes (early versions?) tcl9 on non BMP codepoints" continue } if {[catch { @@ -253,6 +346,106 @@ tcl::namespace::eval punk::cesu::lib { #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::cesu { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::cesu" + @package -name "punk::cesu" -help\ + "experimental cesu conversions + surrogate pair processing" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::cesu + } + 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::cesu + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::cesu::version" + } + proc get_topic_Contributors {} { + set authors {"Julian Noble "} + 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_custom-topic {} { + punk::args::lib::tstr -return string { + nothing to see here + } + } + # ------------------------------------------------------------- + } + + # 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::cesu::about" + dict set overrides @cmd -name "punk::cesu::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::cesu + }] \n] + dict set overrides topic -choices [list {*}[punk::cesu::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::cesu::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::cesu::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::cesu::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::cesu +} +# ----------------------------------------------------------------------------- ## Ready package provide punk::cesu [tcl::namespace::eval punk::cesu { variable pkg punk::cesu diff --git a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index 2e10e75b..a8884746 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -740,18 +740,27 @@ namespace eval punk::console { set was_raw 1 set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + puts -nonewline $output $query;flush $output chan configure $input -blocking 0 set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on set tsclock($callid) $tslaunch($callid) - #write before console enableRaw vs after?? - #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it - puts -nonewline $output $query;flush $output + #after 0 + #------------------ + #trying alternatives to get faster read and maintain reliability..REVIEW + #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features + #------------------ + # 1) faster - races? + $this_handler $input $callid $capturingendregex $this_handler $input $callid $capturingendregex - if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } + # 2) more reliable? + #chan event $input readable [list $this_handler $input $callid $capturingendregex] + #------------------ #response from terminal @@ -794,7 +803,7 @@ namespace eval punk::console { if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { - puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" + puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" } if {$was_raw == 0} { @@ -956,9 +965,10 @@ namespace eval punk::console { set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] #review - what is min length of any ansiresponse? + #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z #endregex is capturing - but as we are only testing the match here #it should perform the same as if it were non-capturing - if {[string length $sofar] > 3 && [regexp $endregex $sofar]} { + if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" chan event $chan readable {} set waits($callid) ok @@ -1438,7 +1448,8 @@ namespace eval punk::console { -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 newsize -default "" -help\ - "character cell pixel dimensions WxH" + "character cell pixel dimensions WxH + or omit to query cell size." } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] @@ -1474,6 +1485,31 @@ namespace eval punk::console { } set cell_size ${w}x${h} } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #puts -->$payload<-- + return [expr {$payload in {Z K M}}] + } #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { @@ -1587,7 +1623,6 @@ namespace eval punk::console { } - proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?7\$p" @@ -1683,7 +1718,14 @@ namespace eval punk::console { return } - puts -nonewline stdout $char_or_string + #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error + #e.g contains surrogate pair + if {[catch { + puts -nonewline stdout $char_or_string + } errM]} { + puts stderr "test_char_width couldn't emit this string - \nerror: $errM" + } + set response [punk::console::get_cursor_pos] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm new file mode 100644 index 00000000..fe28d0a4 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm @@ -0,0 +1,2168 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::icomm 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::icomm 0 0.1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::icomm] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::icomm +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::icomm +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::icomm::class { + #*** !doctools + #[subsection {Namespace punk::icomm::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# comm.tcl -- +# +# socket-based 'send'ing of commands between interpreters. +# +# %%_OSF_FREE_COPYRIGHT_%% +# Copyright (C) 1995-1998 The Open Group. All Rights Reserved. +# (Please see the file "comm.LICENSE" that accompanied this source, +# or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html) +# Copyright (c) 2003-2007 ActiveState Corporation +# +# This is the 'comm' package written by Jon Robert LoVerso, placed +# into its own namespace during integration into tcllib. +# +# Note that the actual code was changed in several places (Reordered, +# eval speedup) +# +# comm works just like Tk's send, except that it uses sockets. +# These commands work just like "send" and "winfo interps": +# +# comm send ?-async? ? ...? +# comm interps +# +# See the manual page comm.n for further details on this package. + +package require Tcl 8.6- +package require snit ; # comm::future objects. + +namespace eval ::punk::icomm { + namespace export comm comm_send + + variable comm + array set comm {} + + if {![info exists comm(chans)]} { + array set comm { + debug 0 chans {} localhost 127.0.0.1 + connecting,hook 1 + connected,hook 1 + incoming,hook 1 + eval,hook 1 + callback,hook 1 + reply,hook 1 + lost,hook 1 + offerVers {3 2 } + acceptVers {3 2 } + defVers 2 + defaultEncoding "utf-8" + defaultSilent 0 + } + + set comm(lastport) [expr {[pid] % 32768 + 9999}] + # fast check for acceptable versions + foreach comm(_x) $comm(acceptVers) { + set comm($comm(_x),vers) 1 + } + catch {unset comm(_x)} + } + + # Class variables: + # lastport saves last default listening port allocated + # debug enable debug output + # chans list of allocated channels + # future,fid,$fid List of futures a specific peer is waiting for. + # + # Channel instance variables: + # comm() + # $ch,port listening port (our id) + # $ch,socket listening socket + # $ch,socketcmd command to use to create sockets. + # $ch,silent boolean to indicate whether to throw error on + # protocol negotiation failure + # $ch,local boolean to indicate if port is local + # $ch,interp interpreter to run received scripts in. + # If not empty we own it! = We destroy it + # with the channel + # $ch,events List of hoks to run in the 'interp', if defined + # $ch,serial next serial number for commands + # + # $ch,hook,$hook script for hook $hook + # + # $ch,peers,$id open connections to peers; ch,id=>fid + # $ch,fids,$fid reverse mapping for peers; ch,fid=>id + # $ch,vers,$id negotiated protocol version for id + # $ch,pending,$id list of outstanding send serial numbers for id + # + # $ch,buf,$fid buffer to collect incoming data + # $ch,result,$serial result value set here to wake up sender + # $ch,return,$serial return codes to go along with result + + if {0} { + # Propagate result, code, and errorCode. Can't just eval + # otherwise TCL_BREAK gets turned into TCL_ERROR. + global errorInfo errorCode + set code [catch [concat commSend $args] res] + return -code $code -errorinfo $errorInfo -errorcode $errorCode $res + } +} + +namespace eval ::punk::icomm { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::icomm}] + #[para] Core API functions for punk::icomm + #[list_begin definitions] + + variable PUNKARGS + + # ::punk::icomm::comm_send -- + # + # Convenience command. Replaces Tk 'send' and 'winfo' with + # versions using the 'comm' variants. Multiple calls are + # allowed, only the first one will have an effect. + # + # Arguments: + # None. + # + # Results: + # None. + + proc comm_send {} { + proc send {args} { + # Use pure lists to speed this up. + uplevel 1 [linsert $args 0 ::punk::icomm::comm send] + } + rename winfo tk_winfo + proc winfo {cmd args} { + if {![string match in* $cmd]} { + # Use pure lists to speed this up ... + return [uplevel 1 [linsert $args 0 tk_winfo $cmd]] + } + return [::punk::icomm::comm interps] + } + proc ::punk::icomm::comm_send {} {} + } + + + + + #(Ensemble equivalent) + + # ::punk::icomm::comm -- + # + # See documentation for public methods of "comm". + # This procedure is followed by the definition of + # the public methods themselves. + # + # Arguments: + # cmd Invoked method + # args Arguments to method. + # + # Results: + # As of the invoked method. + + proc comm {cmd args} { + set method [info commands ::punk::icomm::comm_cmd_$cmd*] + + if {[llength $method] == 1} { + set chan ::punk::icomm::comm; # passed to methods + return [uplevel 1 [linsert $args 0 $method $chan]] + } else { + foreach c [info commands ::punk::icomm::comm_cmd_*] { + # remove ::comm::comm_cmd_ + #lappend cmds [string range $c 17 end] + lappend cmds [string range $c 24 end] + } + return -code error "unknown subcommand \"$cmd\":\ + must be one of [join [lsort $cmds] {, }]" + } + } + + + #ensemble members + proc comm_cmd_connect {chan args} { + uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan] + } + proc comm_cmd_self {chan args} { + variable comm + return $comm($chan,port) + } + proc comm_cmd_channels {chan args} { + variable comm + return $comm(chans) + } + proc comm_cmd_configure {chan args} { + uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0] + } + proc comm_cmd_ids {chan args} { + variable comm + set res $comm($chan,port) + foreach {i id} [array get comm $chan,fids,*] { + lappend res $id + } + return $res + } + proc comm_cmd_remoteid {chan args} { + variable comm + if {[info exists comm($chan,remoteid)]} { + set comm($chan,remoteid) + } else { + return -code error "No remote commands processed yet" + } + } + proc comm_cmd_debug {chan bool} { + variable comm + return [set comm(debug) [string is true -strict $bool]] + } + + + # ### ### ### ######### ######### ######### + ## API: Setup async result generation for a remotely invoked command. + + # (future,fid,) -> list (future) + # (current,async) -> bool (default 0) + # (current,state) -> list (chan fid cmd ser) + + proc comm_cmd_return_async {chan} { + variable comm + + if {![info exists comm(current,async)]} { + return -code error "No remote commands processed yet" + } + if {$comm(current,async)} { + # Return the same future which were generated by the first + # call. + return $comm(current,state) + } + + #foreach {cmdchan cmdfid cmd ser} $comm(current,state) break + lassign $comm(current,state) cmdchan cmdfid cmd ser + + # Assert that the channel performing the request and the channel + # the current command came in are identical. Panic if not. + + if {![string equal $chan $cmdchan]} { + return -code error "Internal error: Trying to activate\ + async return for a command on a different channel" + } + + # Establish the future for the command and return a handle for + # it. Remember the outstanding futures for a peer, so that we can + # cancel them if the peer is lost before the promise implicit in + # the future is redeemed. + + set future [::punk::icomm::future %AUTO% $chan $cmdfid $cmd $ser] + + lappend comm(future,fid,$cmdfid) $future + set comm(current,state) $future + + # Mark the current command as using async result return. We do + # this last to ensure that all errors in this method are reported + # through the regular channels. + + set comm(current,async) 1 + + return $future + } + # hook -- + # + # Internal command. Implements 'comm hook'. + # + # Arguments: + # hook hook to modify + # script Script to add/remove to/from the hook + # + # Results: + # None. + # + proc comm_cmd_hook {chan hook {script +}} { + variable comm + if {![info exists comm($hook,hook)]} { + return -code error "Unknown hook invoked" + } + if {!$comm($hook,hook)} { + return -code error "Unimplemented hook invoked" + } + if {[string equal + $script]} { + if {[catch {set comm($chan,hook,$hook)} ret]} { + return + } + return $ret + } + if {[string match +* $script]} { + append comm($chan,hook,$hook) \n [string range $script 1 end] + } else { + set comm($chan,hook,$hook) $script + } + return + } + + # abort -- + # + # Close down all peer connections. + # Implements the 'comm abort' method. + # + # Arguments: + # None. + # + # Results: + # None. + + proc comm_cmd_abort {chan} { + variable comm + + foreach pid [array names comm $chan,peers,*] { + commLostConn $chan $comm($pid) "Connection aborted by request" + } + } + + # destroy -- + # + # Destroy the channel invoking it. + # Implements the 'comm destroy' method. + # + # Arguments: + # None. + # + # Results: + # None. + # + proc comm_cmd_destroy {chan} { + variable comm + catch {close $comm($chan,socket)} + comm_cmd_abort $chan + if {$comm($chan,interp) != {}} { + interp delete $comm($chan,interp) + } + array unset comm $chan,* + + #catch {unset comm($chan,port)} + #catch {unset comm($chan,local)} + #catch {unset comm($chan,silent)} + #catch {unset comm($chan,interp)} + #catch {unset comm($chan,events)} + #catch {unset comm($chan,socket)} + #catch {unset comm($chan,socketcmd)} + #catch {unset comm($chan,remoteid)} + #unset comm($chan,serial) + #unset comm($chan,chan) + #unset comm($chan,encoding) + #unset comm($chan,listen) + ## array unset would have been nicer, but is not available in + ## 8.2/8.3 + #foreach pattern {hook,* interp,* vers,*} { + # array unset comm $chan,$pattern + # #foreach k [array names comm $chan,$pattern] { + # # unset comm($k) + # #} + #} + set pos [lsearch -exact $comm(chans) $chan] + set comm(chans) [lreplace $comm(chans) $pos $pos] + if { + ![string equal ::punk::icomm::comm $chan] && + ![string equal [info proc $chan] ""] + } { + rename $chan {} + } + return + } + + # shutdown -- + # + # Close down a peer connection. + # Implements the 'comm shutdown' method. + # + # Arguments: + # id Reference to the remote interp + # + # Results: + # None. + # + proc comm_cmd_shutdown {chan id} { + variable comm + + if {[info exists comm($chan,peers,$id)]} { + commLostConn $chan $comm($chan,peers,$id) \ + "Connection shutdown by request" + } + } + + # new -- + # + # Create a new comm channel/instance. + # Implements the 'comm new' method. + # + # Arguments: + # newchan Name of the new channel + # args Configuration, in the form of -option value pairs. + # + # Results: + # None. + # + proc comm_cmd_new {_irrelevant_chan newchan args} { + variable comm + + if {[lsearch -exact $comm(chans) $newchan] >= 0} { + return -code error "Already existing channel: $newchan" + } + if {([llength $args] % 2) != 0} { + return -code error "Must have an even number of config arguments" + } + # ensure that the new channel name is fully qualified + set newchan ::[string trimleft $newchan :] + if {[string equal ::punk::icomm::comm $newchan]} { + # allow comm to be recreated after destroy + } elseif {[string equal $newchan [info commands $newchan]]} { + return -code error "Already existing command: $newchan" + } else { + # Create the new channel with fully qualified proc name + proc $newchan {cmd args} { + set method [info commands ::punk::icomm::comm_cmd_$cmd*] + + if {[llength $method] == 1} { + # this should work right even if aliased + # it is passed to methods to identify itself + set chan [namespace origin [lindex [info level 0] 0]] + return [uplevel 1 [linsert $args 0 $method $chan]] + } else { + foreach c [info commands ::punk::icomm::comm_cmd_*] { + # remove ::comm::comm_cmd_ + #lappend cmds [string range $c 17 end] + lappend cmds [string range $c 24 end] + } + return -code error "unknown subcommand \"$cmd\":\ + must be one of [join [lsort $cmds] {, }]" + } + } + } + lappend comm(chans) $newchan + set chan $newchan + set comm($chan,serial) 0 + set comm($chan,chan) $chan + set comm($chan,tclchan) "" + set comm($chan,port) 0 + set comm($chan,listen) 0 + set comm($chan,socket) "" + set comm($chan,local) 1 + set comm($chan,silent) $comm(defaultSilent) + set comm($chan,encoding) $comm(defaultEncoding) + set comm($chan,interp) {} + set comm($chan,events) {} + set comm($chan,socketcmd) ::socket + + if {[llength $args] > 0} { + if {[catch [linsert $args 0 commConfigure $chan 1] err]} { + comm_cmd_destroy $chan + return -code error $err + } + } + return $chan + } + + # send -- + # + # Send command to a specified channel. + # Implements the 'comm send' method. + # + # Arguments: + # args see inside + # + # Results: + # varies. + # + proc comm_cmd_send {chan args} { + variable comm + + set cmd send + + # args = ?-async | -command command? id cmd ?arg arg ...? + set i 0 + set opt [lindex $args $i] + if {[string equal -async $opt]} { + set cmd async + incr i + } elseif {[string equal -command $opt]} { + set cmd command + set callback [lindex $args [incr i]] + incr i + } + # args = id cmd ?arg arg ...? + + set id [lindex $args $i] + incr i + set args [lrange $args $i end] + + if {![info complete $args]} { + return -code error "Incomplete command" + } + if {![llength $args]} { + return -code error \ + "wrong # args: should be \"send ?-async? id arg ?arg ...?\"" + } + if {[catch {commConnect $chan $id} fid]} { + return -code error "Connect to remote failed: $fid" + } + + set ser [incr comm($chan,serial)] + # This is unneeded - wraps from 2147483647 to -2147483648 + ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0} + + commDebug {puts stderr "<$chan> send <[list [list $cmd $ser $args]]>"} + + # The double list assures that the command is a single list when read. + puts $fid [list [list $cmd $ser $args]] + flush $fid + + commDebug {puts stderr "<$chan> sent"} + + # wait for reply if so requested + + if {[string equal command $cmd]} { + # In this case, don't wait on the command result. Set the callback + # in the return and that will be invoked by the result. + lappend comm($chan,pending,$id) [list $ser callback] + set comm($chan,return,$ser) $callback + return $ser + } elseif {[string equal send $cmd]} { + upvar 0 comm($chan,pending,$id) pending ;# shorter variable name + + lappend pending $ser + set comm($chan,return,$ser) "" ;# we're waiting + + commDebug {puts stderr "<$chan> --<>--"} + vwait ::punk::icomm::comm($chan,result,$ser) + + # if connection was lost, pending is gone + if {[info exists pending]} { + set pos [lsearch -exact $pending $ser] + set pending [lreplace $pending $pos $pos] + } + + commDebug { + puts stderr "<$chan> result\ + <$comm($chan,return,$ser);$comm($chan,result,$ser)>" + } + + array set return $comm($chan,return,$ser) + unset comm($chan,return,$ser) + set thisres $comm($chan,result,$ser) + unset comm($chan,result,$ser) + switch -- $return(-code) { + "" - 0 {return $thisres} + 1 { + return -code $return(-code) \ + -errorinfo $return(-errorinfo) \ + -errorcode $return(-errorcode) \ + $thisres + } + default {return -code $return(-code) $thisres} + } + } + } + + ############################################################################### + + # ::punk::icomm::commDebug -- + # + # Internal command. Conditionally executes debugging + # statements. Currently this are only puts commands logging the + # various interactions. These could be replaced with calls into + # the 'log' module. + # + # Arguments: + # arg Tcl script to execute. + # + # Results: + # None. + + proc commDebug {cmd} { + variable comm + if {$comm(debug)} { + uplevel 1 $cmd + } + } + + # ::punk::icomm::commConfVars -- + # + # Internal command. Used to declare configuration options. + # + # Arguments: + # v Name of configuration option. + # t Default value. + # + # Results: + # None. + + proc commConfVars {v t} { + variable comm + set comm($v,var) $t + set comm(vars) {} + foreach c [array names comm *,var] { + lappend comm(vars) [lindex [split $c ,] 0] + } + return + } + commConfVars port p + commConfVars local b + commConfVars listen b + commConfVars socket ro + commConfVars socketcmd socketcmd + commConfVars chan ro + commConfVars serial ro + commConfVars encoding enc + commConfVars silent b + commConfVars interp interp + commConfVars events ev + commConfVars tclchan tclchan + + # ::punk::icomm::commConfigure -- + # + # Internal command. Implements 'comm configure'. + # + # Arguments: + # force Boolean flag. If set the socket is reinitialized. + # args New configuration, as -option value pairs. + # + # Results: + # None. + + proc commConfigure {chan {force 0} args} { + variable comm + + # query + if {[llength $args] == 0} { + foreach v $comm(vars) { + lappend res -$v $comm($chan,$v) + } + return $res + } elseif {[llength $args] == 1} { + set arg [lindex $args 0] + set var [string range $arg 1 end] + if {![string match -* $arg] || ![info exists comm($var,var)]} { + return -code error "Unknown configuration option: $arg" + } + return $comm($chan,$var) + } + + # set + set opt 0 + foreach arg $args { + incr opt + if {[info exists skip]} {unset skip; continue} + set var [string range $arg 1 end] + if {![string match -* $arg] || ![info exists comm($var,var)]} { + return -code error "Unknown configuration option: $arg" + } + set optval [lindex $args $opt] + switch $comm($var,var) { + ev { + if {![string equal $optval ""]} { + set err 0 + if {[catch { + foreach ev $optval { + if {[lsearch -exact {connecting connected incoming eval callback reply lost} $ev] < 0} { + set err 1 + break + } + } + }]} { + set err 1 + } + if {$err} { + return -code error \ + "Non-event to configuration option: -$var" + } + } + # FRINK: nocheck + set $var $optval + set skip 1 + } + interp { + if { + ![string equal $optval ""] && + ![interp exists $optval] + } { + return -code error \ + "Non-interpreter to configuration option: -$var" + } + # FRINK: nocheck + set $var $optval + set skip 1 + } + b { + # FRINK: nocheck + set $var [string is true -strict $optval] + set skip 1 + } + v { + # FRINK: nocheck + set $var $optval + set skip 1 + } + p { + ##nagelfar ignore + if {![string is integer -strict $optval]} { + return -code error \ + "Non-port to configuration option: -$var" + } + # FRINK: nocheck + set $var [format %d $optval] + set skip 1 + } + i { + ##nagelfar ignore + if {![string is integer $optval]} { + return -code error \ + "Non-integer to configuration option: -$var" + } + # FRINK: nocheck + set $var [format %d $optval] + set skip 1 + } + enc { + # to configure encodings, we will need to extend the + # protocol to allow for handshaked encoding changes + return -code error "encoding not configurable" + if {[lsearch -exact [encoding names] $optval] == -1} { + return -code error \ + "Unknown encoding to configuration option: -$var" + } + set $var $optval + set skip 1 + } + ro { + return -code error "Readonly configuration option: -$var" + } + socketcmd { + if {$optval eq {}} { + return -code error \ + "Non-command to configuration option: -$var" + } + + set $var $optval + set skip 1 + } + tclchan { + #test existence of channel - don't use existence in [chan names] - could be a wrapped channel + if {[catch {chan configure $optval} errM]} { + return -code error \ + "Cannot verify existence of Tcl channel supplied to configuration option: -$var" + } + set $var $optval + set skip 1 + } + } + } + if {[info exists skip]} { + return -code error "Missing value for option: $arg" + } + + foreach var {port listen local socketcmd tclchan} { + # FRINK: nocheck + if {[info exists $var] && [set $var] != $comm($chan,$var)} { + incr force + # FRINK: nocheck + set comm($chan,$var) [set $var] + } + } + + foreach var {silent interp events} { + # FRINK: nocheck + if {[info exists $var] && ([set $var] != $comm($chan,$var))} { + # FRINK: nocheck + set comm($chan,$var) [set ip [set $var]] + if {[string equal $var "interp"] && ($ip != "")} { + # Interrogate the interp about its capabilities. + # + # Like: set, array set, uplevel present ? + # Or: The above, hidden ? + # + # This is needed to decide how to execute hook scripts + # and regular scripts in this interpreter. + set comm($chan,interp,set) [Capability $ip set] + set comm($chan,interp,aset) [Capability $ip array] + set comm($chan,interp,upl) [Capability $ip uplevel] + } + } + } + + if {[info exists encoding] && + ![string equal $encoding $comm($chan,encoding)]} { + # This should not be entered yet + set comm($chan,encoding) $encoding + fconfigure $comm($chan,socket) -encoding $encoding + foreach {i sock} [array get comm $chan,peers,*] { + fconfigure $sock -encoding $encoding + } + } + + # do not re-init socket + if {!$force} {return ""} + + #experimental e.g fifo2 + #------------------------- + if {[info exists comm($chan,tclchan)] && $comm($chan,tclchan) ne "" && $comm($chan,listen)} { + #treat as always connected - call commIncoming imediately. + punk::icomm::commIncoming $chan $comm($chan,tclchan) "localaddr" "localtclchan" + return + } + + #------------------------- + + # User is recycling object, possibly to change from local to !local + if {[info exists comm($chan,socket)]} { + comm_cmd_abort $chan + catch {close $comm($chan,socket)} + unset comm($chan,socket) + } + + set comm($chan,socket) "" + if {!$comm($chan,listen)} { + set comm($chan,port) 0 + return "" + } + + if {[info exists port] && [string equal "" $comm($chan,port)]} { + set nport [incr comm(lastport)] + } else { + set userport 1 + set nport $comm($chan,port) + } + while {1} { + set cmd [list $comm($chan,socketcmd) -server [list ::punk::icomm::commIncoming $chan]] + if {$comm($chan,local)} { + lappend cmd -myaddr $comm(localhost) + } + lappend cmd $nport + if {![catch $cmd ret]} { + break + } + if {[info exists userport] || ![string match "*already in use" $ret]} { + # don't eradicate the class + if { + ![string equal ::punk::icomm::comm $chan] && + ![string equal [info proc $chan] ""] + } { + rename $chan {} + } + return -code error $ret + } + set nport [incr comm(lastport)] + } + set comm($chan,socket) $ret + fconfigure $ret -translation lf -encoding $comm($chan,encoding) + + # If port was 0, system allocated it for us + set comm($chan,port) [lindex [fconfigure $ret -sockname] 2] + return "" + } + + # ::punk::icomm::Capability -- + # + # Internal command. Interogate an interp for + # the commands needed to execute regular and + # hook scripts. + + proc Capability {interp cmd} { + if {[lsearch -exact [interp hidden $interp] $cmd] >= 0} { + # The command is present, although hidden. + return hidden + } + + # The command is not a hidden command. Use info to determine if it + # is present as regular command. Note that the 'info' command + # itself might be hidden. + + if {[catch { + set has [llength [interp eval $interp [list info commands $cmd]]] + }] && [catch { + set has [llength [interp invokehidden $interp info commands $cmd]] + }]} { + # Unable to interogate the interpreter in any way. Assume that + # the command is not present. + set has 0 + } + return [expr {$has ? "ok" : "no"}] + } + + # punk::icomm::commConnect -- + # + # Internal command. Called to connect to a remote interp + # + # Arguments: + # id Specification of the location of the remote interp. + # A list containing either one or two elements. + # One element = port, host is localhost. + # Two elements = port and host, in this order. + # + # Results: + # fid channel handle of the socket the connection goes through. + + proc commConnect {chan id} { + variable comm + + commDebug {puts stderr "<$chan> commConnect $id"} + + # process connecting hook now + CommRunHook $chan connecting + + if {[info exists comm($chan,peers,$id)]} { + return $comm($chan,peers,$id) + } + if {[lindex $id 0] == 0} { + return -code error "Remote comm is anonymous; cannot connect" + } + + # experimental + # ----------------------------------------------------------- + if {[llength $id] == 2 && [lindex $id 0] eq "tclchan"} { + set fid [lindex $id 1] + if {[catch {chan configure $fid} errMsg]} { + error $errMsg $::errorInfo + } + + # process connected hook now + if {[catch { + CommRunHook $chan connected + } err]} { + global errorInfo + set ei $errorInfo + close $fid + error $err $ei + } + # commit new connection + commNewConn $chan $id $fid + # send offered protocols versions and id to identify ourselves to remote + #puts $fid [list $comm(offerVers) $comm($chan,port)] + puts $fid [list $comm(offerVers) $fid] ;#all we have to offer is our end of the pipe as an id? + set comm($chan,vers,$id) $comm(defVers) ;# default proto vers + flush $fid + return $fid + } + # ----------------------------------------------------------- + + + if {[llength $id] > 1} { + set host [lindex $id 1] + } else { + set host $comm(localhost) + } + set port [lindex $id 0] + set fid [$comm($chan,socketcmd) $host $port] + + # process connected hook now + if {[catch { + CommRunHook $chan connected + } err]} { + global errorInfo + set ei $errorInfo + close $fid + error $err $ei + } + + # commit new connection + commNewConn $chan $id $fid + + # send offered protocols versions and id to identify ourselves to remote + puts $fid [list $comm(offerVers) $comm($chan,port)] + set comm($chan,vers,$id) $comm(defVers) ;# default proto vers + flush $fid + return $fid + } + + # ::punk::icomm::commIncoming -- + # + # Internal command. Called for an incoming new connection. + # Handles connection setup and initialization. + # + # Arguments: + # chan logical channel handling the connection. + # fid channel handle of the socket running the connection. + # addr ip address of the socket channel 'fid' + # remport remote port for the socket channel 'fid' + # + # Results: + # None. + + proc commIncoming {chan fid addr remport} { + variable comm + + commDebug {puts stderr "<$chan> commIncoming $fid $addr $remport"} + + # process incoming hook now + if {[catch { + CommRunHook $chan incoming + } err]} { + global errorInfo + set ei $errorInfo + close $fid + error $err $ei + } + + # Wait for offered version, without blocking the entire system. + # Bug 3066872. For a Tcl 8.6 implementation consider use of + # coroutines to hide the CSP and properly handle everything + # event based. + + fconfigure $fid -blocking 0 + fileevent $fid readable [list ::punk::icomm::commIncomingOffered $chan $fid $addr $remport] + return + } + + proc commIncomingOffered {chan fid addr remport} { + variable comm + + # Check if we have a complete line. + if {[gets $fid protoline] < 0} { + #commDebug {puts stderr "commIncomingOffered: no data"} + if {[eof $fid]} { + commDebug {puts stderr "commIncomingOffered: eof on fid=$fid"} + catch { + close $fid + } + } + return + } + + # Protocol version line has been received, disable event handling + # again. + fileevent $fid readable {} + fconfigure $fid -blocking 1 + + # a list of offered proto versions is the first word of first line + # remote id is the second word of first line + # rest of first line is ignored + + set offeredvers [lindex $protoline 0] + set remid [lindex $protoline 1] + + commDebug {puts stderr "<$chan> offered <$protoline>"} + + # use the first supported version in the offered list + foreach v $offeredvers { + if {[info exists comm($v,vers)]} { + set vers $v + break + } + } + if {![info exists vers]} { + close $fid + if {[info exists comm($chan,silent)] && + [string is true -strict $comm($chan,silent)]} { + return + } + error "Unknown offered protocols \"$protoline\" from $addr/$remport" + } + + set chanconf [chan configure $fid] + if {[dict exists $chanconf -sockname]} { + # If the remote host addr isn't our local host addr, + # then add it to the remote id. + if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} { + set id $remid + } else { + set id [list $remid $addr] + } + } else { + #tclchan? + set id $fid + + } + + # Detect race condition of two comms connecting to each other + # simultaneously. It is OK when we are talking to ourselves. + + if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} { + + puts stderr "commIncoming race condition: $id" + puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)" + + # To avoid the race, we really want to terminate one connection. + # However, both sides are committed to using it. + # commConnect needs to be synchronous and detect the close. + # close $fid + # return $comm($chan,peers,$id) + } + + # Make a protocol response. Avoid any temptation to use {$vers > 2} + # - this forces forwards compatibility issues on protocol versions + # that haven't been invented yet. DON'T DO IT! Instead, test for + # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK. + + switch $vers { + 3 { + # Respond with the selected version number + puts $fid [list [list vers $vers]] + flush $fid + } + } + + # commit new connection + commNewConn $chan $id $fid + set comm($chan,vers,$id) $vers + } + + # ::punk::icomm::commNewConn -- + # + # Internal command. Common new connection processing + # + # Arguments: + # id Reference to the remote interp + # fid channel handle of the socket running the connection. + # + # Results: + # None. + + proc commNewConn {chan id fid} { + variable comm + + commDebug {puts stderr "<$chan> commNewConn $id $fid"} + + # There can be a race condition two where comms connect to each other + # simultaneously. This code favors our outgoing connection. + + if {[info exists comm($chan,peers,$id)]} { + # abort this connection, use the existing one + # close $fid + # return -code return $comm($chan,peers,$id) + } else { + set comm($chan,pending,$id) {} + set comm($chan,peers,$id) $fid + } + set comm($chan,fids,$fid) $id + fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 + fileevent $fid readable [list ::punk::icomm::commCollect $chan $fid] + } + + # ::punk::icomm::commLostConn -- + # + # Internal command. Called to tidy up a lost connection, + # including aborting ongoing sends. Each send should clean + # themselves up in pending/result. + # + # Arguments: + # fid Channel handle of the socket which got lost. + # reason Message describing the reason of the loss. + # + # Results: + # reason + + proc commLostConn {chan fid reason} { + variable comm + + commDebug {puts stderr "<$chan> commLostConn $fid $reason"} + + catch {close $fid} + + set id $comm($chan,fids,$fid) + + # Invoke the callbacks of all commands which have such and are + # still waiting for a response from the lost peer. Use an + # appropriate error. + + foreach s $comm($chan,pending,$id) { + if {[string equal "callback" [lindex $s end]]} { + set ser [lindex $s 0] + if {[info exists comm($chan,return,$ser)]} { + set args [list -id $id \ + -serial $ser \ + -chan $chan \ + -code -1 \ + -errorcode NONE \ + -errorinfo "" \ + -result $reason \ + ] + if {[catch {uplevel \#0 $comm($chan,return,$ser) $args} err]} { + commBgerror $err + } + } + } else { + set comm($chan,return,$s) {-code error} + set comm($chan,result,$s) $reason + } + } + unset comm($chan,pending,$id) + unset comm($chan,fids,$fid) + catch {unset comm($chan,peers,$id)} ;# race condition + catch {unset comm($chan,buf,$fid)} + + # Cancel all outstanding futures for requests which were made by + # the lost peer, if there are any. This does not destroy + # them. They will stay around until the long-running operations + # they belong too kill them. + + CancelFutures $fid + + # process lost hook now + catch {CommRunHook $chan lost} + + return $reason + } + + proc commBgerror {err} { + # SF Tcllib Patch #526499 + # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883 + # for initial request and comments) + # + # Error in async call. Look for [bgerror] to report it. Same + # logic as in Tcl itself. Errors thrown by bgerror itself get + # reported to stderr. + if {[catch {bgerror $err} msg]} { + puts stderr "bgerror failed to handle background error." + puts stderr " Original error: $err" + puts stderr " Error in bgerror: $msg" + flush stderr + } + } + + # CancelFutures: Mark futures associated with a comm channel as + # expired, done when the connection to the peer has been lost. The + # marked futures will not generate result anymore. They will also stay + # around until destroyed by the script they belong to. + + proc CancelFutures {fid} { + variable comm + if {![info exists comm(future,fid,$fid)]} return + + commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \ + "\n\t : "]"} + + foreach future $comm(future,fid,$fid) { + $future Cancel + } + + unset comm(future,fid,$fid) + return + } + + ############################################################################### + + # ::punk::icomm::commCollect -- + # + # Internal command. Called from the fileevent to read from fid + # and append to the buffer. This continues until we get a whole + # command, which we then invoke. + # + # Arguments: + # chan logical channel collecting the data + # fid channel handle of the socket we collect. + # + # Results: + # None. + + proc commCollect {chan fid} { + variable comm + upvar #0 comm($chan,buf,$fid) data + + # Tcl8 may return an error on read after a close + if {[catch {read $fid} nbuf] || [eof $fid]} { + commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"} + commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"} + commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"} + + fileevent $fid readable {} ;# be safe + commLostConn $chan $fid "target application died or connection lost" + return + } + append data $nbuf + + commDebug {puts stderr "<$chan> collect <$data>"} + + # If data contains at least one complete command, we will + # be able to take off the first element, which is a list holding + # the command. This is true even if data isn't a well-formed + # list overall, with unmatched open braces. This works because + # each command in the protocol ends with a newline, thus allowing + # lindex and lreplace to work. + # + # This isn't true with Tcl8.0, which will return an error until + # the whole buffer is a valid list. This is probably OK, although + # it could potentially cause a deadlock. + + # [AK] Actually no. This breaks down if the sender shoves so much + # data at us so fast that the receiver runs into out of memory + # before the list is fully well-formed and thus able to be + # processed. + + + while {![catch { + set cmdrange [Word0 data] + # word0 is essentially the pre-8.0 'lindex 0', getting + # the first word of a list, even if the remainder is not fully + # well-formed. Slight API change, we get the char indices the + # word is between, and a relative index to the remainder of + # the list. + }]} { + # Unpack the indices, then extract the word. + #foreach {s e step} $cmdrange break + lassign $cmdrange s e step + + set cmd [string range $data $s $e] + commDebug {puts stderr "<$chan> cmd <$data>"} + if {[string equal "" $cmd]} break + if {[info complete $cmd]} { + # The word is a command, step to the remainder of the + # list, and delete the word we have processed. + incr e $step + set data [string range $data $e end] + after idle \ + [list ::punk::icomm::commExec $chan $fid $comm($chan,fids,$fid) $cmd] + } + } + } + + # ::punk::icomm::commExec -- + # + # Internal command. Receives and executes a remote command, + # returning the result and/or error. Unknown protocol commands + # are silently discarded + # + # Arguments: + # chan logical channel collecting the data + # fid channel handle of the socket we collect. + # remoteid id of the other side. + # buf buffer containing the command to execute. + # + # Results: + # None. + + proc commExec {chan fid remoteid buf} { + variable comm + + # buffer should contain: + # send # {cmd} execute cmd and send reply with serial # + # async # {cmd} execute cmd but send no reply + # reply # {cmd} execute cmd as reply to serial # + + # these variables are documented in the hook interface + set cmd [lindex $buf 0] + set ser [lindex $buf 1] + set buf [lrange $buf 2 end] + set buffer [lindex $buf 0] + + # Save remoteid for "comm remoteid". This will only be valid + # if retrieved before any additional events occur on this channel. + # N.B. we could have already lost the connection to remote, making + # this id be purely informational! + set comm($chan,remoteid) [set id $remoteid] + + # Save state for possible async result generation + AsyncPrepare $chan $fid $cmd $ser + + commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"} + + switch -- $cmd { + send - async - command {} + callback { + if {![info exists comm($chan,return,$ser)]} { + commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} + return + } + + # Decompose reply command to assure it only uses "return" + # with no side effects. + + array set return {-code "" -errorinfo "" -errorcode "" } + set ret [lindex $buffer end] + set len [llength $buffer] + incr len -2 + foreach {sw val} [lrange $buffer 1 $len] { + if {![info exists return($sw)]} {continue} + set return($sw) $val + } + + catch {CommRunHook $chan callback} + + # this wakes up the sender + commDebug {puts stderr "<$chan> --<>--"} + + # the return holds the callback command + # string map the optional %-subs + set args [list -id $id \ + -serial $ser \ + -chan $chan \ + -code $return(-code) \ + -errorcode $return(-errorcode) \ + -errorinfo $return(-errorinfo) \ + -result $ret \ + ] + set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err] + catch { + unset comm($chan,return,$ser) + } + + # remove pending serial + upvar 0 comm($chan,pending,$id) pending + if {[info exists pending]} { + set pos [lsearch -exact $pending [list $ser callback]] + if {$pos != -1} { + set pending [lreplace $pending $pos $pos] + } + } + if {$code} { + commBgerror $err + } + return + } + reply { + if {![info exists comm($chan,return,$ser)]} { + commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} + return + } + + # Decompose reply command to assure it only uses "return" + # with no side effects. + + array set return {-code "" -errorinfo "" -errorcode "" } + set ret [lindex $buffer end] + set len [llength $buffer] + incr len -2 + foreach {sw val} [lrange $buffer 1 $len] { + if {![info exists return($sw)]} continue + set return($sw) $val + } + + catch {CommRunHook $chan reply} + + # this wakes up the sender + commDebug {puts stderr "<$chan> --<>--"} + set comm($chan,result,$ser) $ret + set comm($chan,return,$ser) [array get return] + return + } + vers { + set comm($chan,vers,$id) $ser + return + } + default { + commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""} + return + } + } + + # process eval hook now + set done 0 + set err 0 + if {[info exists comm($chan,hook,eval)]} { + set err [catch {CommRunHook $chan eval} ret] + commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"} + switch $err { + 1 { + # error + set done 1 + } + 2 - 3 { + # return / break + set err 0 + set done 1 + } + } + } + + commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"} + + # exec command + if {!$done} { + commDebug {puts stderr "<$chan> exec ($buffer)"} + + # Sadly, the uplevel needs to be in the catch to access the local + # variables buffer and ret. These cannot simply be global because + # commExec is reentrant (i.e., they could be linked to an allocated + # serial number). + + if {$comm($chan,interp) == {}} { + # Main interpreter + set thecmd [concat [list uplevel \#0] $buffer] + set err [catch $thecmd ret] + } else { + # Redirect execution into the configured slave + # interpreter. The exact command used depends on the + # capabilities of the interpreter. A best effort is made + # to execute the script in the global namespace. + set interp $comm($chan,interp) + + if {$comm($chan,interp,upl) == "ok"} { + set thecmd [concat [list uplevel \#0] $buffer] + set err [catch {interp eval $interp $thecmd} ret] + } elseif {$comm($chan,interp,aset) == "hidden"} { + set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0] + set err [catch $thecmd ret] + } else { + set thecmd [concat [list interp eval $interp] $buffer] + set err [catch $thecmd ret] + } + } + } + + # Check and handle possible async result generation. + if {[AsyncCheck]} {return} + + commSendReply $chan $fid $cmd $ser $err $ret + return + } + + # ::punk::icomm::commSendReply -- + # + # Internal command. Executed to construct and send the reply + # for a command. + # + # Arguments: + # fid channel handle of the socket we are replying to. + # cmd The type of request (send, command) we are replying to. + # ser Serial number of the request the reply is for. + # err result code to place into the reply. + # ret result value to place into the reply. + # + # Results: + # None. + + proc commSendReply {chan fid cmd ser err ret} { + variable comm + + commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"} + + # The double list assures that the command is a single list when read. + if {[string equal send $cmd] || [string equal command $cmd]} { + # The catch here is just in case we lose the target. Consider: + # comm send $other comm send [comm self] exit + catch { + set return [list return -code $err] + # send error or result + if {$err == 1} { + global errorInfo errorCode + lappend return -errorinfo $errorInfo -errorcode $errorCode + } + lappend return $ret + if {[string equal send $cmd]} { + set reply reply + } else { + set reply callback + } + puts $fid [list [list $reply $ser $return]] + flush $fid + } + commDebug {puts stderr "<$chan> reply sent"} + } + + if {$err == 1} { + commBgerror $ret + } + commDebug {puts stderr "<$chan> exec complete"} + return + } + + proc CommRunHook {chan event} { + variable comm + + # The documentation promises the hook scripts to have access to a + # number of internal variables. For a regular hook we simply + # execute it in the calling level to fulfill this. When the hook + # is redirected into an interpreter however we do a best-effort + # copying of the variable values into the interpreter. Best-effort + # because the 'set' command may not be available in the + # interpreter, not even hidden. + + if {![info exists comm($chan,hook,$event)]} return + set cmd $comm($chan,hook,$event) + set interp $comm($chan,interp) + commDebug {puts stderr "<$chan> hook($event) run <$cmd>"} + + if { + ($interp != {}) && + ([lsearch -exact $comm($chan,events) $event] >= 0) + } { + # Best-effort to copy the context into the interpreter for + # access by the hook script. + set vars { + addr buffer chan cmd fid host + id port reason remport ret var + } + + if {$comm($chan,interp,set) == "ok"} { + foreach v $vars { + upvar 1 $v V + if {![info exists V]} continue + interp eval $interp [list set $v $V] + } + } elseif {$comm($chan,interp,set) == "hidden"} { + foreach v $vars { + upvar 1 $v V + if {![info exists V]} continue + interp invokehidden $interp set $v $V + } + } + upvar 1 return AV + if {[info exists AV]} { + if {$comm($chan,interp,aset) == "ok"} { + interp eval $interp [list array set return [array get AV]] + } elseif {$comm($chan,interp,aset) == "hidden"} { + interp invokehidden $interp array set return [array get AV] + } + } + + commDebug {puts stderr "<$chan> /interp $interp"} + set code [catch {interp eval $interp $cmd} res options] + } else { + commDebug {puts stderr "<$chan> /main"} + set code [catch {uplevel 1 $cmd} res options] + } + + # Perform the return code propagation promised + # to the hook scripts. + return -options $options -code $code $res + } + + # ### ### ### ######### ######### ######### + ## Hooks to link async return and future processing into the regular + ## system. + + # AsyncPrepare, AsyncCheck: Initialize state information for async + # return upon start of a remote invokation, and checking the state for + # async return. + + proc AsyncPrepare {chan fid cmd ser} { + variable comm + set comm(current,async) 0 + set comm(current,state) [list $chan $fid $cmd $ser] + return + } + + proc AsyncCheck {} { + # Check if the executed command notified us of an async return. If + # not we let the regular return processing handle the end of the + # script. Otherwise we stop the caller from proceeding, preventing + # a regular return. + + variable comm + if {!$comm(current,async)} {return 0} + return 1 + } + + # FutureDone: Action taken by an uncanceled future to deliver the + # generated result to the proper invoker. This also removes the future + # from the list of pending futures for the comm channel. + + proc FutureDone {future chan fid cmd sid rcode rvalue} { + variable comm + commSendReply $chan $fid $cmd $sid $rcode $rvalue + + set pos [lsearch -exact $comm(future,fid,$fid) $future] + set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos] + return + } + + # ### ### ### ######### ######### ######### + ## Hooks to save command state across nested eventloops a remotely + ## invoked command may run before finally activating async result + ## generation. + + # DANGER !! We have to refer to comm internals using fully-qualified + # names because the wrappers will execute in the global namespace + # after their installation. + + proc Vwait {varname} { + variable ::punk::icomm::comm + + set hasstate [info exists comm(current,async)] + set hasremote 0 + if {$hasstate} { + set chan [lindex $comm(current,state) 0] + set async $comm(current,async) + set state $comm(current,state) + set hasremote [info exists comm($chan,remoteid)] + if {$hasremote} { + set remoteid $comm($chan,remoteid) + } + } + + set code [catch {uplevel 1 [list ::punk::icomm::VwaitOrig $varname]} res] + + if {$hasstate} { + set comm(current,async) $async + set comm(current,state) $state + } + if {$hasremote} { + set comm($chan,remoteid) $remoteid + } + + return -code $code $res + } + + proc Update {args} { + variable ::punk::icomm::comm + + set hasstate [info exists comm(current,async)] + set hasremote 0 + if {$hasstate} { + set chan [lindex $comm(current,state) 0] + set async $comm(current,async) + set state $comm(current,state) + + set hasremote [info exists comm($chan,remoteid)] + if {$hasremote} { + set remoteid $comm($chan,remoteid) + } + } + + set code [catch {uplevel 1 [linsert $args 0 ::punk::icomm::UpdateOrig]} res] + + if {$hasstate} { + set comm(current,async) $async + set comm(current,state) $state + } + if {$hasremote} { + set comm($chan,remoteid) $remoteid + } + + return -code $code $res + } + + # Install the wrappers. + + proc InitWrappers {} { + rename ::vwait ::punk::icomm::VwaitOrig + rename ::punk::icomm::Vwait ::vwait + + rename ::update ::punk::icomm::UpdateOrig + rename ::punk::icomm::Update ::update + + proc ::punk::icomm::InitWrappers {} {} + return + } + + proc Word0 {dv} { + upvar 1 $dv data + + # data + # + # The string we expect to be either a full well-formed list, or a + # well-formed list until the end of the first word in the list, + # with non-wellformed data following after, i.e. an incomplete + # list with a complete first word. + + set re "^\\s*(\{)" ;#\} + if {[regexp -indices $re $data -> bracerange]} { + # The word is brace-quoted, starting at index 'lindex + # bracerange 0'. We now have to find the closing brace, + # counting inner braces, ignoring quoted braces. We fail if + # there is no proper closing brace. + + lassign $bracerange s e + incr s ; # index of the first char after the brace. + incr e ; # same. but this is our running index. + + set level 1 + set max [string length $data] + + while {$level} { + # We are looking for the first regular or backslash-quoted + # opening or closing brace in the string. If none is found + # then the word is not complete, and we abort our search. + + # \{Bug 2972571: To avoid the bogus detection of + # backslash-quoted braces we look for double-backslashes + # as well and skip them. Without this a string like '{puts + # \\}' will incorrectly find a \} at the end, missing the + # end of the word. + set re {((\\\\)|([{}])|(\\[{}]))} ;#split out for dumb editor to fix highlighting + # ^^ ^ ^ + # |\\ regular \quoted + # any + + if {![regexp -indices -start $e $re $data -> any dbs regular quoted]} { + return -code error "no complete word found/1" + } + # + lassign $dbs ds de + lassign $quoted qs qe + lassign $regular rs re + + if {$ds >= 0} { + # Skip double-backslashes ... + set e $de + incr e + continue + } elseif {$qs >= 0} { + # Skip quoted braces ... + set e $qe + incr e + continue + } elseif {$rs >= 0} { + # Step one nesting level in or out. + if {[string index $data $rs] eq "\{" || "boguseditorfix" eq "\}"} { + incr level + } else { + incr level -1 + } + set e $re + incr e + #puts @$e + continue + } else { + return -code error "internal error" + } + } + # + incr e -2 ; # index of character just before the brace. + return [list $s $e 2] + + } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} { + # The word is a simple literal which ends at the next + # whitespace character. Note that there has to be a whitespace + # for us to recognize a word, for while there is no whitespace + # behind it in the buffer the word itself may be incomplete. + + return [linsert $wordrange end 1] + } + + return -code error "no complete word found/2" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::icomm ---}] +} + +interp alias {} ::punk::icomm::comm_cmd_interps {} ::punk::icomm::comm_cmd_ids + + + + +# ### ### ### ######### ######### ######### +## API: Future objects. + +snit::type punk::icomm::future { + option -command -default {} + + constructor {chan fid cmd ser} { + set xfid $fid + set xcmd $cmd + set xser $ser + set xchan $chan + return + } + + destructor { + if {!$canceled} { + return -code error \ + "Illegal attempt to destroy unresolved future \"$self\"" + } + } + + method return {args} { + # Syntax: | 0 + # : -code x | 2 + # : -code x val | 3 + # : val | 4 + # Allowing multiple -code settings, last one is taken. + + set rcode 0 + set rvalue {} + + while {[lindex $args 0] == "-code"} { + set rcode [lindex $args 1] + set args [lrange $args 2 end] + } + if {[llength $args] > 1} { + return -code error "wrong\#args, expected \"?-code errcode? ?result?\"" + } + if {[llength $args] == 1} { + set rvalue [lindex $args 0] + } + + if {!$canceled} { + ::punk::icomm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue + set canceled 1 + } + # assert: canceled == 1 + $self destroy + return + } + + variable xfid {} + variable xcmd {} + variable xser {} + variable xchan {} + variable canceled 0 + + # Internal method for use by comm channels. Marks the future as + # expired, no peer to return a result back to. + + method Cancel {} { + set canceled 1 + if {![llength $options(-command)]} {return} + uplevel #0 [linsert $options(-command) end $self] + return + } +} + +# ### ### ### ######### ######### ######### +## Setup +::punk::icomm::InitWrappers + +############################################################################### +# +# Finish creating "comm" using the default port for this interp. +# + +#don't listen by default +proc ::punk::icomm::initlocal {{tcpport 0}} { + if {![info exists ::punk::icomm::comm(comm,port)]} { + if {[string equal macintosh $::tcl_platform(platform)]} { + ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 0 -listen 1 + set ::punk::icomm::comm(localhost) \ + [lindex [fconfigure $::punk::icomm::comm(::punk::icomm::comm,socket) -sockname] 0] + ::punk::icomm::comm config -local 1 + } else { + ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 1 -listen 1 + } + } + return [::punk::icomm::comm configure] +} + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::icomm::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::icomm::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 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::icomm::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::icomm::system { + #*** !doctools + #[subsection {Namespace punk::icomm::system}] + #[para] Internal functions that are not part of the API + + + +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::icomm { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::icomm" + @package -name "punk::icomm" -help\ + "taken from tcllib comm package + todo - describe changes" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::icomm + } + 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::icomm + description to come.. + } \n] + } + proc get_topic_License {} { + return "" + } + proc get_topic_Version {} { + return "$::punk::icomm::version" + } + proc get_topic_Contributors {} { + set authors {} + 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_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # 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::icomm::about" + dict set overrides @cmd -name "punk::icomm::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::icomm + }] \n] + dict set overrides topic -choices [list {*}[punk::icomm::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::icomm::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::icomm::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::icomm::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::icomm +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::icomm [tcl::namespace::eval punk::icomm { + variable pkg punk::icomm + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm new file mode 100644 index 00000000..d41a947b --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm @@ -0,0 +1,3412 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/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 +# Copyright (C) 2004 Salvatore Sanfilippo +# Copyright (C) 2013 Nicola Hall +# Copyright (C) 2013 Magnatune +# +# 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) + +# +# @@ Meta Begin +# Application punk::imap4 0.9 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::imap4 0 0.9] +#[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 { + 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}] +#[item] [package {punk::args}] +#[item] [package {punk::lib}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::imap4::class { + #*** !doctools + #[subsection {Namespace punk::imap4::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +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::proto { + variable PUNKARGS + variable info + variable coninfo + namespace export {[a-z]*} + + #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 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] + } + # 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. + proc simplecmd {chan command validstates args} { + requirestate $chan $validstates + + set req "$command" + foreach arg $args { + 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 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 line + 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 + ::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 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 + } + + # Extract information from the line + set dirty 0 + 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= + regexp {.*\[CAPABILITY\s+(.*)\]\s*(.*)$} $line => capstring tailstring + 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'" + } + } + } + } + + #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) + incr dirty + } + {^[0-9]+\s+RECENT} { + regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent) + incr dirty + } + {.*?\[UIDVALIDITY\s+[0-9]+?\]} { + regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,uidval) + incr dirty + } + {.*?\[UNSEEN\s+[0-9]+?\]} { + regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,unseen) + incr dirty + } + {.*?\[UIDNEXT\s+[0-9]+?\]} { + regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \ + mboxinfo($chan,uidnext) + 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 + } + {^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) + 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] + 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 ad 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 + 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 + } + set info($chan,lastrequest) $request + } + + + # 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 {} + } + + 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 - + ALL {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 + } + + NOT { + set e [convert_search_expr [pop0 expr]] + multiline_append_command result "NOT" + multiline_concat_expr result $e + } + + SMALLER - + LARGER { + set len [pop0 expr] + ##nagelfar ignore + 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 + } + + + + # 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::OPEN + @cmd -name punk::imap4::OPEN -help\ + "Open a new IMAP connection and initialise the handler. + Returns the Tcl channel to use in subsequent calls to + the API." + @leaders -min 0 -max 0 + -debug -type boolean -default 0 + -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 port argument + 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 OPEN {args} { + set argd [punk::args::parse $args withid ::punk::imap4::OPEN] + 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::OPEN] + 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. todo UIDs separate variable? + #some headers have multipl 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 password [dict get $values 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 "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 password [dict get $values password] + package require base64 + set b64_creds [base64::encode $opt_authorization\0$username\0$password] + if {[punk::imap4::proto::simplecmd $chan "AUTHENTICATE PLAIN" {*}$allowstates $b64_creds]} { + return 1 + } + set info($chan,state) AUTH + 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; + 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 + }] + 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 + } + + # General function for selection. + proc selectmbox {chan cmd mailbox} { + upvar ::punk::imap4::proto::info info + variable mboxinfo + + 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 + 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 + } + + set info($chan,state) SELECT + # Set the new name as mbox->current. + #set mboxinfo($chan,current) $mailbox + _set_mboxinfo $chan current $mailbox + return 0 + } + # Read-only equivalent of SELECT. + proc EXAMINE {chan {mailbox INBOX}} { + selectmbox $chan EXAMINE $mailbox + } + + # Parse an IMAP range, store 'start' and 'end' in the + # named vars. If the first number of the range is omitted, + # 1 is assumed. If the second number of the range is omitted, + # the value of "exists" of the current mailbox is assumed. + # + # So : means all the messages. + proc parserange {chan range startvar endvar} { + + upvar $startvar start $endvar end + set rangelist [split $range :] + switch -- [llength $rangelist] { + 1 { + ##nagelfar ignore + 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] + } + ##nagelfar ignore + 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 + range supplied for the message(s) of interest." + @leaders -min 1 -max 1 + chan + @opts + -inline -type none + @values -min 1 -max -1 + range -help\ + "Message sequence number set. + e.g + 1 + 1:3 + 2:2 + :3 + " + queryitems -default {} -help\ + "Some common FETCH queries are shown here, but + this list isn't exhaustive."\ + -multiple 1 -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices { + ALL FAST FULL BODY BODYSTRUCTURE ENVELOPE FLAGS INTERNALDATE + SIZE RFC822.SIZE + UID + TEXT HEADER BODY[] + } -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" + } + }] + 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 range [dict get $values range] + set query_items [dict get $values queryitems] + + punk::imap4::proto::requirestate $chan SELECT + parserange $chan $range start end + + 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 $start:$end [lindex $items 0]"] + } else { + set request_tag [punk::imap4::proto::request $chan "FETCH $start:$end ([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. + proc CHECK {chan} { + punk::imap4::proto::simplecmd $chan CHECK SELECT {} + } + + # Close the mailbox. Permanently removes \Deleted messages and return to + # the AUTH state. + proc CLOSE {chan} { + upvar ::punk::imap4::proto::info info + variable mboxinfo + + if {[punk::imap4::proto::simplecmd $chan CLOSE SELECT {}]} { + 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 UNSELECT {*}$allowstates {}]} { + 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 + proc CREATE {chan mailbox} { + punk::imap4::proto::simplecmd $chan CREATE {AUTH SELECT} $mailbox + } + + # ------------------------------------------------------------ + # - RFC6154 IMAP LIST Extension for Special-use Mailboxes + # - other mailbox 'annotations' ? + # - relevant CAPS: SPECIAL-USE CREATE-SPECIAL-USE LIST-EXTENDED + # ------------------------------------------------------------ + proc GETMETADATA {chan mailbox annotation} { + #on cyrus at least, annotation must begin with /shared or /private + #e.g /private/specialuse + #C: GETMETDATA "Foldername" /private/specialuse + #S: * METADATA "Foldername" (/private/specialuse NIL) + #S: OK Completed + #or + #C: GETMETDATA "Junk" /private/specialuse + #S: * METADATA "Foldername" (/private/specialuse {5} + #S: \Junk + #S: ) + #S: OK Completed + set annotation [string trim $annotation] + if {![string match "/private/?*" $annotation] && ![string match "/shared/?*" $annotation]} { + error "GETMETADATA annotation must begin with /shared/ or /private/" + } + punk::imap4::proto::simplecmd $chan GETMETADATA {AUTH SELECT} $mailbox $annotation + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::SETMETADATA" + @cmd -name "punk::imap4::SETMETDATA" -help\ + "Set metadata on mailbox" + @leaders -min 1 -max 1 + chan + @opts + @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] + 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 {$value in [list "" NIL]} { + punk::imap4::proto::simplecmd $chan SETMETADATA {AUTH SELECT} $mailbox "($annotation NIL)" + } else { + punk::imap4::proto::simplecmd $chan SETMETADATA {AUTH SELECT} $mailbox "($annotation \"$value\")" + } + } + # ------------------------------------------------------------ + + # Delete a mailbox + proc DELETE {chan mailbox} { + punk::imap4::proto::simplecmd $chan DELETE {AUTH SELECT} $mailbox + } + + # Rename a mailbox + proc RENAME {chan oldname newname} { + punk::imap4::proto::simplecmd $chan RENAME {AUTH SELECT} $oldname $newname + } + + # Subscribe to a mailbox + proc SUBSCRIBE {chan mailbox} { + punk::imap4::proto::simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox + } + + # Unsubscribe to a mailbox + proc UNSUBSCRIBE {chan mailbox} { + punk::imap4::proto::simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox + } + + #TODO + proc IDLE {chan} { + if {[punk::imap4::prot::has_capability $chan IDLE]} { + punk::imap4::proto::simplecmd $chan IDLE {AUTH SELECT} + } 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 "" + mbox -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 mbox] + + 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 LIST $allowstates \"$ref\" \"$mbox\" RETURN (SPECIAL-USE SUBSCRIBED)] + } else { + set rv [punk::imap4::proto::simplecmd $chan LIST $allowstates \"$ref\" \"$mbox\" RETURN (SUBSCRIBED)] + } + if {$opt_inline} { + set rv {} + 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 rv [list [lindex $f 0] $lflags] + } + } + # parray folderinfo + return $rv + } + + + # Search command. + proc SEARCH {chan args} { + if {![llength $args]} { + error "missing arguments. Usage: search chan arg ?arg ...?" + } + + punk::imap4::proto::requirestate $chan SELECT + set imapexpr [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 + proc STORE {chan range key values} { + set valid_keys { + FLAGS + FLAGS.SILENT + +FLAGS + +FLAGS.SILENT + -FLAGS + -FLAGS.SILENT + } + if {$key ni $valid_keys} { + error "Invalid data item: $key. Must be one of [join $valid_keys ,]" + } + parserange $chan $range start end + set newflags {} + foreach val $values { + if {[regexp {^\\+(.*?)$} $val]} { + lappend newflags $values + } else { + lappend newflags "\\$val" + } + } + set clitag [punk::imap4::proto::request $chan "STORE $start:$end $key ([join $newflags])"] + if {[punk::imap4::proto::getresponse $chan $clitag]} { + return 1 + } + return 0 + } + + # Logout + proc LOGOUT {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 + } + + # Expunge : force removal of any messages with the + # flag \Deleted + proc EXPUNGE {chan} { + if {[punk::imap4::proto::simplecmd $chan EXPUNGE SELECT {}]} { + return 1 + } + return 0 + } + + # copy : copy a message to a destination mailbox + proc COPY {chan msgid mailbox} { + if {[punk::imap4::proto::simplecmd $chan COPY SELECT [list $msgid $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 + } + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::imap4 ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# 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? ~{} + #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 ()] + #[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[]<> (bare,squarelist?,partial) + return $words + } + + #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 ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::imap4::system { + #*** !doctools + #[subsection {Namespace punk::imap4::system}] + #[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 + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::imap4" + @package -name "punk::imap4" -help\ + "Package + Description" + }] + + 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 } {Nicola Hall } {Magnatune } {Julian Noble }} + 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::proto +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::imap4 [tcl::namespace::eval punk::imap4 { + variable pkg punk::imap4 + variable version + set version 0.9 +}] + +################################################################################ +# 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::OPEN {*}$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 :$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] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl b/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl new file mode 100644 index 00000000..6379cfd9 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl @@ -0,0 +1,44 @@ + + set a b + set x {a b} + set x [] + set x { + a + {b c} + } + + + + array set comm { + debug 0 + chans {} + localhost 1.2 + x {} + y jb + j aa + blah "xxxb" + defaulg 0 + } + + #test + + if {"x" eq max(2,3)} { + } + if {"x" eq min(1)} {} + + set x [dict create {a b c {x} e f }] + zlib adler32 "abc" + dict get $x "a" + #dict create {a b} + set x [] + #test + array set test1 {blah etc} + array set comm { + debug 0 chans {} localhost 127.0.0.1 + offerVers {3 2} + acceptVers {3 2} + defaultEncoding "utf-8" + defaultSilent 0 + } + #test + set x blah \ No newline at end of file diff --git a/src/modules/punk/repl-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm similarity index 98% rename from src/modules/punk/repl-0.1.tm rename to src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm index 354fa005..ebc24234 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm @@ -80,7 +80,17 @@ namespace eval repl { #(this is an example of a deaddrop) variable post_script } - +namespace eval punk::repl::class { + oo::class create con { + variable o_data ;#dict + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + } +} namespace eval punk::repl { tsv::set repl runid 0 @@ -2659,16 +2669,18 @@ namespace eval repl { set codethread_mutex [thread::mutex create] - set init_script [string map [list %args% [list $opts]\ - %argv0% [list $::argv0]\ - %argv% [list $::argv]\ - %argc% [list $::argc]\ - %replthread% [thread::id]\ - %replthread_cond% $codethread_cond\ - %replthread_interp% [list $opt_callback_interp]\ - %tmlist% [list [tcl::tm::list]]\ - %autopath% [list $::auto_path]\ - ] { + set scriptmap [list %args% [list $opts] \ + %argv0% [list $::argv0] \ + %argv% [list $::argv] \ + %argc% [list $::argc] \ + %replthread% [thread::id] \ + %replthread_cond% $codethread_cond \ + %replthread_interp% [list $opt_callback_interp] \ + %tmlist% [list [tcl::tm::list]] \ + %autopath% [list $::auto_path] \ + ] + #scriptmap applied at end to satisfy silly editor highlighting. + set init_script { set ::argv0 %argv0% set ::argv %argv% set ::argc %argc% @@ -2698,6 +2710,30 @@ namespace eval repl { package require punk::packagepreference punk::packagepreference::install + package require punk::args + package require Thread + package require snit + if {[catch {package require punk::icomm} errM]} { + puts stdout "---icomm $errM" + } + namespace eval ::punk::repl::codethread {} + #todo - review. According to fifo2 docs Memchan involves one less thread (may offer better performance/resource use) + catch {package require tcl::chan::fifo2} + if {[catch { + #first use can raise error being a version number e.g 0.1.0 - why? + lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside + } errMsg]} { + #puts stdout "---tcl::chan::fifo2 error: $errM" + } else { + #puts stdout "transferring chan $replside to thread %replthread%" + #flush stdout + if {[catch { + #after 0 [list thread::transfer %replthread% $replside] + } errMsg]} { + #puts stdout "---thread::transfer error: $errMsg" + } + } + package require punk::console package require punk::repl::codethread package require shellfilter @@ -2945,6 +2981,7 @@ namespace eval repl { interp create code } punkisland { + interp create code #todo #when no island paths specified - should be like safebase, but without folder hiding and with expanded read to ::auto_path folders } @@ -3378,7 +3415,9 @@ namespace eval repl { #puts stderr [thread::id] thread::id - }] + } + set init_script [string map $scriptmap $init_script] + #thread::send $codethread $init_script if {![catch { @@ -3395,8 +3434,8 @@ namespace eval repl { #init - don't auto init - require init with possible options e.g -safe } package provide punk::repl [namespace eval punk::repl { - variable version - set version 0.1 + variable version + set version 0.1.1 }] #repl::start $program_read_stdin_pipe diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm index 354fa005..a99f4757 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm @@ -80,7 +80,17 @@ namespace eval repl { #(this is an example of a deaddrop) variable post_script } - +namespace eval punk::repl::class { + oo::class create con { + variable o_data ;#dict + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + } +} namespace eval punk::repl { tsv::set repl runid 0