From 7c40f63c2a095eeafe79d2b2f7a2e1f186f40580 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 30 Jul 2025 23:29:53 +1000 Subject: [PATCH] subshell and subprocess work --- .../modules/punk/args/tclcore-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 115 +- src/lib/app-punk/repl.tcl | 15 +- src/make.tcl | 11 +- src/modules/picalc-999999.0a1.0.tm | 45 - src/modules/punk/args-999999.0a1.0.tm | 2 +- src/modules/punk/imap4-999999.0a1.0.tm | 66 +- src/modules/punk/libunknown-0.1.tm | 2 +- src/modules/punk/mix/cli-999999.0a1.0.tm | 34 +- .../mix/commandset/project-999999.0a1.0.tm | 115 +- .../punk/mix/commandset/repo-999999.0a1.0.tm | 33 +- .../mix/commandset/scriptwrap-999999.0a1.0.tm | 2 +- src/modules/punk/repl-999999.0a1.0.tm | 20 +- src/modules/punk/safe-999999.0a1.0.tm | 32 - src/modules/punk/sixel-999999.0a1.0.tm | 52 - src/modules/shellfilter-0.2.tm | 67 +- .../args-999999.0a1.0.tm | 3 +- src/modules/textblock-999999.0a1.0.tm | 1 - .../custom/_project/punk.basic/src/make.tcl | 11 +- .../modules/punk/args/tclcore-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 115 +- .../_project/punk.project-0.1/src/make.tcl | 11 +- .../modules/punk/args/tclcore-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 115 +- .../_project/punk.shell-0.1/src/make.tcl | 11 +- .../src/bootsupport/modules/pattern-1.2.4.tm | 2570 ++++++++--------- src/vendormodules/tomlish-1.1.6.tm | 13 +- src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl | 15 +- src/vfs/_vfscommon.vfs/lib/kettle1/kettle.tcl | 2 +- .../_vfscommon.vfs/modules/picalc-0.1.0.tm | 45 - .../_vfscommon.vfs/modules/punk/args-0.2.tm | 2 +- .../modules/punk/args/tclcore-0.1.0.tm | 2 +- .../modules/punk/docgen-0.1.0.tm | 29 +- .../_vfscommon.vfs/modules/punk/imap4-0.9.tm | 66 +- .../modules/punk/libunknown-0.1.tm | 2 +- .../modules/punk/mix/cli-0.3.1.tm | 34 +- .../punk/mix/commandset/project-0.1.0.tm | 115 +- .../modules/punk/mix/commandset/repo-0.1.0.tm | 33 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 2 +- .../_vfscommon.vfs/modules/punk/repl-0.1.2.tm | 20 +- .../_vfscommon.vfs/modules/punk/safe-0.1.0.tm | 32 - .../modules/punk/sixel-0.1.0.tm | 52 - .../_vfscommon.vfs/modules/shellfilter-0.2.tm | 67 +- .../modules/test/punk/args-0.1.5.tm | Bin 17085 -> 17085 bytes .../_vfscommon.vfs/modules/textblock-0.1.3.tm | 1 - .../_vfscommon.vfs/modules/tomlish-1.1.6.tm | 13 +- 46 files changed, 2033 insertions(+), 1966 deletions(-) diff --git a/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index 5eb1a6ea..562bddd4 100644 --- a/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -2629,7 +2629,7 @@ tcl::namespace::eval punk::args::tclcore { "Search for files which match the given patterns starting in the given ${$I}directory${$NI}. This allows searching of directories whose name contains glob-sensitive characters without the need to quote such characters explicitly. This option may not be used - in conjunction with ${$B}-path${$NI}, which is used to allow searching for complete file + in conjunction with ${$B}-path${$N}, which is used to allow searching for complete file paths whose names may contain glob-sensitive characters." -join -type none -help\ "The remaining pattern arguments, after option processing, are treated as a single diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 8abe694e..d0dd3eb0 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -776,33 +776,70 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc cd {{glob {}} args} { - dict set args -cd 1 - work $glob {*}$args + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." } - proc work {{glob {}} args} { + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received package require sqlite3 - set db_projects [lib::get_projects $glob] + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} if {[llength $db_projects] == 0} { - puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" return "" } - #list of lists of the form: - #{fosdb fname workdirlist} - set defaults [dict create\ - -cd 0\ - -detail "\uFFFF"\ - ] - set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- - set opt_cd [dict get $opts -cd] + set opt_cd [dict exists $received -cd] # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] - set opt_detail_explicit_zero 1 ;#default assumption only - if {$opt_detail eq "\uFFFF"} { + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { set opt_detail_explicit_zero 0 - set opt_detail 0; #default } + set opt_prompt [dict exists $received -prompt] # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] @@ -991,7 +1028,7 @@ namespace eval punk::mix::commandset::project { set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { puts stdout $msg - if {$numrows == 1} { + if {$numrows == 1 && !$opt_prompt} { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { @@ -1014,6 +1051,30 @@ namespace eval punk::mix::commandset::project { } return $msg } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } @@ -1029,12 +1090,17 @@ namespace eval punk::mix::commandset::project { @id -id ::punk::mix::commandset::project::lib::get_projects @cmd -name punk::mix::commandset::project::lib::get_projects\ -summary\ - "List projects referred to by central fossil config-db."\ + "Return a 3-element list of projects referred to by central fossil config-db."\ -help\ - "Get project info only by opening the central fossil config-db - (will not have proper project-name etc)" + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." @values -min 0 -max -1 - glob -type string -multiple 1 -default * -optional 1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." } proc get_projects {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] @@ -1048,6 +1114,9 @@ namespace eval punk::mix::commandset::project { ::sqlite3 fosconf $configdb #set testresult [fosconf eval {select name,value from global_config;}] #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { @@ -1064,7 +1133,7 @@ namespace eval punk::mix::commandset::project { } set filtered_list [list] foreach glob $globlist { - set matches [lsearch -all -inline -index 1 $paths_and_names $glob] + set matches [lsearch -nocase -all -inline -index 1 $paths_and_names $glob] foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m diff --git a/src/lib/app-punk/repl.tcl b/src/lib/app-punk/repl.tcl index ee01e7a9..3474eff0 100644 --- a/src/lib/app-punk/repl.tcl +++ b/src/lib/app-punk/repl.tcl @@ -47,7 +47,20 @@ package require punk::repl repl::init -safe 0 #puts stderr "Launching repl::start stdin -title app-punk" #flush stderr -repl::start stdin -title app-punk +set replresult [repl::start stdin -title app-punk] + +catch { + puts "app-punk ifneeded: [package ifneeded app-punk 1.0]" +} +#review +if {[string is integer -strict $replresult]} { + puts stdout "repl.tcl exiting with numeric code $replresult" + exit $replresult +} else { + puts stdout "repl.tcl result $replresult" + flush stdout + exit 0 +} #puts "- repl app done -" #flush stdout diff --git a/src/make.tcl b/src/make.tcl index b60bd752..6ffd6002 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -1565,9 +1565,14 @@ if {$::punkboot::command eq "shell"} { repl::init - repl::start stdin - - exit 1 + set replresult [repl::start stdin -title make.tcl] + #review + if {[string is integer -strict $replresult]} { + exit $replresult + } else { + puts stdout $replresult + exit 0 + } } if {$::punkboot::command eq "vfscommonupdate"} { diff --git a/src/modules/picalc-999999.0a1.0.tm b/src/modules/picalc-999999.0a1.0.tm index 9f4e9467..d5676271 100644 --- a/src/modules/picalc-999999.0a1.0.tm +++ b/src/modules/picalc-999999.0a1.0.tm @@ -65,39 +65,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval picalc::class { - #*** !doctools - #[subsection {Namespace picalc::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 picalc { @@ -502,18 +469,6 @@ tcl::namespace::eval picalc::lib { -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval picalc::system { - #*** !doctools - #[subsection {Namespace picalc::system}] - #[para] Internal functions that are not part of the API - - - -#} - # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index be5a2bae..d6a198ab 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -222,7 +222,7 @@ package require Tcl 8.6- tcl::namespace::eval punk::args::register { #*** !doctools - #[subsection {Namespace punk::args}] + #[subsection {Namespace punk::args::register}] #[para] cooperative namespace punk::args::register #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. diff --git a/src/modules/punk/imap4-999999.0a1.0.tm b/src/modules/punk/imap4-999999.0a1.0.tm index 5bdb01d6..522d75fb 100644 --- a/src/modules/punk/imap4-999999.0a1.0.tm +++ b/src/modules/punk/imap4-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- 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 +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm # # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -99,7 +99,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::imap4 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::imap4 0 999999.0a1.0] #[copyright "2025"] #[titledesc {IMAP4 client}] [comment {-- Name section and table of contents description --}] #[moddesc {IMAP4 client}] [comment {-- Description at end of page heading --}] @@ -117,6 +117,15 @@ #[para] - tcl::namespace::eval punk::imap4 { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id "(package)punk::imap4" + @package -name "punk::imap4"\ + -title "IMAP4 client library"\ + -description "An implementation of IMAP4 (rev1+?) client protocol."\ + -copyright "2025" + }] + if {[info exists ::argv0] && [info script] eq $::argv0} { #assert? - if argv0 exists and is same as [info script] - we're not in a safe interp #when running a tm module as an app - we should calculate the corresponding tm path @@ -173,7 +182,7 @@ package require Tcl 8.6.2- package require punk::args package require punk::lib #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6.2-}] #[item] [package {punk::args}] #[item] [package {punk::lib}] @@ -189,38 +198,6 @@ package require punk::lib #*** !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 @@ -4243,19 +4220,6 @@ tcl::namespace::eval 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 # == === === === === === === === === === === === === === === @@ -4264,12 +4228,6 @@ tcl::namespace::eval punk::imap4 { 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 diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm index 1b15d45a..3b5d35b0 100644 --- a/src/modules/punk/libunknown-0.1.tm +++ b/src/modules/punk/libunknown-0.1.tm @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[manpage_begin shellspy_module_punk::libunknown 0 0.1] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm index b6091779..655bed96 100644 --- a/src/modules/punk/mix/cli-999999.0a1.0.tm +++ b/src/modules/punk/mix/cli-999999.0a1.0.tm @@ -1083,20 +1083,28 @@ namespace eval punk::mix::cli { switch -- $calltype { lib {} shell { - set kettleappfile [file dirname [info nameofexecutable]]/kettle - set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat - - if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { - error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" - } - if {[file exists $kettleappfile]} { - set kettlescript $kettleappfile - } - if {$::tcl_platform(platform) eq "windows"} { - if {[file exists $kettlebatfile]} { - set kettlescript $kettlebatfile - } + #on windows - could be kettle.bat or kettle.cmd - use auto_execok to find, whatever the platform. + #for now, restrict to version sitting next to exe - REVIEW + set exedir [file dirname [info nameofexecutable]] + set kettlescript [auto_execok $exedir/kettle] + if {$kettlescript eq ""} { + error "kettle_call unable to find installed kettle application file in '$exedir'" } + + #set kettleappfile [file dirname [info nameofexecutable]]/kettle + #set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + #if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + # error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" + #} + #if {[file exists $kettleappfile]} { + # set kettlescript $kettleappfile + #} + #if {$::tcl_platform(platform) eq "windows"} { + # if {[file exists $kettlebatfile]} { + # set kettlescript $kettlebatfile + # } + #} } default { error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index 8cc6e5c5..61bd7b75 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -776,33 +776,70 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc cd {{glob {}} args} { - dict set args -cd 1 - work $glob {*}$args + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." } - proc work {{glob {}} args} { + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received package require sqlite3 - set db_projects [lib::get_projects $glob] + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} if {[llength $db_projects] == 0} { - puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" return "" } - #list of lists of the form: - #{fosdb fname workdirlist} - set defaults [dict create\ - -cd 0\ - -detail "\uFFFF"\ - ] - set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- - set opt_cd [dict get $opts -cd] + set opt_cd [dict exists $received -cd] # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] - set opt_detail_explicit_zero 1 ;#default assumption only - if {$opt_detail eq "\uFFFF"} { + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { set opt_detail_explicit_zero 0 - set opt_detail 0; #default } + set opt_prompt [dict exists $received -prompt] # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] @@ -991,7 +1028,7 @@ namespace eval punk::mix::commandset::project { set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { puts stdout $msg - if {$numrows == 1} { + if {$numrows == 1 && !$opt_prompt} { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { @@ -1014,6 +1051,30 @@ namespace eval punk::mix::commandset::project { } return $msg } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } @@ -1029,12 +1090,17 @@ namespace eval punk::mix::commandset::project { @id -id ::punk::mix::commandset::project::lib::get_projects @cmd -name punk::mix::commandset::project::lib::get_projects\ -summary\ - "List projects referred to by central fossil config-db."\ + "Return a 3-element list of projects referred to by central fossil config-db."\ -help\ - "Get project info only by opening the central fossil config-db - (will not have proper project-name etc)" + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." @values -min 0 -max -1 - glob -type string -multiple 1 -default * -optional 1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." } proc get_projects {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] @@ -1048,6 +1114,9 @@ namespace eval punk::mix::commandset::project { ::sqlite3 fosconf $configdb #set testresult [fosconf eval {select name,value from global_config;}] #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { @@ -1064,7 +1133,7 @@ namespace eval punk::mix::commandset::project { } set filtered_list [list] foreach glob $globlist { - set matches [lsearch -all -inline -index 1 $paths_and_names $glob] + set matches [lsearch -nocase -all -inline -index 1 $paths_and_names $glob] foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m diff --git a/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm b/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm index 5a307929..f7c2b009 100644 --- a/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm @@ -41,11 +41,27 @@ namespace eval punk::mix::commandset::repo { return $result } + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::fossilize + @cmd -name punk::mix::commandset::repo::fossilize + -summary\ + "Initialise and check in a project to fossil (unimplemented)."\ + -help\ + "(unimplemented)" + }] proc fossilize { args} { #check if project already managed by fossil.. initialise and check in if not. puts stderr "unimplemented" } + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::unfossilize + @cmd -name punk::mix::commandset::repo::unfossilize + -summary\ + "Remove/archive .fossil (unimplemented)."\ + -help\ + "(unimplemented)" + }] proc unfossilize {projectname args} { #remove/archive .fossil puts stderr "unimplemented" @@ -76,14 +92,27 @@ namespace eval punk::mix::commandset::repo { #punk::args lappend PUNKARGS [list { @id -id ::punk::mix::commandset::repo::fossil-move-repository - @cmd -name punk::mix::commandset::repo::fossil-move-repository -help\ + @cmd -name punk::mix::commandset::repo::fossil-move-repository + -summary\ + "Move a fossil repository database file."\ + -help\ "Move the fossil repository file (usually named with .fossil extension). This is an interactive function which will prompt for answers on stdin before proceeding. The move can be done even if there are open checkouts and will maintain - the link between checkout databases and the repository file." + the link between checkout databases and the repository file. + + The call can be made from within a folder containing fossil databases, + or from within one of the checkouts of the fossil database that is to + be moved. + " + + #todo? + #@values -min 0 -max 1 + #path }] proc fossil-move-repository {{path ""}} { + #path unused for now - todo - allow calling with a specific target rather than relying on cwd? set searchbase [pwd] set projectinfo [punk::repo::find_repos $searchbase] set projectbase [dict get $projectinfo closest] diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index c5f6b9b5..254bab83 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -77,7 +77,7 @@ namespace eval punk::mix::commandset::scriptwrap { #[para] Core API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - namespace export * + namespace export {[a-z]*} namespace eval fileline { namespace import ::punk::fileline::lib::* diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 25ecd92a..216cf0b7 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -522,7 +522,14 @@ proc repl::start {inchan args} { 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" + set donevalue [set [namespace current]::done] + if {[lindex $donevalue 0] eq "quit"} { + puts "-->repl::start end $inchan $args result:'$donevalue'" + puts stderr "--> returning [lindex $donevalue 1]" + return [lindex $donevalue 1] + } + puts "-->repl::start end $inchan $args result:'$donevalue'" + puts stderr "__> returning 0" return 0 } proc repl::post_operations {} { @@ -570,7 +577,7 @@ proc repl::reopen_stdin {} { #todo - avoid putting this in gobal namespace? #collisions with other libraries apps? proc punk::repl::quit {args} { - set ::repl::done "quit {*}$args" + set ::repl::done [list quit {*}$args] #puts stderr "quit called" return "" ;#make sure to return nothing so "quit" doesn't land on stdout } @@ -800,8 +807,7 @@ proc repl::rputs {args} { } } 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]]" + #review - string shouldn't be truncated prior to ansistrip - could chop ansi codes! 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} { @@ -1610,6 +1616,8 @@ proc repl::repl_handler {inputchan prompt_config} { if {![llength $input_chunks_waiting($inputchan)]} { chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] } else { + #review + #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" after idle [list ::repl::repl_handler $inputchan $prompt_config] } #################################################### @@ -2695,6 +2703,7 @@ namespace eval repl { proc init {args} { + puts stderr "-->repl::init $args" if {![info exists ::argv0]} { #error out before we create a thread - punk requires this - review error "::argv0 not set" @@ -2900,7 +2909,7 @@ namespace eval repl { 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] + thread::send -async %replthread% [list interp eval %replthread_interp% [list ::punk::repl::quit {*}$args]] } proc editbuf args { thread::send %replthread% [list punk::repl::editbuf {*}$args] @@ -3623,6 +3632,7 @@ namespace eval repl { #temporary debug aliases - deliberate violation of safety provided by safe interp code alias escapeeval ::repl::interphelpers::escapeeval + code alias exit ::repl::interphelpers::quit #experiment #code alias ::shellfilter::stack ::shellfilter::stack diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm index a40608c8..a0ed7ad1 100644 --- a/src/modules/punk/safe-999999.0a1.0.tm +++ b/src/modules/punk/safe-999999.0a1.0.tm @@ -63,38 +63,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::safe::class { - #*** !doctools - #[subsection {Namespace punk::safe::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 ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace diff --git a/src/modules/punk/sixel-999999.0a1.0.tm b/src/modules/punk/sixel-999999.0a1.0.tm index f69094fe..724c3f35 100644 --- a/src/modules/punk/sixel-999999.0a1.0.tm +++ b/src/modules/punk/sixel-999999.0a1.0.tm @@ -69,38 +69,6 @@ package require punk::ansi #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::sixel::class { - #*** !doctools - #[subsection {Namespace punk::sixel::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 ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #reading #https://www.reddit.com/r/linux/comments/t3m7zm/quick_roundup_of_bitmap_graphics_availability_in/ @@ -122,20 +90,6 @@ tcl::namespace::eval punk::sixel { - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - - #terminated by ST #some older terminals may terminate at first other esc encountered. #non-sixel characters ignored (? review) @@ -286,12 +240,6 @@ tcl::namespace::eval punk::sixel::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 - #} proc ascii_to_sixelvalue {a} { set dec [scan $a %c] if {$dec < 63 || $dec > 127} {error "ascii character to convert to sixel value must be from 63 to 126 (chars '?' through to '~')"} diff --git a/src/modules/shellfilter-0.2.tm b/src/modules/shellfilter-0.2.tm index 9aa98332..6c446aa3 100644 --- a/src/modules/shellfilter-0.2.tm +++ b/src/modules/shellfilter-0.2.tm @@ -152,65 +152,6 @@ namespace eval shellfilter::pipe { } - -namespace eval shellfilter::ansi { - #maint warning - - #ansistrip from punk::ansi is better/more comprehensive - proc stripcodes {text} { - #obsolete? - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. - #line endings can theoretically occur within an ansi escape sequence (review e.g title?) - set inputlist [split $text ""] - set outputlist [list] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_dict] - - set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls - set i 0 - foreach u $inputlist { - set v [lindex $inputlist $i+1] - set uv ${u}${v} - if {$in_escapesequence eq "2b"} { - #2nd byte - done. - set in_escapesequence 0 - } elseif {$in_escapesequence != 0} { - set escseq [dict get $escape_terminals $in_escapesequence] - if {$u in $escseq} { - set in_escapesequence 0 - } elseif {$uv in $escseq} { - set in_escapseequence 2b ;#flag next byte as last in sequence - } - } else { - #handle both 7-bit and 8-bit CSI and OSC - if {[regexp {^(?:\033\[|\u009b)} $uv]} { - set in_escapesequence CSI - } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { - set in_escapesequence OSC - } elseif {$uv in $2bytecodes} { - #self-contained e.g terminal reset - don't pass through. - set in_escapesequence 2b - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - -} namespace eval shellfilter::chan { set testobj ::shellfilter::chan::var if {$testobj ni [info commands $testobj]} { @@ -2851,8 +2792,10 @@ namespace eval shellfilter { - + #chan configure $inchan -buffering none -blocking 1 ;test chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + + chan configure $errchan -buffering $errbuffering #chan configure $outchan -blocking 0 chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. @@ -2889,7 +2832,9 @@ namespace eval shellfilter { # - and that at least appears like a terminal to the called command. #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - + #REVIEW! + #if the child process takes a while to begin reading stdin - the data on stdin between when we stopped the parent chan event handler and when the child gets data, + #seems to stay buffered somewhere. It is then read by the parent, after the child returns. (ie not lost, but out-of-order) set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] chan configure $rderr -buffering $errbuffering -blocking 0 diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm index 1903a58a..4afc180c 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm @@ -119,8 +119,7 @@ tcl::namespace::eval test::punk::args { lappend PUNKARGS [list { @id -id "(package)test::punk::args" @package -name "test::punk::args" -help\ - "Package - Description" + "Test suites for punk::args" }] namespace eval argdoc { diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index c7e44294..21ca38c3 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -4899,7 +4899,6 @@ tcl::namespace::eval textblock { set textblock [punk::ansi::ansistripraw $textblock] } if {[tcl::string::last \n $textblock] >= 0} { - #return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] set max [tcl::mathfunc::max {*}$widths] set min [tcl::mathfunc::min {*}$widths] diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index b60bd752..6ffd6002 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -1565,9 +1565,14 @@ if {$::punkboot::command eq "shell"} { repl::init - repl::start stdin - - exit 1 + set replresult [repl::start stdin -title make.tcl] + #review + if {[string is integer -strict $replresult]} { + exit $replresult + } else { + puts stdout $replresult + exit 0 + } } if {$::punkboot::command eq "vfscommonupdate"} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index 5eb1a6ea..562bddd4 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -2629,7 +2629,7 @@ tcl::namespace::eval punk::args::tclcore { "Search for files which match the given patterns starting in the given ${$I}directory${$NI}. This allows searching of directories whose name contains glob-sensitive characters without the need to quote such characters explicitly. This option may not be used - in conjunction with ${$B}-path${$NI}, which is used to allow searching for complete file + in conjunction with ${$B}-path${$N}, which is used to allow searching for complete file paths whose names may contain glob-sensitive characters." -join -type none -help\ "The remaining pattern arguments, after option processing, are treated as a single diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 8abe694e..d0dd3eb0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -776,33 +776,70 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc cd {{glob {}} args} { - dict set args -cd 1 - work $glob {*}$args + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." } - proc work {{glob {}} args} { + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received package require sqlite3 - set db_projects [lib::get_projects $glob] + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} if {[llength $db_projects] == 0} { - puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" return "" } - #list of lists of the form: - #{fosdb fname workdirlist} - set defaults [dict create\ - -cd 0\ - -detail "\uFFFF"\ - ] - set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- - set opt_cd [dict get $opts -cd] + set opt_cd [dict exists $received -cd] # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] - set opt_detail_explicit_zero 1 ;#default assumption only - if {$opt_detail eq "\uFFFF"} { + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { set opt_detail_explicit_zero 0 - set opt_detail 0; #default } + set opt_prompt [dict exists $received -prompt] # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] @@ -991,7 +1028,7 @@ namespace eval punk::mix::commandset::project { set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { puts stdout $msg - if {$numrows == 1} { + if {$numrows == 1 && !$opt_prompt} { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { @@ -1014,6 +1051,30 @@ namespace eval punk::mix::commandset::project { } return $msg } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } @@ -1029,12 +1090,17 @@ namespace eval punk::mix::commandset::project { @id -id ::punk::mix::commandset::project::lib::get_projects @cmd -name punk::mix::commandset::project::lib::get_projects\ -summary\ - "List projects referred to by central fossil config-db."\ + "Return a 3-element list of projects referred to by central fossil config-db."\ -help\ - "Get project info only by opening the central fossil config-db - (will not have proper project-name etc)" + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." @values -min 0 -max -1 - glob -type string -multiple 1 -default * -optional 1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." } proc get_projects {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] @@ -1048,6 +1114,9 @@ namespace eval punk::mix::commandset::project { ::sqlite3 fosconf $configdb #set testresult [fosconf eval {select name,value from global_config;}] #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { @@ -1064,7 +1133,7 @@ namespace eval punk::mix::commandset::project { } set filtered_list [list] foreach glob $globlist { - set matches [lsearch -all -inline -index 1 $paths_and_names $glob] + set matches [lsearch -nocase -all -inline -index 1 $paths_and_names $glob] foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index b60bd752..6ffd6002 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -1565,9 +1565,14 @@ if {$::punkboot::command eq "shell"} { repl::init - repl::start stdin - - exit 1 + set replresult [repl::start stdin -title make.tcl] + #review + if {[string is integer -strict $replresult]} { + exit $replresult + } else { + puts stdout $replresult + exit 0 + } } if {$::punkboot::command eq "vfscommonupdate"} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index 5eb1a6ea..562bddd4 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -2629,7 +2629,7 @@ tcl::namespace::eval punk::args::tclcore { "Search for files which match the given patterns starting in the given ${$I}directory${$NI}. This allows searching of directories whose name contains glob-sensitive characters without the need to quote such characters explicitly. This option may not be used - in conjunction with ${$B}-path${$NI}, which is used to allow searching for complete file + in conjunction with ${$B}-path${$N}, which is used to allow searching for complete file paths whose names may contain glob-sensitive characters." -join -type none -help\ "The remaining pattern arguments, after option processing, are treated as a single diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 8abe694e..d0dd3eb0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -776,33 +776,70 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc cd {{glob {}} args} { - dict set args -cd 1 - work $glob {*}$args + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." } - proc work {{glob {}} args} { + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received package require sqlite3 - set db_projects [lib::get_projects $glob] + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} if {[llength $db_projects] == 0} { - puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" return "" } - #list of lists of the form: - #{fosdb fname workdirlist} - set defaults [dict create\ - -cd 0\ - -detail "\uFFFF"\ - ] - set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- - set opt_cd [dict get $opts -cd] + set opt_cd [dict exists $received -cd] # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] - set opt_detail_explicit_zero 1 ;#default assumption only - if {$opt_detail eq "\uFFFF"} { + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { set opt_detail_explicit_zero 0 - set opt_detail 0; #default } + set opt_prompt [dict exists $received -prompt] # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] @@ -991,7 +1028,7 @@ namespace eval punk::mix::commandset::project { set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { puts stdout $msg - if {$numrows == 1} { + if {$numrows == 1 && !$opt_prompt} { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { @@ -1014,6 +1051,30 @@ namespace eval punk::mix::commandset::project { } return $msg } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } @@ -1029,12 +1090,17 @@ namespace eval punk::mix::commandset::project { @id -id ::punk::mix::commandset::project::lib::get_projects @cmd -name punk::mix::commandset::project::lib::get_projects\ -summary\ - "List projects referred to by central fossil config-db."\ + "Return a 3-element list of projects referred to by central fossil config-db."\ -help\ - "Get project info only by opening the central fossil config-db - (will not have proper project-name etc)" + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." @values -min 0 -max -1 - glob -type string -multiple 1 -default * -optional 1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." } proc get_projects {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] @@ -1048,6 +1114,9 @@ namespace eval punk::mix::commandset::project { ::sqlite3 fosconf $configdb #set testresult [fosconf eval {select name,value from global_config;}] #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { @@ -1064,7 +1133,7 @@ namespace eval punk::mix::commandset::project { } set filtered_list [list] foreach glob $globlist { - set matches [lsearch -all -inline -index 1 $paths_and_names $glob] + set matches [lsearch -nocase -all -inline -index 1 $paths_and_names $glob] foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index b60bd752..6ffd6002 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -1565,9 +1565,14 @@ if {$::punkboot::command eq "shell"} { repl::init - repl::start stdin - - exit 1 + set replresult [repl::start stdin -title make.tcl] + #review + if {[string is integer -strict $replresult]} { + exit $replresult + } else { + puts stdout $replresult + exit 0 + } } if {$::punkboot::command eq "vfscommonupdate"} { diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm index 5d76af04..6bc10b20 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm @@ -1,1285 +1,1285 @@ -#PATTERN -# - A prototype-based Object system. -# -# Julian Noble 2003 -# License: Public domain -# - -# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern. -# -# -# Pattern uses a mixture of class-based and prototype-based object instantiation. -# -# A pattern object has 'properties' and 'methods' -# The system makes a distinction between them with regards to the access syntax for write operations, -# and yet provides unity in access syntax for read operations. -# e.g >object . myProperty -# will return the value of the property 'myProperty' -# >ojbect . myMethod -# will return the result of the method 'myMethod' -# contrast this with the write operations: -# set [>object . myProperty .] blah -# >object . myMethod blah -# however, the property can also be read using: -# set [>object . myProperty .] -# Note the trailing . to give us a sort of 'reference' to the property. -# this is NOT equivalent to -# set [>object . myProperty] -# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property -# i.e it is equivalent in this case to: set blah - -#All objects are represented by a command, the name of which contains a leading ">". -#Any commands in the interp which use this naming convention are assumed to be a pattern object. -#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined) - -#All user-added properties & methods of the wrapped object are accessed -# using the separator character "." -#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".." -# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype) -# you would use the 'Create' metamethod on the pattern object like so: -# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject -# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties -# of the object it was created from. ( - - -#The use of the access-syntax separator character "." allows objects to be kept -# 'clean' in the sense that the only methods &/or properties that can be called this way are ones -# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax -# so you are free to implement your own 'Create' method on your object that doesn't conflict with -# the metamethod. - -#Chainability (or how to violate the Law of Demeter!) -#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other -# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference -# structure, without the need to regress to enter matching brackets as is required when using -# standard TCL command syntax. -# ie instead of: -# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething -# we can use: -# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething -# -# This separates out the object-traversal syntax from the TCL command syntax. - -# . is the 'traversal operator' when it appears between items in a commandlist -# . is the 'reference operator' when it is the last item in a commandlist -# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'. -# It marks breaks in the multidimensional structure that correspond to how the data is stored. -# e.g obj . arraydata x y , x1 y1 z1 -# represents an element of a 5-dimensional array structured as a plane of cubes -# e.g2 obj . arraydata x y z , x1 y1 -# represents an element of a 5-dimensional array structured as a cube of planes -# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1 -# .. is the 'meta-traversal operator' when it appears between items in a commandlist -# .. is the 'meta-info operator'(?) when it is the last item in a commandlist - - -#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing -# implement iStacks & pStacks (interface stacks & pattern stacks) - -#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975 - - -#------------------------------------------------------------ -# System objects. -#------------------------------------------------------------ -#::p::-1 ::p::internals::>metaface -#::p::0 ::p::ifaces::>null -#::p::1 ::>pattern -#------------------------------------------------------------ - -#TODO - -#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?) - - -#CHANGES -#2018-09 - v 1.2.2 -# varied refactoring -# Changed invocant datastructure curried into commands (the _ID_ structure) -# Changed MAP structure to dict -# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns) -# updated test suites -#2018-08 - v 1.2.1 -# split ::p::predatorX functions into separate files (pkgs) -# e.g patternpredator2-1.0.tm -# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken -# -#2017-08 - v 1.1.6 Fairly big overhaul -# New predator function using coroutines -# Added bang operator ! -# Fixed Constructor chaining -# Added a few tests to test::pattern -# -#2008-03 - preserve ::errorInfo during var writes - -#2007-11 -#Major overhaul + new functionality + new tests v 1.1 -# new dispatch system - 'predator'. -# (preparing for multiple interface stacks, multiple invocants etc) -# -# -#2006-05 -# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature. -# -#2005-12 -# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top. -# -# Fixed so that PatternVariable default applied on Create. -# -# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE:::: -# - heading towards multiple-interface objects -# -#2005-10-28 -# 1.0.8.1 passes 80/80 tests -# >object .. Destroy - improved cleanup of interfaces & namespaces. -# -#2005-10-26 -# fixes to refsync (still messy!) -# remove variable traces on REF vars during .. Destroy -# passes 76/76 -# -#2005-10-24 -# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined. -# 1.0.8.0 now passes 75/76 -# -#2005-10-19 -# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before) -# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names) -# 1.0.8.0 (passes 74/76) -# tests now in own package -# usage: -# package require test::pattern -# test::p::list -# test::p::run ?nameglob? ?-version ? -# -#2005-09?-12 -# -# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc. -# fixed @next@ so that destination method resolved at interface compile time instead of call time -# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x. -# (before, the overlay only occured when '.. Method' was used to override.) -# -# -# miscellaneous tidy-ups -# -# 1.0.7.8 (passes 71/73) -# -#2005-09-10 -# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value -# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier. -# -#2005-09-07 -# bugfix indexed write to list property -# bugfix Variable default value -# 1.0.7.7 (passes 70/72) -# fails: -# arrayproperty.test - array-entire-reference -# properties.test - property_getter_filter_via_ObjectRef -# -#2005-04-22 -# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!) -# -# 1.0.7.4 -# -#2004-11-05 -# basic PropertyRead implementation (non-indexed - no tests!) -# -#2004-08-22 -# object creation speedups - (pattern::internals::obj simplified/indirected) -# -#2004-08-17 -# indexed property setter fixes + tests -# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values) -# -#2004-08-16 -# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset) -# -#2004-08-15 -# reference syncing: ensure writes to properties always trigger traces on property references (+ tests) -# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger -# - also trigger on curried traces to indexed properties i.e list and array elements. -# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties. -# -# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .] -# -#2004-08-05 -# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write) -# -# fix + add tests to support method & property of same name. (method precedence) -# -#2004-08-04 -# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var) -# -# 1.0.7.1 -# use objectref array access to read properties even when some props unset; + test -# unset property using array access on object reference; + test -# -# -#2004-07-21 -# object reference changes - array property values appear as list value when accessed using upvared array. -# bugfixes + tests - properties containing lists (multidimensional access) -# -#1.0.7 -# -#2004-07-20 -# fix default property value append problem -# -#2004-07-17 -# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods -# ( -# -#2004-06-18 -# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces. -# -#2004-06-05 -# change argsafety operator to be anything with leading - -# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-' -# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg, -# the entire dash-prefixed operator is also passed in as an argument. -# e.g >object . doStuff -window . -# will call the doStuff method with the 2 parameters -window . -# >object . doStuff - . -# will call doStuff with single parameter . -# >object . doStuff - -window . -# will result in a reference to the doStuff method with the argument -window 'curried' in. -# -#2004-05-19 -#1.0.6 -# fix so custom constructor code called. -# update Destroy metamethod to unset $self -# -#1.0.4 - 2004-04-22 -# bug fixes regarding method specialisation - added test -# -#------------------------------------------------------------ - -package provide pattern [namespace eval pattern {variable version; set version 1.2.4}] - - -namespace eval pattern::util { - - # Generally better to use 'package require $minver-' - # - this only gives us a different error - proc package_require_min {pkg minver} { - if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { - package require $pkg - } else { - error "Package pattern requires package $pkg of at least version $minver. Available: $available" - } - } -} - -package require patterncmd 1.2.4- -package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) - - - -#package require cmdline -package require overtype - -#package require md5 ;#will be loaded if/when needed -#package require md4 -#package require uuid - - - - - -namespace eval pattern { - variable initialised 0 - - - if 0 { - if {![catch {package require twapi_base} ]} { - #twapi is a windows only package - #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. - # If available - windows seems to provide a fast uuid generator.. - #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) - # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) - interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok - } else { - #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) - # (e.g 200usec 2018 corei9) - #(with or without tcllibc?) - #very first call is extremely slow though - 3.5seconds on 2018 corei9 - package require uuid - interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate - } - #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) - } - - -} - - - - - - -namespace eval p { - #this is also the interp alias namespace. (object commands created here , then renamed into place) - #the object aliases are named as incrementing integers.. !todo - consider uuids? - variable ID 0 - namespace eval internals {} - - - #!?? - #namespace export ?? - variable coroutine_instance 0 -} - -#------------------------------------------------------------------------------------- -#review - what are these for? -#note - this function is deliberately not namespaced -# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features -proc process_pattern_aliases {object args} { - set o [namespace tail $object] - interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] - interp alias {} process_method_$o {} [$object .. Method .] - interp alias {} process_constructor_$o {} [$object .. Constructor .] -} -#------------------------------------------------------------------------------------- - - - - -#!store all interface objects here? -namespace eval ::p::ifaces {} - - - -#K combinator - see http://wiki.tcl.tk/1923 -#proc ::p::K {x y} {set x} -#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] - - - - - - - - -proc ::p::internals::(VIOLATE) {_ID_ violation_script} { - #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] - set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] - - if {![dict get $processed explicitvars]} { - #no explicit var statements - we need the implicit ones - set self [set ::p::${_ID_}::(self)] - set IFID [lindex [set $self] 1 0 end] - #upvar ::p::${IFID}:: self_IFINFO - - - set varDecls {} - set vlist [array get ::p::${IFID}:: v,name,*] - set _k ""; set v "" - if {[llength $vlist]} { - append varDecls "upvar #0 " - foreach {_k v} $vlist { - append varDecls "::p::\${_ID_}::$v $v " - } - append varDecls "\n" - } - - #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] - set violation_script $varDecls\n[dict get $processed body] - - #tidy up - unset processed varDecls self IFID _k v - } else { - set violation_script [dict get $processed body] - } - unset processed - - - - - #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. - eval "unset violation_script;$violation_script" -} - - -proc ::p::internals::DestroyObjectsBelowNamespace {ns} { - #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" - - set nsparts [split [string trim [string map {:: :} $ns] :] :] - if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { - #ns not of form ::p::?::_ref - - foreach obj [info commands ${ns}::>*] { - #catch {::p::meta::Destroy $obj} - #puts ">>found object $obj below ns $ns - destroying $obj" - $obj .. Destroy - } - } - - #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] - #foreach tinfo $traces { - # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo - #} - #unset -nocomplain ${ns}::-->PATTERN_ANCHOR - - foreach sub [namespace children $ns] { - ::p::internals::DestroyObjectsBelowNamespace $sub - } -} - - - - -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# - - - - - - - - - -proc ::p::get_new_object_id {} { - tailcall incr ::p::ID - #tailcall ::pattern::new_uuid -} - -#create a new minimal object - with no interfaces or patterns. - -#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} -proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { - - #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" - - if {$OID eq "-2"} { - set OID [::p::get_new_object_id] - #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) - #set OID [pattern::new_uuid] - } - #if $wrapped provided it is assumed to be an existing namespace. - #if {[string length $wrapped]} { - # #??? - #} - - #sanity check - alias must not exist for this OID - if {[llength [interp alias {} ::p::$OID]]} { - error "Object alias '::p::$OID' already exists - cannot create new object with this id" - } - - #system 'varspaces' - - - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - - # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. - # (see http://wiki.tcl.tk/1030 'Dangers of creative writing') - #set o_open 1 - every object is initially also an open interface (?) - #NOTE! comments within namespace eval slow it down. - namespace eval ::p::$OID { - #namespace ensemble create - namespace eval _ref {} - namespace eval _meta {} - namespace eval _iface { - variable o_usedby; - variable o_open 1; - array set o_usedby [list]; - variable o_varspace "" ; - variable o_varspaces [list]; - variable o_methods [dict create]; - variable o_properties [dict create]; - variable o_variables; - variable o_propertyunset_handlers; - set o_propertyunset_handlers [dict create] - } - } - - #set alias ::p::$OID - - #objectid alis default_method object_command wrapped_namespace - set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] - - #MAP is a dict - set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] - - - - #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token - #we've already checked that ::p::$OID doesn't pre-exist - # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias - #interp alias {} ::p::$OID {} ::p::internals::predator $MAP - - - # _ID_ structure - set invocants_dict [dict create this [list $INVOCANTDATA] ] - #puts stdout "New _ID_structure: $interfaces_dict" - set _ID_ [dict create i $invocants_dict context ""] - - - interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ - #rename the command into place - thus the alias & the command name no longer match! - rename ::p::$OID $cmd - - set ::p::${OID}::_meta::map $MAP - - # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something - interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ - - #set p2 [string map {> ?} $cmd] - #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ - - - #trace add command $cmd delete "$cmd .. Destroy ;#" - #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" - - trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" - #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) - - #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" - - - #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" - #trace add command $cmd delete "puts deleting$cmd ;#" - #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" - - - #puts "--> new_object returning map $MAP" - return $MAP -} - - - - -#>x .. Create >y -# ".." is special case equivalent to "._." -# (whereas in theory it would be ".default.") -# "." is equivalent to ".default." is equivalent to ".default.default." (...) - -#>x ._. Create >y -#>x ._.default. Create >y ??? -# -# - -# create object using 'blah' as source interface-stack ? -#>x .blah. .. Create >y -#>x .blah,_. ._. Create .iStackDestination. >y - - - -# -# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _] -# the 1st item, blah in this case becomes the 'default' iStack. -# -#>x .*. -# cast to object with all iStacks -# -#>x .*,!_. -# cast to object with all iStacks except _ -# -# --------------------- -#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@' -# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not. -# -#eg1: >x & >y . some_multi_method arg arg -# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects) -# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these' -# The invocant signature is thus {these 2} -# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1}) -# Invocation roles can be specified in the call using the @ operator. -# e.g >x & >y @ points . some_multi_method arg arg -# The invocant signature for this is: {points 2} -# -#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path -# This has the signature {objects n plane 1} where n depends on the length of the list $objects -# -# -# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration. -# e.g set pointset [>x & >y .] -# We can now call multimethods on $pointset -# - - - - - - -#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) -proc ::pattern::predatorversion {{ver ""}} { - variable active_predatorversion - set allowed_predatorversions {1 2} - set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions - - if {![info exists active_predatorversion]} { - set first_time_set 1 - } else { - set first_time_set 0 - } - - if {$ver eq ""} { - #get version - if {$first_time_set} { - set active_predatorversions $default_predatorversion - } - return $active_predatorversion - } else { - #set version - if {$ver ni $allowed_predatorversions} { - error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" - } - - if {!$first_time_set} { - if {$active_predatorversion eq $ver} { - #puts stderr "Active predator version is already '$ver'" - #ok - nothing to do - return $active_predatorversion - } else { - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - rename ::p::internals::predator ::p::predator$active_predatorversion - } - } - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - - rename ::p::predator$ver ::p::internals::predator - set active_predatorversion $ver - - return $active_predatorversion - } -} -::pattern::predatorversion 2 - - - - - - - - - - - - -# >pattern has object ID 1 -# meta interface has object ID 0 -proc ::pattern::init args { - - if {[set ::pattern::initialised]} { - if {[llength $args]} { - #if callers want to avoid this error, they can do their own check of $::pattern::initialised - error "pattern package is already initialised. Unable to apply args: $args" - } else { - return 1 - } - } - - #this seems out of date. - # - where is PatternPropertyRead? - # - Object is obsolete - # - Coinjoin, Combine don't seem to exist - array set ::p::metaMethods { - Clone object - Conjoin object - Combine object - Create object - Destroy simple - Info simple - Object simple - PatternProperty simple - PatternPropertyWrite simple - PatternPropertyUnset simple - Property simple - PropertyWrite simple - PatternMethod simple - Method simple - PatternVariable simple - Variable simple - Digest simple - PatternUnknown simple - Unknown simple - } - array set ::p::metaProperties { - Properties object - Methods object - PatternProperties object - PatternMethods object - } - - - - - - #create metaface - IID = -1 - also OID = -1 - # all objects implement this special interface - accessed via the .. operator. - - - - - - set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface - - - #OID = 0 - ::p::internals::new_object ::p::ifaces::>null "" 0 - - #? null object has itself as level0 & level1 interfaces? - #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]] - - #null interface should always have 'usedby' members. It should never be extended. - array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array - set ::p::0::_iface::o_open 0 - - set ::p::0::_iface::o_constructor [list] - set ::p::0::_iface::o_variables [list] - set ::p::0::_iface::o_properties [dict create] - set ::p::0::_iface::o_methods [dict create] - set ::p::0::_iface::o_varspace "" - set ::p::0::_iface::o_varspaces [list] - array set ::p::0::_iface::o_definition [list] - set ::p::0::_iface::o_propertyunset_handlers [dict create] - - - - - ############################### - # OID = 1 - # >pattern - ############################### - ::p::internals::new_object ::>pattern "" 1 - - #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] - - - array set ::p::1::_iface::o_usedby [list] ;#'usedby' array - - set _self ::pattern - - #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1 - #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1 - - - - #1)this object references its interfaces - #lappend ID $IFID $IFID_1 - #lset SELFMAP 1 0 $IFID - #lset SELFMAP 2 0 $IFID_1 - - - #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND] - #proc ::>pattern args $body - - - - - ####################################################################################### - #OID = 2 - # >ifinfo interface for accessing interfaces. - # - ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object - set ::p::2::_iface::o_constructor [list] - set ::p::2::_iface::o_variables [list] - set ::p::2::_iface::o_properties [dict create] - set ::p::2::_iface::o_methods [dict create] - set ::p::2::_iface::o_varspace "" - set ::p::2::_iface::o_varspaces [list] - array set ::p::2::_iface::o_definition [list] - set ::p::2::_iface::o_open 1 ;#open for extending - - ::p::ifaces::>2 .. AddInterface 2 - - #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations - #(bootstrap because we can't yet use metaface methods on it) - - - - proc ::p::2::_iface::isOpen.1 {_ID_} { - return $::p::2::_iface::o_open - } - interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1 - - proc ::p::2::_iface::isClosed.1 {_ID_} { - return [expr {!$::p::2::_iface::o_open}] - } - interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1 - - proc ::p::2::_iface::open.1 {_ID_} { - set ::p::2::_iface::o_open 1 - } - interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1 - - proc ::p::2::_iface::close.1 {_ID_} { - set ::p::2::_iface::o_open 0 - } - interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1 - - - #proc ::p::2::_iface::(GET)properties.1 {_ID_} { - # set ::p::2::_iface::o_properties - #} - #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1 - - #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties - - - #proc ::p::2::_iface::(GET)methods.1 {_ID_} { - # set ::p::2::_iface::o_methods - #} - #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1 - #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods - - - - - - #link from object to interface (which in this case are one and the same) - - #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --] - #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --] - #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --] - #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --] - - interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen - interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed - interp alias {} ::p::2::open {} ::p::2::_iface::open - interp alias {} ::p::2::close {} ::p::2::_iface::close - - - #namespace eval ::p::2 "namespace export $method" - - ####################################################################################### - - - - - - - set ::pattern::initialised 1 - - - ::p::internals::new_object ::p::>interface "" 3 - #create a convenience object on which to manipulate the >ifinfo interface - #set IF [::>pattern .. Create ::p::>interface] - set IF ::p::>interface - - - #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects? - # (or is forcing end user to add their own pStack/iStack ok .. ?) - # - ::p::>interface .. AddPatternInterface 2 ;# - - ::p::>interface .. PatternVarspace _iface - - ::p::>interface .. PatternProperty methods - ::p::>interface .. PatternPropertyRead methods {} { - varspace _iface - var {o_methods alias} - return $alias - } - ::p::>interface .. PatternProperty properties - ::p::>interface .. PatternPropertyRead properties {} { - varspace _iface - var o_properties - return $o_properties - } - ::p::>interface .. PatternProperty variables - - ::p::>interface .. PatternProperty varspaces - - ::p::>interface .. PatternProperty definition - - ::p::>interface .. Constructor {{usedbylist {}}} { - #var this - #set this @this@ - #set ns [$this .. Namespace] - #puts "-> creating ns ${ns}::_iface" - #namespace eval ${ns}::_iface {} - - varspace _iface - var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces - - set o_constructor [list] - set o_variables [list] - set o_properties [dict create] - set o_methods [dict create] - set o_varspaces [list] - array set o_definition [list] - - foreach usedby $usedbylist { - set o_usedby(i$usedby) 1 - } - - - } - ::p::>interface .. PatternMethod isOpen {} { - varspace _iface - var o_open - - return $o_open - } - ::p::>interface .. PatternMethod isClosed {} { - varspace _iface - var o_open - - return [expr {!$o_open}] - } - ::p::>interface .. PatternMethod open {} { - varspace _iface - var o_open - set o_open 1 - } - ::p::>interface .. PatternMethod close {} { - varspace _iface - var o_open - set o_open 0 - } - ::p::>interface .. PatternMethod refCount {} { - varspace _iface - var o_usedby - return [array size o_usedby] - } - - set ::p::2::_iface::o_open 1 - - - - - uplevel #0 {pattern::util::package_require_min patternlib 1.2.4} - #uplevel #0 {package require patternlib} - return 1 -} - - - -proc ::p::merge_interface {old new} { - #puts stderr " ** ** ** merge_interface $old $new" - set ns_old ::p::$old - set ns_new ::p::$new - - upvar #0 ::p::${new}:: IFACE - upvar #0 ::p::${old}:: IFACEX - - if {![catch {set c_arglist $IFACEX(c,args)}]} { - #constructor - #for now.. just add newer constructor regardless of any existing one - #set IFACE(c,args) $IFACEX(c,args) - - #if {![info exists IFACE(c,args)]} { - # #target interface didn't have a constructor - # - #} else { - # # - #} - } - - - set methods [::list] - foreach nm [array names IFACEX m-1,name,*] { - lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) - } - - #puts " *** merge interface $old -> $new ****merging-in methods: $methods " - - foreach method $methods { - if {![info exists IFACE(m-1,name,$method)]} { - #target interface doesn't yet have this method - - set THISNAME $method - - if {![string length [info command ${ns_new}::$method]]} { - - if {![set ::p::${old}::_iface::o_open]} { - #interp alias {} ${ns_new}::$method {} ${ns_old}::$method - #namespace eval $ns_new "namespace export [namespace tail $method]" - } else { - #wait to compile - } - - } else { - error "merge interface - command collision " - } - #set i 2 ??? - set i 1 - - } else { - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - - set i [incr IFACE(m-1,chain,$method)] - - set THISNAME ___system___override_${method}_$i - - #move metadata using subindices for delegated methods - set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) - set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) - set IFACE(mp-$i,$method) $IFACE(mp-1,$method) - - set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) - set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) - - - #set next [::p::next_script $IFID0 $method] - if {![string length [info command ${ns_new}::$THISNAME]]} { - if {![set ::p::${old}::_iface::o_open]} { - interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method - namespace eval $ns_new "namespace export $method" - } else { - #wait for compile - } - } else { - error "merge_interface - command collision " - } - - } - - array set IFACE [::list \ - m-1,chain,$method $i \ - m-1,body,$method $IFACEX(m-1,body,$method) \ - m-1,args,$method $IFACEX(m-1,args,$method) \ - m-1,name,$method $THISNAME \ - m-1,iface,$method $old \ - ] - - } - - - - - - #array set ${ns_new}:: [array get ${ns_old}::] - - - #!todo - review - #copy everything else across.. - - foreach {nm v} [array get IFACEX] { - #puts "-.- $nm" - if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { - set IFACE($nm) $v - } - } - - #!todo -write a test - set ::p::${new}::_iface::o_open 1 - - #!todo - is this done also when iface compiled? - #namespace eval ::p::$new {namespace ensemble create} - - - #puts stderr "copy_interface $old $new" - - #assume that the (usedby) data is now obsolete - #???why? - #set ${ns_new}::(usedby) [::list] - - #leave ::(usedby) reference in place - - return -} - - - - -#detect attempt to treat a reference to a method as a property -proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { -#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args" - lassign [lrange $args end-2 end] vtraced vidx op - #NOTE! cannot rely on vtraced as it may have been upvared - - switch -- $op { - write { - error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])" - } - unset { - #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace - #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #!todo - don't use vtraced! - trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #pointless raising an error as "Any errors in unset traces are ignored" - #error "cannot unset. $field is a method not a property" - } - read { - error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])" - } - array { - error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])" - #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args" - } - } - - return -} - - - - -#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points. -# -# The 'dispatcher' is an object instance's underlying object command. -# - -#proc ::p::make_dispatcher {obj ID IFID} { -# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] { -# ::p::@IID@ $methprop @oid@ {*}$args -# }] -# return -#} - - - - -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -#aliased from ::p::${OID}:: -# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something -proc ::p::internals::no_default_method {_ID_ args} { - puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'" - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped - tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)" -} - -#force 1 will extend an interface even if shared. (??? why is this necessary here?) -#if IID empty string - create the interface. -proc ::p::internals::expand_interface {IID {force 0}} { - #puts stdout ">>> expand_interface $IID [info level -1]<<<" - if {![string length $IID]} { - #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) - set iid [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$iid - return $iid - } else { - if {[set ::p::${IID}::_iface::o_open]} { - #interface open for extending - shared or not! - return $IID - } - - if {[array size ::p::${IID}::_iface::o_usedby] > 1} { - #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby - - #oops.. shared interface. Copy before specialising it. - set prev_IID $IID - - #set IID [::p::internals::new_interface] - set IID [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$IID - - ::p::internals::linkcopy_interface $prev_IID $IID - #assert: prev_usedby contains at least one other element. - } - - #whether copied or not - mark as open for extending. - set ::p::${IID}::_iface::o_open 1 - return $IID - } -} - -#params: old - old (shared) interface ID -# new - new interface ID -proc ::p::internals::linkcopy_interface {old new} { - #puts stderr " ** ** ** linkcopy_interface $old $new" - set ns_old ::p::${old}::_iface - set ns_new ::p::${new}::_iface - - - - foreach nsmethod [info commands ${ns_old}::*.1] { - #puts ">>> adding $nsmethod to iface $new" - set tail [namespace tail $nsmethod] - set method [string range $tail 0 end-2] ;#strip .1 - - if {![llength [info commands ${ns_new}::$method]]} { - - set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1 - - #link from new interface namespace to existing one. - #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...) - #!todo? verify? - #- actual link is chainslot to chainslot - interp alias {} ${ns_new}::$method.1 {} $oldhead - - #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head? - - - #chainhead pointer within new interface - interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1 - - namespace eval $ns_new "namespace export $method" - - #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} { - # lappend ${ns_new}::o_methods $method - #} - } else { - if {$method eq "(VIOLATE)"} { - #ignore for now - #!todo - continue - } - - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - #warning - existing chainslot will be completely shadowed by linked method. - # - existing one becomes unreachable. #!todo review!? - - - error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)" - - } - } - - - #foreach propinf [set ${ns_old}::o_properties] { - # lassign $propinf prop _default - # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop - # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop - # lappend ${ns_new}::o_properties $propinf - #} - - - set ${ns_new}::o_variables [set ${ns_old}::o_variables] - set ${ns_new}::o_properties [set ${ns_old}::o_properties] - set ${ns_new}::o_methods [set ${ns_old}::o_methods] - set ${ns_new}::o_constructor [set ${ns_old}::o_constructor] - - - set ::p::${old}::_iface::o_usedby(i$new) linkcopy - - - #obsolete.? - array set ::p::${new}:: [array get ::p::${old}:: ] - - - - #!todo - is this done also when iface compiled? - #namespace eval ::p::${new}::_iface {namespace ensemble create} - - - #puts stderr "copy_interface $old $new" - - #assume that the (usedby) data is now obsolete - #???why? - #set ${ns_new}::(usedby) [::list] - - #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' - - return -} -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -pattern::init - -return $::pattern::version +#PATTERN +# - A prototype-based Object system. +# +# Julian Noble 2003 +# License: Public domain +# + +# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern. +# +# +# Pattern uses a mixture of class-based and prototype-based object instantiation. +# +# A pattern object has 'properties' and 'methods' +# The system makes a distinction between them with regards to the access syntax for write operations, +# and yet provides unity in access syntax for read operations. +# e.g >object . myProperty +# will return the value of the property 'myProperty' +# >ojbect . myMethod +# will return the result of the method 'myMethod' +# contrast this with the write operations: +# set [>object . myProperty .] blah +# >object . myMethod blah +# however, the property can also be read using: +# set [>object . myProperty .] +# Note the trailing . to give us a sort of 'reference' to the property. +# this is NOT equivalent to +# set [>object . myProperty] +# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property +# i.e it is equivalent in this case to: set blah + +#All objects are represented by a command, the name of which contains a leading ">". +#Any commands in the interp which use this naming convention are assumed to be a pattern object. +#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined) + +#All user-added properties & methods of the wrapped object are accessed +# using the separator character "." +#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".." +# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype) +# you would use the 'Create' metamethod on the pattern object like so: +# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject +# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties +# of the object it was created from. ( + + +#The use of the access-syntax separator character "." allows objects to be kept +# 'clean' in the sense that the only methods &/or properties that can be called this way are ones +# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax +# so you are free to implement your own 'Create' method on your object that doesn't conflict with +# the metamethod. + +#Chainability (or how to violate the Law of Demeter!) +#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other +# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference +# structure, without the need to regress to enter matching brackets as is required when using +# standard TCL command syntax. +# ie instead of: +# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething +# we can use: +# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething +# +# This separates out the object-traversal syntax from the TCL command syntax. + +# . is the 'traversal operator' when it appears between items in a commandlist +# . is the 'reference operator' when it is the last item in a commandlist +# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'. +# It marks breaks in the multidimensional structure that correspond to how the data is stored. +# e.g obj . arraydata x y , x1 y1 z1 +# represents an element of a 5-dimensional array structured as a plane of cubes +# e.g2 obj . arraydata x y z , x1 y1 +# represents an element of a 5-dimensional array structured as a cube of planes +# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1 +# .. is the 'meta-traversal operator' when it appears between items in a commandlist +# .. is the 'meta-info operator'(?) when it is the last item in a commandlist + + +#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing +# implement iStacks & pStacks (interface stacks & pattern stacks) + +#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975 + + +#------------------------------------------------------------ +# System objects. +#------------------------------------------------------------ +#::p::-1 ::p::internals::>metaface +#::p::0 ::p::ifaces::>null +#::p::1 ::>pattern +#------------------------------------------------------------ + +#TODO + +#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?) + + +#CHANGES +#2018-09 - v 1.2.2 +# varied refactoring +# Changed invocant datastructure curried into commands (the _ID_ structure) +# Changed MAP structure to dict +# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns) +# updated test suites +#2018-08 - v 1.2.1 +# split ::p::predatorX functions into separate files (pkgs) +# e.g patternpredator2-1.0.tm +# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken +# +#2017-08 - v 1.1.6 Fairly big overhaul +# New predator function using coroutines +# Added bang operator ! +# Fixed Constructor chaining +# Added a few tests to test::pattern +# +#2008-03 - preserve ::errorInfo during var writes + +#2007-11 +#Major overhaul + new functionality + new tests v 1.1 +# new dispatch system - 'predator'. +# (preparing for multiple interface stacks, multiple invocants etc) +# +# +#2006-05 +# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature. +# +#2005-12 +# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top. +# +# Fixed so that PatternVariable default applied on Create. +# +# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE:::: +# - heading towards multiple-interface objects +# +#2005-10-28 +# 1.0.8.1 passes 80/80 tests +# >object .. Destroy - improved cleanup of interfaces & namespaces. +# +#2005-10-26 +# fixes to refsync (still messy!) +# remove variable traces on REF vars during .. Destroy +# passes 76/76 +# +#2005-10-24 +# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined. +# 1.0.8.0 now passes 75/76 +# +#2005-10-19 +# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before) +# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names) +# 1.0.8.0 (passes 74/76) +# tests now in own package +# usage: +# package require test::pattern +# test::p::list +# test::p::run ?nameglob? ?-version ? +# +#2005-09?-12 +# +# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc. +# fixed @next@ so that destination method resolved at interface compile time instead of call time +# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x. +# (before, the overlay only occured when '.. Method' was used to override.) +# +# +# miscellaneous tidy-ups +# +# 1.0.7.8 (passes 71/73) +# +#2005-09-10 +# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value +# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier. +# +#2005-09-07 +# bugfix indexed write to list property +# bugfix Variable default value +# 1.0.7.7 (passes 70/72) +# fails: +# arrayproperty.test - array-entire-reference +# properties.test - property_getter_filter_via_ObjectRef +# +#2005-04-22 +# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!) +# +# 1.0.7.4 +# +#2004-11-05 +# basic PropertyRead implementation (non-indexed - no tests!) +# +#2004-08-22 +# object creation speedups - (pattern::internals::obj simplified/indirected) +# +#2004-08-17 +# indexed property setter fixes + tests +# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values) +# +#2004-08-16 +# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset) +# +#2004-08-15 +# reference syncing: ensure writes to properties always trigger traces on property references (+ tests) +# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger +# - also trigger on curried traces to indexed properties i.e list and array elements. +# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties. +# +# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .] +# +#2004-08-05 +# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write) +# +# fix + add tests to support method & property of same name. (method precedence) +# +#2004-08-04 +# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var) +# +# 1.0.7.1 +# use objectref array access to read properties even when some props unset; + test +# unset property using array access on object reference; + test +# +# +#2004-07-21 +# object reference changes - array property values appear as list value when accessed using upvared array. +# bugfixes + tests - properties containing lists (multidimensional access) +# +#1.0.7 +# +#2004-07-20 +# fix default property value append problem +# +#2004-07-17 +# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods +# ( +# +#2004-06-18 +# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces. +# +#2004-06-05 +# change argsafety operator to be anything with leading - +# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-' +# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg, +# the entire dash-prefixed operator is also passed in as an argument. +# e.g >object . doStuff -window . +# will call the doStuff method with the 2 parameters -window . +# >object . doStuff - . +# will call doStuff with single parameter . +# >object . doStuff - -window . +# will result in a reference to the doStuff method with the argument -window 'curried' in. +# +#2004-05-19 +#1.0.6 +# fix so custom constructor code called. +# update Destroy metamethod to unset $self +# +#1.0.4 - 2004-04-22 +# bug fixes regarding method specialisation - added test +# +#------------------------------------------------------------ + +package provide pattern [namespace eval pattern {variable version; set version 1.2.4}] + + +namespace eval pattern::util { + + # Generally better to use 'package require $minver-' + # - this only gives us a different error + proc package_require_min {pkg minver} { + if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { + package require $pkg + } else { + error "Package pattern requires package $pkg of at least version $minver. Available: $available" + } + } +} + +package require patterncmd 1.2.4- +package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) + + + +#package require cmdline +package require overtype + +#package require md5 ;#will be loaded if/when needed +#package require md4 +#package require uuid + + + + + +namespace eval pattern { + variable initialised 0 + + + if 0 { + if {![catch {package require twapi_base} ]} { + #twapi is a windows only package + #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. + # If available - windows seems to provide a fast uuid generator.. + #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) + # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) + interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok + } else { + #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) + # (e.g 200usec 2018 corei9) + #(with or without tcllibc?) + #very first call is extremely slow though - 3.5seconds on 2018 corei9 + package require uuid + interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate + } + #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) + } + + +} + + + + + + +namespace eval p { + #this is also the interp alias namespace. (object commands created here , then renamed into place) + #the object aliases are named as incrementing integers.. !todo - consider uuids? + variable ID 0 + namespace eval internals {} + + + #!?? + #namespace export ?? + variable coroutine_instance 0 +} + +#------------------------------------------------------------------------------------- +#review - what are these for? +#note - this function is deliberately not namespaced +# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features +proc process_pattern_aliases {object args} { + set o [namespace tail $object] + interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] + interp alias {} process_method_$o {} [$object .. Method .] + interp alias {} process_constructor_$o {} [$object .. Constructor .] +} +#------------------------------------------------------------------------------------- + + + + +#!store all interface objects here? +namespace eval ::p::ifaces {} + + + +#K combinator - see http://wiki.tcl.tk/1923 +#proc ::p::K {x y} {set x} +#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] + + + + + + + + +proc ::p::internals::(VIOLATE) {_ID_ violation_script} { + #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] + set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] + + if {![dict get $processed explicitvars]} { + #no explicit var statements - we need the implicit ones + set self [set ::p::${_ID_}::(self)] + set IFID [lindex [set $self] 1 0 end] + #upvar ::p::${IFID}:: self_IFINFO + + + set varDecls {} + set vlist [array get ::p::${IFID}:: v,name,*] + set _k ""; set v "" + if {[llength $vlist]} { + append varDecls "upvar #0 " + foreach {_k v} $vlist { + append varDecls "::p::\${_ID_}::$v $v " + } + append varDecls "\n" + } + + #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] + set violation_script $varDecls\n[dict get $processed body] + + #tidy up + unset processed varDecls self IFID _k v + } else { + set violation_script [dict get $processed body] + } + unset processed + + + + + #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. + eval "unset violation_script;$violation_script" +} + + +proc ::p::internals::DestroyObjectsBelowNamespace {ns} { + #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" + + set nsparts [split [string trim [string map {:: :} $ns] :] :] + if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { + #ns not of form ::p::?::_ref + + foreach obj [info commands ${ns}::>*] { + #catch {::p::meta::Destroy $obj} + #puts ">>found object $obj below ns $ns - destroying $obj" + $obj .. Destroy + } + } + + #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] + #foreach tinfo $traces { + # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo + #} + #unset -nocomplain ${ns}::-->PATTERN_ANCHOR + + foreach sub [namespace children $ns] { + ::p::internals::DestroyObjectsBelowNamespace $sub + } +} + + + + +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# + + + + + + + + + +proc ::p::get_new_object_id {} { + tailcall incr ::p::ID + #tailcall ::pattern::new_uuid +} + +#create a new minimal object - with no interfaces or patterns. + +#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} +proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { + + #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" + + if {$OID eq "-2"} { + set OID [::p::get_new_object_id] + #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) + #set OID [pattern::new_uuid] + } + #if $wrapped provided it is assumed to be an existing namespace. + #if {[string length $wrapped]} { + # #??? + #} + + #sanity check - alias must not exist for this OID + if {[llength [interp alias {} ::p::$OID]]} { + error "Object alias '::p::$OID' already exists - cannot create new object with this id" + } + + #system 'varspaces' - + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://wiki.tcl.tk/1030 'Dangers of creative writing') + #set o_open 1 - every object is initially also an open interface (?) + #NOTE! comments within namespace eval slow it down. + namespace eval ::p::$OID { + #namespace ensemble create + namespace eval _ref {} + namespace eval _meta {} + namespace eval _iface { + variable o_usedby; + variable o_open 1; + array set o_usedby [list]; + variable o_varspace "" ; + variable o_varspaces [list]; + variable o_methods [dict create]; + variable o_properties [dict create]; + variable o_variables; + variable o_propertyunset_handlers; + set o_propertyunset_handlers [dict create] + } + } + + #set alias ::p::$OID + + #objectid alis default_method object_command wrapped_namespace + set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] + + #MAP is a dict + set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] + + + + #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token + #we've already checked that ::p::$OID doesn't pre-exist + # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias + #interp alias {} ::p::$OID {} ::p::internals::predator $MAP + + + # _ID_ structure + set invocants_dict [dict create this [list $INVOCANTDATA] ] + #puts stdout "New _ID_structure: $interfaces_dict" + set _ID_ [dict create i $invocants_dict context ""] + + + interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ + #rename the command into place - thus the alias & the command name no longer match! + rename ::p::$OID $cmd + + set ::p::${OID}::_meta::map $MAP + + # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something + interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ + + #set p2 [string map {> ?} $cmd] + #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ + + + #trace add command $cmd delete "$cmd .. Destroy ;#" + #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" + + trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" + #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) + + #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" + + + #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" + #trace add command $cmd delete "puts deleting$cmd ;#" + #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" + + + #puts "--> new_object returning map $MAP" + return $MAP +} + + + + +#>x .. Create >y +# ".." is special case equivalent to "._." +# (whereas in theory it would be ".default.") +# "." is equivalent to ".default." is equivalent to ".default.default." (...) + +#>x ._. Create >y +#>x ._.default. Create >y ??? +# +# + +# create object using 'blah' as source interface-stack ? +#>x .blah. .. Create >y +#>x .blah,_. ._. Create .iStackDestination. >y + + + +# +# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _] +# the 1st item, blah in this case becomes the 'default' iStack. +# +#>x .*. +# cast to object with all iStacks +# +#>x .*,!_. +# cast to object with all iStacks except _ +# +# --------------------- +#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@' +# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not. +# +#eg1: >x & >y . some_multi_method arg arg +# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects) +# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these' +# The invocant signature is thus {these 2} +# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1}) +# Invocation roles can be specified in the call using the @ operator. +# e.g >x & >y @ points . some_multi_method arg arg +# The invocant signature for this is: {points 2} +# +#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path +# This has the signature {objects n plane 1} where n depends on the length of the list $objects +# +# +# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration. +# e.g set pointset [>x & >y .] +# We can now call multimethods on $pointset +# + + + + + + +#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) +proc ::pattern::predatorversion {{ver ""}} { + variable active_predatorversion + set allowed_predatorversions {1 2} + set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions + + if {![info exists active_predatorversion]} { + set first_time_set 1 + } else { + set first_time_set 0 + } + + if {$ver eq ""} { + #get version + if {$first_time_set} { + set active_predatorversions $default_predatorversion + } + return $active_predatorversion + } else { + #set version + if {$ver ni $allowed_predatorversions} { + error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" + } + + if {!$first_time_set} { + if {$active_predatorversion eq $ver} { + #puts stderr "Active predator version is already '$ver'" + #ok - nothing to do + return $active_predatorversion + } else { + package require patternpredator$ver 1.2.4- + if {![llength [info commands ::p::predator$ver]]} { + error "Unable to set predatorversion - command ::p::predator$ver not found" + } + rename ::p::internals::predator ::p::predator$active_predatorversion + } + } + package require patternpredator$ver 1.2.4- + if {![llength [info commands ::p::predator$ver]]} { + error "Unable to set predatorversion - command ::p::predator$ver not found" + } + + rename ::p::predator$ver ::p::internals::predator + set active_predatorversion $ver + + return $active_predatorversion + } +} +::pattern::predatorversion 2 + + + + + + + + + + + + +# >pattern has object ID 1 +# meta interface has object ID 0 +proc ::pattern::init args { + + if {[set ::pattern::initialised]} { + if {[llength $args]} { + #if callers want to avoid this error, they can do their own check of $::pattern::initialised + error "pattern package is already initialised. Unable to apply args: $args" + } else { + return 1 + } + } + + #this seems out of date. + # - where is PatternPropertyRead? + # - Object is obsolete + # - Coinjoin, Combine don't seem to exist + array set ::p::metaMethods { + Clone object + Conjoin object + Combine object + Create object + Destroy simple + Info simple + Object simple + PatternProperty simple + PatternPropertyWrite simple + PatternPropertyUnset simple + Property simple + PropertyWrite simple + PatternMethod simple + Method simple + PatternVariable simple + Variable simple + Digest simple + PatternUnknown simple + Unknown simple + } + array set ::p::metaProperties { + Properties object + Methods object + PatternProperties object + PatternMethods object + } + + + + + + #create metaface - IID = -1 - also OID = -1 + # all objects implement this special interface - accessed via the .. operator. + + + + + + set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface + + + #OID = 0 + ::p::internals::new_object ::p::ifaces::>null "" 0 + + #? null object has itself as level0 & level1 interfaces? + #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]] + + #null interface should always have 'usedby' members. It should never be extended. + array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array + set ::p::0::_iface::o_open 0 + + set ::p::0::_iface::o_constructor [list] + set ::p::0::_iface::o_variables [list] + set ::p::0::_iface::o_properties [dict create] + set ::p::0::_iface::o_methods [dict create] + set ::p::0::_iface::o_varspace "" + set ::p::0::_iface::o_varspaces [list] + array set ::p::0::_iface::o_definition [list] + set ::p::0::_iface::o_propertyunset_handlers [dict create] + + + + + ############################### + # OID = 1 + # >pattern + ############################### + ::p::internals::new_object ::>pattern "" 1 + + #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] + + + array set ::p::1::_iface::o_usedby [list] ;#'usedby' array + + set _self ::pattern + + #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1 + #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1 + + + + #1)this object references its interfaces + #lappend ID $IFID $IFID_1 + #lset SELFMAP 1 0 $IFID + #lset SELFMAP 2 0 $IFID_1 + + + #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND] + #proc ::>pattern args $body + + + + + ####################################################################################### + #OID = 2 + # >ifinfo interface for accessing interfaces. + # + ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object + set ::p::2::_iface::o_constructor [list] + set ::p::2::_iface::o_variables [list] + set ::p::2::_iface::o_properties [dict create] + set ::p::2::_iface::o_methods [dict create] + set ::p::2::_iface::o_varspace "" + set ::p::2::_iface::o_varspaces [list] + array set ::p::2::_iface::o_definition [list] + set ::p::2::_iface::o_open 1 ;#open for extending + + ::p::ifaces::>2 .. AddInterface 2 + + #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations + #(bootstrap because we can't yet use metaface methods on it) + + + + proc ::p::2::_iface::isOpen.1 {_ID_} { + return $::p::2::_iface::o_open + } + interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1 + + proc ::p::2::_iface::isClosed.1 {_ID_} { + return [expr {!$::p::2::_iface::o_open}] + } + interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1 + + proc ::p::2::_iface::open.1 {_ID_} { + set ::p::2::_iface::o_open 1 + } + interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1 + + proc ::p::2::_iface::close.1 {_ID_} { + set ::p::2::_iface::o_open 0 + } + interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1 + + + #proc ::p::2::_iface::(GET)properties.1 {_ID_} { + # set ::p::2::_iface::o_properties + #} + #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1 + + #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties + + + #proc ::p::2::_iface::(GET)methods.1 {_ID_} { + # set ::p::2::_iface::o_methods + #} + #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1 + #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods + + + + + + #link from object to interface (which in this case are one and the same) + + #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --] + #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --] + #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --] + #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --] + + interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen + interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed + interp alias {} ::p::2::open {} ::p::2::_iface::open + interp alias {} ::p::2::close {} ::p::2::_iface::close + + + #namespace eval ::p::2 "namespace export $method" + + ####################################################################################### + + + + + + + set ::pattern::initialised 1 + + + ::p::internals::new_object ::p::>interface "" 3 + #create a convenience object on which to manipulate the >ifinfo interface + #set IF [::>pattern .. Create ::p::>interface] + set IF ::p::>interface + + + #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects? + # (or is forcing end user to add their own pStack/iStack ok .. ?) + # + ::p::>interface .. AddPatternInterface 2 ;# + + ::p::>interface .. PatternVarspace _iface + + ::p::>interface .. PatternProperty methods + ::p::>interface .. PatternPropertyRead methods {} { + varspace _iface + var {o_methods alias} + return $alias + } + ::p::>interface .. PatternProperty properties + ::p::>interface .. PatternPropertyRead properties {} { + varspace _iface + var o_properties + return $o_properties + } + ::p::>interface .. PatternProperty variables + + ::p::>interface .. PatternProperty varspaces + + ::p::>interface .. PatternProperty definition + + ::p::>interface .. Constructor {{usedbylist {}}} { + #var this + #set this @this@ + #set ns [$this .. Namespace] + #puts "-> creating ns ${ns}::_iface" + #namespace eval ${ns}::_iface {} + + varspace _iface + var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces + + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + set o_varspaces [list] + array set o_definition [list] + + foreach usedby $usedbylist { + set o_usedby(i$usedby) 1 + } + + + } + ::p::>interface .. PatternMethod isOpen {} { + varspace _iface + var o_open + + return $o_open + } + ::p::>interface .. PatternMethod isClosed {} { + varspace _iface + var o_open + + return [expr {!$o_open}] + } + ::p::>interface .. PatternMethod open {} { + varspace _iface + var o_open + set o_open 1 + } + ::p::>interface .. PatternMethod close {} { + varspace _iface + var o_open + set o_open 0 + } + ::p::>interface .. PatternMethod refCount {} { + varspace _iface + var o_usedby + return [array size o_usedby] + } + + set ::p::2::_iface::o_open 1 + + + + + uplevel #0 {pattern::util::package_require_min patternlib 1.2.4} + #uplevel #0 {package require patternlib} + return 1 +} + + + +proc ::p::merge_interface {old new} { + #puts stderr " ** ** ** merge_interface $old $new" + set ns_old ::p::$old + set ns_new ::p::$new + + upvar #0 ::p::${new}:: IFACE + upvar #0 ::p::${old}:: IFACEX + + if {![catch {set c_arglist $IFACEX(c,args)}]} { + #constructor + #for now.. just add newer constructor regardless of any existing one + #set IFACE(c,args) $IFACEX(c,args) + + #if {![info exists IFACE(c,args)]} { + # #target interface didn't have a constructor + # + #} else { + # # + #} + } + + + set methods [::list] + foreach nm [array names IFACEX m-1,name,*] { + lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) + } + + #puts " *** merge interface $old -> $new ****merging-in methods: $methods " + + foreach method $methods { + if {![info exists IFACE(m-1,name,$method)]} { + #target interface doesn't yet have this method + + set THISNAME $method + + if {![string length [info command ${ns_new}::$method]]} { + + if {![set ::p::${old}::_iface::o_open]} { + #interp alias {} ${ns_new}::$method {} ${ns_old}::$method + #namespace eval $ns_new "namespace export [namespace tail $method]" + } else { + #wait to compile + } + + } else { + error "merge interface - command collision " + } + #set i 2 ??? + set i 1 + + } else { + #!todo - handle how? + #error "command $cmd already exists in interface $new" + + + set i [incr IFACE(m-1,chain,$method)] + + set THISNAME ___system___override_${method}_$i + + #move metadata using subindices for delegated methods + set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) + set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) + set IFACE(mp-$i,$method) $IFACE(mp-1,$method) + + set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) + set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) + + + #set next [::p::next_script $IFID0 $method] + if {![string length [info command ${ns_new}::$THISNAME]]} { + if {![set ::p::${old}::_iface::o_open]} { + interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method + namespace eval $ns_new "namespace export $method" + } else { + #wait for compile + } + } else { + error "merge_interface - command collision " + } + + } + + array set IFACE [::list \ + m-1,chain,$method $i \ + m-1,body,$method $IFACEX(m-1,body,$method) \ + m-1,args,$method $IFACEX(m-1,args,$method) \ + m-1,name,$method $THISNAME \ + m-1,iface,$method $old \ + ] + + } + + + + + + #array set ${ns_new}:: [array get ${ns_old}::] + + + #!todo - review + #copy everything else across.. + + foreach {nm v} [array get IFACEX] { + #puts "-.- $nm" + if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { + set IFACE($nm) $v + } + } + + #!todo -write a test + set ::p::${new}::_iface::o_open 1 + + #!todo - is this done also when iface compiled? + #namespace eval ::p::$new {namespace ensemble create} + + + #puts stderr "copy_interface $old $new" + + #assume that the (usedby) data is now obsolete + #???why? + #set ${ns_new}::(usedby) [::list] + + #leave ::(usedby) reference in place + + return +} + + + + +#detect attempt to treat a reference to a method as a property +proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { +#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args" + lassign [lrange $args end-2 end] vtraced vidx op + #NOTE! cannot rely on vtraced as it may have been upvared + + switch -- $op { + write { + error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])" + } + unset { + #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace + #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] + + #!todo - don't use vtraced! + trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] + + #pointless raising an error as "Any errors in unset traces are ignored" + #error "cannot unset. $field is a method not a property" + } + read { + error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])" + } + array { + error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])" + #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args" + } + } + + return +} + + + + +#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points. +# +# The 'dispatcher' is an object instance's underlying object command. +# + +#proc ::p::make_dispatcher {obj ID IFID} { +# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] { +# ::p::@IID@ $methprop @oid@ {*}$args +# }] +# return +#} + + + + +################################################################################################################################################ +################################################################################################################################################ +################################################################################################################################################ + +#aliased from ::p::${OID}:: +# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something +proc ::p::internals::no_default_method {_ID_ args} { + puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'" + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped + tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)" +} + +#force 1 will extend an interface even if shared. (??? why is this necessary here?) +#if IID empty string - create the interface. +proc ::p::internals::expand_interface {IID {force 0}} { + #puts stdout ">>> expand_interface $IID [info level -1]<<<" + if {![string length $IID]} { + #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) + set iid [expr {$::p::ID + 1}] + ::p::>interface .. Create ::p::ifaces::>$iid + return $iid + } else { + if {[set ::p::${IID}::_iface::o_open]} { + #interface open for extending - shared or not! + return $IID + } + + if {[array size ::p::${IID}::_iface::o_usedby] > 1} { + #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby + + #oops.. shared interface. Copy before specialising it. + set prev_IID $IID + + #set IID [::p::internals::new_interface] + set IID [expr {$::p::ID + 1}] + ::p::>interface .. Create ::p::ifaces::>$IID + + ::p::internals::linkcopy_interface $prev_IID $IID + #assert: prev_usedby contains at least one other element. + } + + #whether copied or not - mark as open for extending. + set ::p::${IID}::_iface::o_open 1 + return $IID + } +} + +#params: old - old (shared) interface ID +# new - new interface ID +proc ::p::internals::linkcopy_interface {old new} { + #puts stderr " ** ** ** linkcopy_interface $old $new" + set ns_old ::p::${old}::_iface + set ns_new ::p::${new}::_iface + + + + foreach nsmethod [info commands ${ns_old}::*.1] { + #puts ">>> adding $nsmethod to iface $new" + set tail [namespace tail $nsmethod] + set method [string range $tail 0 end-2] ;#strip .1 + + if {![llength [info commands ${ns_new}::$method]]} { + + set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1 + + #link from new interface namespace to existing one. + #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...) + #!todo? verify? + #- actual link is chainslot to chainslot + interp alias {} ${ns_new}::$method.1 {} $oldhead + + #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head? + + + #chainhead pointer within new interface + interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1 + + namespace eval $ns_new "namespace export $method" + + #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} { + # lappend ${ns_new}::o_methods $method + #} + } else { + if {$method eq "(VIOLATE)"} { + #ignore for now + #!todo + continue + } + + #!todo - handle how? + #error "command $cmd already exists in interface $new" + + #warning - existing chainslot will be completely shadowed by linked method. + # - existing one becomes unreachable. #!todo review!? + + + error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)" + + } + } + + + #foreach propinf [set ${ns_old}::o_properties] { + # lassign $propinf prop _default + # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop + # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop + # lappend ${ns_new}::o_properties $propinf + #} + + + set ${ns_new}::o_variables [set ${ns_old}::o_variables] + set ${ns_new}::o_properties [set ${ns_old}::o_properties] + set ${ns_new}::o_methods [set ${ns_old}::o_methods] + set ${ns_new}::o_constructor [set ${ns_old}::o_constructor] + + + set ::p::${old}::_iface::o_usedby(i$new) linkcopy + + + #obsolete.? + array set ::p::${new}:: [array get ::p::${old}:: ] + + + + #!todo - is this done also when iface compiled? + #namespace eval ::p::${new}::_iface {namespace ensemble create} + + + #puts stderr "copy_interface $old $new" + + #assume that the (usedby) data is now obsolete + #???why? + #set ${ns_new}::(usedby) [::list] + + #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' + + return +} +################################################################################################################################################ +################################################################################################################################################ +################################################################################################################################################ + +pattern::init + +return $::pattern::version diff --git a/src/vendormodules/tomlish-1.1.6.tm b/src/vendormodules/tomlish-1.1.6.tm index 7abbaeae..d7d1f131 100644 --- a/src/vendormodules/tomlish-1.1.6.tm +++ b/src/vendormodules/tomlish-1.1.6.tm @@ -2012,6 +2012,8 @@ namespace eval tomlish { #updatables #review - type changes from existing value?? set sourcedata [lindex $source_d_elements $arridx] + #todo - what happens when less source elements than in existing array? ie sourcedata is empty. + # switch -- $arrchild_type { STRING - LITERAL - FLOAT - INT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { #basic types - no recursion needed @@ -2036,7 +2038,7 @@ namespace eval tomlish { } ITABLE - ARRAY { #recurse - puts stderr "update $tomlish_type within array" + puts stderr "update $arrchild_type within array" set nextd [tomlish::dict::path::get $d $arridx] set subrecord_tomlish [list $arrchild] set newsubrecord_tomlish [update_tomlish_from_dict $subrecord_tomlish $nextd] @@ -9240,8 +9242,15 @@ namespace eval tomlish::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval tomlish::system { + #*** !doctools + #[subsection {Namespace tomlish::system}] + #[para] + #[list_begin definitions] + + #taken from punk::lib + #todo - change list argument to integer length proc lindex_resolve_basic {list index} { #*** !doctools #[call [fun lindex_resolve_basic] [arg list] [arg index]] @@ -9360,6 +9369,8 @@ namespace eval tomlish::system { } } + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::system ---}] } if {[info exists ::argc] && $::argc > 0} { diff --git a/src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl b/src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl index ee01e7a9..3474eff0 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl @@ -47,7 +47,20 @@ package require punk::repl repl::init -safe 0 #puts stderr "Launching repl::start stdin -title app-punk" #flush stderr -repl::start stdin -title app-punk +set replresult [repl::start stdin -title app-punk] + +catch { + puts "app-punk ifneeded: [package ifneeded app-punk 1.0]" +} +#review +if {[string is integer -strict $replresult]} { + puts stdout "repl.tcl exiting with numeric code $replresult" + exit $replresult +} else { + puts stdout "repl.tcl result $replresult" + flush stdout + exit 0 +} #puts "- repl app done -" #flush stdout diff --git a/src/vfs/_vfscommon.vfs/lib/kettle1/kettle.tcl b/src/vfs/_vfscommon.vfs/lib/kettle1/kettle.tcl index 3eb2fac7..68fba117 100644 --- a/src/vfs/_vfscommon.vfs/lib/kettle1/kettle.tcl +++ b/src/vfs/_vfscommon.vfs/lib/kettle1/kettle.tcl @@ -27,7 +27,7 @@ # # ## ### ##### ######## ############# ##################### ## Requisites -package require Tcl 8.5 +package require Tcl 8.5- namespace eval ::kettle {} # # ## ### ##### ######## ############# ##################### diff --git a/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm index 7b761812..d13899ac 100644 --- a/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm @@ -65,39 +65,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval picalc::class { - #*** !doctools - #[subsection {Namespace picalc::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 picalc { @@ -502,18 +469,6 @@ tcl::namespace::eval picalc::lib { -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval picalc::system { - #*** !doctools - #[subsection {Namespace picalc::system}] - #[para] Internal functions that are not part of the API - - - -#} - # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm index f2b3c002..93fcfe6d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm @@ -222,7 +222,7 @@ package require Tcl 8.6- tcl::namespace::eval punk::args::register { #*** !doctools - #[subsection {Namespace punk::args}] + #[subsection {Namespace punk::args::register}] #[para] cooperative namespace punk::args::register #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm index 5eb1a6ea..562bddd4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm @@ -2629,7 +2629,7 @@ tcl::namespace::eval punk::args::tclcore { "Search for files which match the given patterns starting in the given ${$I}directory${$NI}. This allows searching of directories whose name contains glob-sensitive characters without the need to quote such characters explicitly. This option may not be used - in conjunction with ${$B}-path${$NI}, which is used to allow searching for complete file + in conjunction with ${$B}-path${$N}, which is used to allow searching for complete file paths whose names may contain glob-sensitive characters." -join -type none -help\ "The remaining pattern arguments, after option processing, are treated as a single diff --git a/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm index cea2d287..f3808c15 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm @@ -40,15 +40,30 @@ namespace eval punk::docgen { set data [string map [list \r\n \n] $data] set in_doctools 0 set doctools "" + #foreach ln [split $data \n] { + # set ln [string trim $ln] + # if {$in_doctools && [string index $ln 0] != "#"} { + # set in_doctools 0 + # } elseif {[string range $ln 0 1] == "#*"} { + # #todo - process doctools ordering hints in tail of line + # set in_doctools 1 + # } elseif {$in_doctools} { + # append doctools [string range $ln 1 end] \n + # } + #} foreach ln [split $data \n] { set ln [string trim $ln] - if {$in_doctools && [string index $ln 0] != "#"} { - set in_doctools 0 - } elseif {[string range $ln 0 1] == "#*"} { - #todo - process doctools ordering hints in tail of line - set in_doctools 1 - } elseif {$in_doctools} { - append doctools [string range $ln 1 end] \n + if {$in_doctools} { + if {[string index $ln 0] != "#"} { + set in_doctools 0 + } else { + append doctools [string range $ln 1 end] \n + } + } else { + if {[string range $ln 0 1] == "#*" && [string first "!doctools" $ln] >=2} { + #todo - process doctools ordering hints in tail of line + set in_doctools 1 + } } } return $doctools diff --git a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm index f11fbac8..60f0bb7d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm @@ -1,6 +1,6 @@ # -*- 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 +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm # # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -99,7 +99,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::imap4 0 0.9] +#[manpage_begin punkshell_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 --}] @@ -117,6 +117,15 @@ #[para] - tcl::namespace::eval punk::imap4 { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id "(package)punk::imap4" + @package -name "punk::imap4"\ + -title "IMAP4 client library"\ + -description "An implementation of IMAP4 (rev1+?) client protocol."\ + -copyright "2025" + }] + if {[info exists ::argv0] && [info script] eq $::argv0} { #assert? - if argv0 exists and is same as [info script] - we're not in a safe interp #when running a tm module as an app - we should calculate the corresponding tm path @@ -173,7 +182,7 @@ package require Tcl 8.6.2- package require punk::args package require punk::lib #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6.2-}] #[item] [package {punk::args}] #[item] [package {punk::lib}] @@ -189,38 +198,6 @@ package require punk::lib #*** !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 @@ -4243,19 +4220,6 @@ tcl::namespace::eval 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 # == === === === === === === === === === === === === === === @@ -4264,12 +4228,6 @@ tcl::namespace::eval punk::imap4 { 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 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm index 1b15d45a..3b5d35b0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[manpage_begin shellspy_module_punk::libunknown 0 0.1] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index 33d17404..afd06d2a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -1083,20 +1083,28 @@ namespace eval punk::mix::cli { switch -- $calltype { lib {} shell { - set kettleappfile [file dirname [info nameofexecutable]]/kettle - set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat - - if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { - error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" - } - if {[file exists $kettleappfile]} { - set kettlescript $kettleappfile - } - if {$::tcl_platform(platform) eq "windows"} { - if {[file exists $kettlebatfile]} { - set kettlescript $kettlebatfile - } + #on windows - could be kettle.bat or kettle.cmd - use auto_execok to find, whatever the platform. + #for now, restrict to version sitting next to exe - REVIEW + set exedir [file dirname [info nameofexecutable]] + set kettlescript [auto_execok $exedir/kettle] + if {$kettlescript eq ""} { + error "kettle_call unable to find installed kettle application file in '$exedir'" } + + #set kettleappfile [file dirname [info nameofexecutable]]/kettle + #set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + #if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + # error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" + #} + #if {[file exists $kettleappfile]} { + # set kettlescript $kettleappfile + #} + #if {$::tcl_platform(platform) eq "windows"} { + # if {[file exists $kettlebatfile]} { + # set kettlescript $kettlebatfile + # } + #} } default { error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm index 8abe694e..d0dd3eb0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm @@ -776,33 +776,70 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc cd {{glob {}} args} { - dict set args -cd 1 - work $glob {*}$args + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." } - proc work {{glob {}} args} { + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received package require sqlite3 - set db_projects [lib::get_projects $glob] + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} if {[llength $db_projects] == 0} { - puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" return "" } - #list of lists of the form: - #{fosdb fname workdirlist} - set defaults [dict create\ - -cd 0\ - -detail "\uFFFF"\ - ] - set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- - set opt_cd [dict get $opts -cd] + set opt_cd [dict exists $received -cd] # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] - set opt_detail_explicit_zero 1 ;#default assumption only - if {$opt_detail eq "\uFFFF"} { + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { set opt_detail_explicit_zero 0 - set opt_detail 0; #default } + set opt_prompt [dict exists $received -prompt] # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] @@ -991,7 +1028,7 @@ namespace eval punk::mix::commandset::project { set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { puts stdout $msg - if {$numrows == 1} { + if {$numrows == 1 && !$opt_prompt} { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { @@ -1014,6 +1051,30 @@ namespace eval punk::mix::commandset::project { } return $msg } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } @@ -1029,12 +1090,17 @@ namespace eval punk::mix::commandset::project { @id -id ::punk::mix::commandset::project::lib::get_projects @cmd -name punk::mix::commandset::project::lib::get_projects\ -summary\ - "List projects referred to by central fossil config-db."\ + "Return a 3-element list of projects referred to by central fossil config-db."\ -help\ - "Get project info only by opening the central fossil config-db - (will not have proper project-name etc)" + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." @values -min 0 -max -1 - glob -type string -multiple 1 -default * -optional 1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." } proc get_projects {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] @@ -1048,6 +1114,9 @@ namespace eval punk::mix::commandset::project { ::sqlite3 fosconf $configdb #set testresult [fosconf eval {select name,value from global_config;}] #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { @@ -1064,7 +1133,7 @@ namespace eval punk::mix::commandset::project { } set filtered_list [list] foreach glob $globlist { - set matches [lsearch -all -inline -index 1 $paths_and_names $glob] + set matches [lsearch -nocase -all -inline -index 1 $paths_and_names $glob] foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm index 277e386e..15dc9187 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm @@ -41,11 +41,27 @@ namespace eval punk::mix::commandset::repo { return $result } + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::fossilize + @cmd -name punk::mix::commandset::repo::fossilize + -summary\ + "Initialise and check in a project to fossil (unimplemented)."\ + -help\ + "(unimplemented)" + }] proc fossilize { args} { #check if project already managed by fossil.. initialise and check in if not. puts stderr "unimplemented" } + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::unfossilize + @cmd -name punk::mix::commandset::repo::unfossilize + -summary\ + "Remove/archive .fossil (unimplemented)."\ + -help\ + "(unimplemented)" + }] proc unfossilize {projectname args} { #remove/archive .fossil puts stderr "unimplemented" @@ -76,14 +92,27 @@ namespace eval punk::mix::commandset::repo { #punk::args lappend PUNKARGS [list { @id -id ::punk::mix::commandset::repo::fossil-move-repository - @cmd -name punk::mix::commandset::repo::fossil-move-repository -help\ + @cmd -name punk::mix::commandset::repo::fossil-move-repository + -summary\ + "Move a fossil repository database file."\ + -help\ "Move the fossil repository file (usually named with .fossil extension). This is an interactive function which will prompt for answers on stdin before proceeding. The move can be done even if there are open checkouts and will maintain - the link between checkout databases and the repository file." + the link between checkout databases and the repository file. + + The call can be made from within a folder containing fossil databases, + or from within one of the checkouts of the fossil database that is to + be moved. + " + + #todo? + #@values -min 0 -max 1 + #path }] proc fossil-move-repository {{path ""}} { + #path unused for now - todo - allow calling with a specific target rather than relying on cwd? set searchbase [pwd] set projectinfo [punk::repo::find_repos $searchbase] set projectbase [dict get $projectinfo closest] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 24168483..4f1af2bc 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -77,7 +77,7 @@ namespace eval punk::mix::commandset::scriptwrap { #[para] Core API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - namespace export * + namespace export {[a-z]*} namespace eval fileline { namespace import ::punk::fileline::lib::* diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index fd84ec8d..731e263e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm @@ -522,7 +522,14 @@ proc repl::start {inchan args} { 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" + set donevalue [set [namespace current]::done] + if {[lindex $donevalue 0] eq "quit"} { + puts "-->repl::start end $inchan $args result:'$donevalue'" + puts stderr "--> returning [lindex $donevalue 1]" + return [lindex $donevalue 1] + } + puts "-->repl::start end $inchan $args result:'$donevalue'" + puts stderr "__> returning 0" return 0 } proc repl::post_operations {} { @@ -570,7 +577,7 @@ proc repl::reopen_stdin {} { #todo - avoid putting this in gobal namespace? #collisions with other libraries apps? proc punk::repl::quit {args} { - set ::repl::done "quit {*}$args" + set ::repl::done [list quit {*}$args] #puts stderr "quit called" return "" ;#make sure to return nothing so "quit" doesn't land on stdout } @@ -800,8 +807,7 @@ proc repl::rputs {args} { } } 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]]" + #review - string shouldn't be truncated prior to ansistrip - could chop ansi codes! 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} { @@ -1610,6 +1616,8 @@ proc repl::repl_handler {inputchan prompt_config} { if {![llength $input_chunks_waiting($inputchan)]} { chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] } else { + #review + #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" after idle [list ::repl::repl_handler $inputchan $prompt_config] } #################################################### @@ -2695,6 +2703,7 @@ namespace eval repl { proc init {args} { + puts stderr "-->repl::init $args" if {![info exists ::argv0]} { #error out before we create a thread - punk requires this - review error "::argv0 not set" @@ -2900,7 +2909,7 @@ namespace eval repl { 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] + thread::send -async %replthread% [list interp eval %replthread_interp% [list ::punk::repl::quit {*}$args]] } proc editbuf args { thread::send %replthread% [list punk::repl::editbuf {*}$args] @@ -3623,6 +3632,7 @@ namespace eval repl { #temporary debug aliases - deliberate violation of safety provided by safe interp code alias escapeeval ::repl::interphelpers::escapeeval + code alias exit ::repl::interphelpers::quit #experiment #code alias ::shellfilter::stack ::shellfilter::stack diff --git a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm index 466f6a86..ff345623 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm @@ -63,38 +63,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::safe::class { - #*** !doctools - #[subsection {Namespace punk::safe::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 ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace diff --git a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm index 6da53230..9136b650 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm @@ -69,38 +69,6 @@ package require punk::ansi #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::sixel::class { - #*** !doctools - #[subsection {Namespace punk::sixel::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 ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #reading #https://www.reddit.com/r/linux/comments/t3m7zm/quick_roundup_of_bitmap_graphics_availability_in/ @@ -122,20 +90,6 @@ tcl::namespace::eval punk::sixel { - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - - #terminated by ST #some older terminals may terminate at first other esc encountered. #non-sixel characters ignored (? review) @@ -286,12 +240,6 @@ tcl::namespace::eval punk::sixel::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 - #} proc ascii_to_sixelvalue {a} { set dec [scan $a %c] if {$dec < 63 || $dec > 127} {error "ascii character to convert to sixel value must be from 63 to 126 (chars '?' through to '~')"} diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm index 9aa98332..6c446aa3 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm @@ -152,65 +152,6 @@ namespace eval shellfilter::pipe { } - -namespace eval shellfilter::ansi { - #maint warning - - #ansistrip from punk::ansi is better/more comprehensive - proc stripcodes {text} { - #obsolete? - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. - #line endings can theoretically occur within an ansi escape sequence (review e.g title?) - set inputlist [split $text ""] - set outputlist [list] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_dict] - - set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls - set i 0 - foreach u $inputlist { - set v [lindex $inputlist $i+1] - set uv ${u}${v} - if {$in_escapesequence eq "2b"} { - #2nd byte - done. - set in_escapesequence 0 - } elseif {$in_escapesequence != 0} { - set escseq [dict get $escape_terminals $in_escapesequence] - if {$u in $escseq} { - set in_escapesequence 0 - } elseif {$uv in $escseq} { - set in_escapseequence 2b ;#flag next byte as last in sequence - } - } else { - #handle both 7-bit and 8-bit CSI and OSC - if {[regexp {^(?:\033\[|\u009b)} $uv]} { - set in_escapesequence CSI - } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { - set in_escapesequence OSC - } elseif {$uv in $2bytecodes} { - #self-contained e.g terminal reset - don't pass through. - set in_escapesequence 2b - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - -} namespace eval shellfilter::chan { set testobj ::shellfilter::chan::var if {$testobj ni [info commands $testobj]} { @@ -2851,8 +2792,10 @@ namespace eval shellfilter { - + #chan configure $inchan -buffering none -blocking 1 ;test chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + + chan configure $errchan -buffering $errbuffering #chan configure $outchan -blocking 0 chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. @@ -2889,7 +2832,9 @@ namespace eval shellfilter { # - and that at least appears like a terminal to the called command. #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - + #REVIEW! + #if the child process takes a while to begin reading stdin - the data on stdin between when we stopped the parent chan event handler and when the child gets data, + #seems to stay buffered somewhere. It is then read by the parent, after the child returns. (ie not lost, but out-of-order) set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] chan configure $rderr -buffering $errbuffering -blocking 0 diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm index a27a15a145a45c92a50c456c749fee3373220e91..3671acbed2043618badf069cdd2d7c5030e3c9f2 100644 GIT binary patch delta 2347 zcmV+`3Dowzg#o>V0kGE@6CHv6TJ6|ac)bV!0OcJ303ZMclVL#~PA+t9|NjC200FgG zZFAeW5&o`Uv6VFA#CMdP>s+VRy-a+*%uU+b&79qSaWoo;ge06PkRd?Xibnsv&w?OD zijreHK8_tlAoc~j&%VKvQyM0J{{DV&Pr{HgBy>c%k(B28*34xb(@`Xsv=F!Qh?0yZ zN}upMULdjw%As4ijyER3tN~uk?%r z{c`myYkcwknv7jRe5^vLv2%*mStePU1=%7MR!vl_?27J`ojcQ9!;Ugc%*sIa08-AA zNP5<3CZ{sXWaM^vu7*OPX(CC+YNjS}Ax7yi&e;(7AMcLU{aXpA}qN?zwV7Dhzh9V-*8e$%qO5Khi*f4LXRB#TMVeM(~ z{a&bSoz6Do3;%I0`TO8+L0btX8qrNju=YCvr#%`w zVNi7RVlD;tSyHEiY%m;Zpx!_gIULHRh}+p@-C;C8Np?Yh@C#@0iv2UWG!NmH>P}o= zmi$|a!<@zT!m;N`=E9z)xpuV1CG^&DJyFfak(?^690}~kua_cIE;oGm@8!SFe*f)i zXBlO)jhn^}Urybkk+%HqQ@2~*#gqSj4ZijF*G>+XZ$4b>IQ^3IcI^l1-6=EzrGPX` zmMFA`X`A|gz-lvSymPXaw%ga8&S6(p=x(ITz$M6<-M27mYZ9Q4LE zNmXdt%z8>s6CO&?(V}n5q{(A6k{lR?9CR6q+f6J@l+8H9pu@x1^D0&t$wZck6`}7l zuN!>1XgHZ;VBXM8Q_RiQG+~a(M%&SFh^$?Is5w3!wRkm7;b79-0}D$L&S^^hn%L%9 zE4_q@>ngbK{pqN+xx{BvI7VCUhclr8uztbJufrvlFKa*s$&F=R$+idm5HQ+Pp{vZO`(Kynisj@N$u1fxSpX$o{$sn~FT zT-Jw#?_T>QpyC zE0U;Qg)ndrhZd-)pn-o;->8MLGE*H4=kl>tYTC(6O>ogiebB+%lle4g#eT`n)=cJ5xTfBYjyZP9PjOoqy+d@(?} z`I-LdR_QW98QN@G^kH2>x4So|2*gh*rsWo&A{u=90$z9^<`K#35*G?H-aYjj^e$(} zPt^UWyPE?^tU<7olN#?%nO*Q^^ngCzTMfD|JEtgUf&0>S&i-f!yeO}4`)Fr>zD~AY za0IZVeJ}7x8y+~|=0&rD&w4$&;{qA*)g?EL+p1m-1;rI*qcydHTl8pLBrU$e;meAQ zhZ~ci)brqNs+p^N2lqxQgvZ?#V&O-((A?zuq`);x-F;E#gmw>7hl}V?t5nj`!^GT9 zHPhYAeh{n=_|PMu$mo0L-b2rSW>lrUJ?a$*4Z?YXtY_+1U`4xmyt&zPWY^C5qnDMF zjvprkZ4?X;S~O4e<_i?Q>e2%`Gz;?xO*t}1MTiyvInOZqj@*tTa`Ur@@5IWu1SR-p zn5P`RG&(}JnoBektW$+HE$_gv=`wIl;-!qn{3Z~X0cLSB!AM&+sD*KVww+W^;kmy( zXY)*+v=t5BvIjX<4lxkUP9v|bYgZ|&E zqMwV7H+?6W!_BG3w={jPhqKhkXIQ=~@i)+B|NQ)w6Ee^B!Am~i=gQ~|SVdD_8RV6D z&0v`GAHYgPf4e&iS5vY9?qqliXZ$JZwMX>c!!!EMfZKFyby$C5XTz0{LBFC;IT%b8 z!o(zeZ;VM-8hvC5l`$fD4>AscWs#IPqkwty9=6N^`$Z0imuDC6u0EWdzq{H4IftK@ zwcm68C?KL$=ZjaEH&3~&d9nN3&8SoKVV%Q&*($E|{|}SRA{+q*lVL$GlNlom1Ofm6 z0kbC~wF?0SlVL$GlMF8o0|5X4vmY-y5DguH{#xzWSa`h%008BaWV0kGE@6PL2|T1)Vnro0FM0P7t903ZMclVL#~OD=S6|NjC200FgG z?Qh$-8UOCT;+btAZSLfxH{7uKUeH{wICNXG;F9f2Y8bRc+q}q>DpF2d!~gq!4@Fs$ zWv5M=6OuS0`Mkf=lU5ogf8pU_@IbJ{CO%q8nRx>q;3o=TFan6dse|$PtlW*zf4j)d_Oo;`hRD^e8CMlC? zVw6p?71R9Y8~l9He=iQdI)6>yoqqSd)5+VnbRjKtAZJSB{VYwvr(g#l7JE2kvcsXs zW`<4&ZwBA9$1nuz8JsVOA9z!_UMkN$&}ogxI~{d8Ph~esLYpM9p}7>W+7rQ#kB{ju zC5le(b|G{M{f#Fq@7BA#yNufs7c!3k87Ao}Q?t3HE^DvLe`{9RSVq!>w7w`j_w4HZ zW<-S3i-pvd)QU&s4}J>XVE{olX_MZhJCe1yt+qRz!=~JNcOzW}EJspah&&4Z3awsJmH zdG()4^-u)AM>)#0h>^CwD29i_qVFkV`T0RrV%iC=lA&5~**WT*fG6k#<4F>czZ> zLH3E>#_8jypYZd%Up9+CBPr=fOp@FlZOIpXe_zc>AZ*UwCQ!xt zRs^3$#~Y#_xD(ark&9m5?+b)yoZQPSL=HWWa`vu{MXUf~ija#%$~A7gOD^6#YvuD+ zMeZ}eXZMwlsUPE!yiKU6M8Rr@Fc^H0P#R`L&$TG1abbsb`122~j zM{^9%H+0)1b6cq<%rW0+I~op=y9+kQf5)R1u7(uOS(;~{VJX5nO{rfa+mv<7mr!w? z1^3>cj#`IHFKrUXfXiKRCN$ioUm){qvD7n!cO}V)TnTAl-ZTwx7X1OwKmx){yv-8u z7fi!b0b_W&N2I10H6t~}M9BVASV5Vxutocvf)J0=T8p5qs1$f>2`sjh%lBvHK< zVeB3bExcmu8u*JUM=c*K^VPv{E+2P?U~*-PbaLS2hCb+n2CgLex1X^OC6_Md?(XN& z{Li;=2hsGQg;t^V&D$5?M*)J~e)il~MU(fOPXS z{nM?|WrAX~*|gxpI)!d`Z%z@2pOQ?=EIvgv@bm?&@JP%flGmkQC`@_})NjDMoFP9_ z_k-?k4kWP#z)ntT?42^Y;LYd}e!R6BaGy6$QP2YS(l*ZiXb3zh&u?3_e=}bvTN@k! zOljW+9%;h^0&ZS3EBLI}qkArp0bgKp>sVFw?PyS3R5lt^E4WdQ#zoTNiyXeP$aust z2}(VW-)1{`m3uI6q(WHST_hHEbPLTxu3HLR%hcT$b&hEFAauBh4mC_AEIkg)O;t19 z-R^gS^#L1t4=6JF-s$(yf3q2F)7~ET3J(p!d4jBG>K9=}(|NqP-6OJV=e+1;<)q^; zBZ4*x3J5KlCwlW42w!#S5gwX_d4$#+8DtBH763WVu=gFg6G!BxXc6Cwm2nA5@cl5) zI(&6>gl;vLXegMct+#1;4}?vV0c#R3Wi;lUKwuJ>#mNMNZP}m}f6A#ksbK5R{YuWJ zOdhlq4PLVc27`XVUU8;sYiaH7Q)(Xd$h5yr1G{k;y1PJbGhE=JmoHt#-NO`SBBVtQ zdM%+sG$K0578q$hA@=nO+)OgLRKib~3Az_ppa6A2HIZCRz@Bjz`?ZeWRWTU4sd{HC z6cToQ9vKnW2ZOpwf9)}&pJ|^k3OhR_s3+stU4I)&SXjR|MzNG?S!*7@#8wCGzn4Wn z7aecB^JNJ^YhfV_DdTV{d%B!|Pxvx|4vS7+z%uJ^c{^PiX1 z-*dhi5Yejh*^A8Er(D^**e&j6)G7L~&f)L3ii`dK1C!1o903KBVL>mG8Y2q>0RRBA zDI>KD0SA*|K`)aIFAfC*00033vmY-y5Dk~I^jb^snx?!6008TgW= 0} { - #return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] set max [tcl::mathfunc::max {*}$widths] set min [tcl::mathfunc::min {*}$widths] diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm index 7abbaeae..d7d1f131 100644 --- a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm @@ -2012,6 +2012,8 @@ namespace eval tomlish { #updatables #review - type changes from existing value?? set sourcedata [lindex $source_d_elements $arridx] + #todo - what happens when less source elements than in existing array? ie sourcedata is empty. + # switch -- $arrchild_type { STRING - LITERAL - FLOAT - INT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { #basic types - no recursion needed @@ -2036,7 +2038,7 @@ namespace eval tomlish { } ITABLE - ARRAY { #recurse - puts stderr "update $tomlish_type within array" + puts stderr "update $arrchild_type within array" set nextd [tomlish::dict::path::get $d $arridx] set subrecord_tomlish [list $arrchild] set newsubrecord_tomlish [update_tomlish_from_dict $subrecord_tomlish $nextd] @@ -9240,8 +9242,15 @@ namespace eval tomlish::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval tomlish::system { + #*** !doctools + #[subsection {Namespace tomlish::system}] + #[para] + #[list_begin definitions] + + #taken from punk::lib + #todo - change list argument to integer length proc lindex_resolve_basic {list index} { #*** !doctools #[call [fun lindex_resolve_basic] [arg list] [arg index]] @@ -9360,6 +9369,8 @@ namespace eval tomlish::system { } } + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::system ---}] } if {[info exists ::argc] && $::argc > 0} {