diff --git a/src/make.tcl b/src/make.tcl index 8f9174d3..9ae26516 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -1760,9 +1760,10 @@ if {$::punkboot::command eq "vendorupdate"} { set vendor_config $sourcefolder/vendormodules$which/include_modules.config ;#todo - change to toml if {[file exists $vendor_config]} { set targetroot $sourcefolder/vendormodules$which + set local_modules [list] source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list if {![llength $local_modules]} { - puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)" + puts stderr "\nsrc/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)" } else { if {[catch { #---------- @@ -1775,10 +1776,15 @@ if {$::punkboot::command eq "vendorupdate"} { set installation_event "" } #todo - sync alg with bootsupport_localupdate! - foreach {relpath requested_module} $local_modules { + foreach {localpath requested_module} $local_modules { set requested_module [string trim $requested_module :] set module_subpath [string map {:: /} [namespace qualifiers $requested_module]] - set srclocation [file join $projectroot $relpath $module_subpath] + if {[file pathtype $localpath] eq "relative"} { + #This would actually work for absolute paths too as file join c:/test c:/etc ignores first arg and returns c:/etc + set srclocation [file join $projectroot $localpath $module_subpath] + } else { + set srclocation [file join $localpath $module_subpath] + } #puts stdout "$relpath $module $module_subpath $srclocation" #todo - check if requested_module has version extension and allow explicit versions instead of just latest diff --git a/src/modules/picalc-999999.0a1.0.tm b/src/modules/picalc-999999.0a1.0.tm index b3ab820c..1dcc87bf 100644 --- a/src/modules/picalc-999999.0a1.0.tm +++ b/src/modules/picalc-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_picalc 0 999999.0a1.0] +#[manpage_begin punkshell_module_picalc 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 55408253..90b3d334 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -8122,10 +8122,10 @@ namespace eval punk { interp alias {} mode {} punk::mode proc aliases {{glob *}} { - tailcall punk::lib::aliases $glob + tailcall punk::ns::aliases $glob } proc alias {{aliasorglob ""} args} { - tailcall punk::lib::alias $aliasorglob {*}$args + tailcall punk::ns::alias $aliasorglob {*}$args } diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 0c41af06..33370d4d 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -108,8 +108,6 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - aliases ::punk::lib::aliases\ - alias ::punk::lib::alias\ tstr ::punk::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ @@ -138,6 +136,8 @@ tcl::namespace::eval punk::aliascore { config ::punk::config\ s ::punk::ns::synopsis\ eg ::punk::ns::eg\ + aliases ::punk::ns::aliases\ + alias ::punk::ns::alias\ ] #*** !doctools diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index e720624a..cf1e5378 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -147,14 +147,18 @@ tcl::namespace::eval punk::ansi::class { }] method render_to_input_line {args} { if {[llength $args] < 1} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + return } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + return } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -6076,12 +6080,13 @@ tcl::namespace::eval punk::ansi::ta { } #perl: ta_strip + punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip proc strip {text} { #*** !doctools #[call [fun strip] [arg text]] #[para]Return text stripped of Ansi codes #[para]This is a tailcall to punk::ansi::ansistrip - tailcall ansistrip $text + tailcall punk::ansi::ansistrip $text } lappend PUNKARGS [list { @@ -6113,7 +6118,7 @@ tcl::namespace::eval punk::ansi::ta { "Calculate length of text (excluding the ANSI codes) This is not the printing length of the string on screen." @values -min 1 - text -type string + text -type string } ] #perl: ta_length proc length {text} { @@ -6133,7 +6138,7 @@ tcl::namespace::eval punk::ansi::ta { #perl: ta_trunc #truncate $text to $width columns while still including all the ANSI colour codes. proc trunc {text width args} { - + error "unimplemented" } #not in perl ta diff --git a/src/modules/punk/ansi/colourmap-999999.0a1.0.tm b/src/modules/punk/ansi/colourmap-999999.0a1.0.tm index b0d1140d..58cefd68 100644 --- a/src/modules/punk/ansi/colourmap-999999.0a1.0.tm +++ b/src/modules/punk/ansi/colourmap-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 999999.0a1.0] +#[manpage_begin punkshell_module_::punk::ansi::colourmap 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index d870a354..961fd07c 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::register { if {![info exists scanned_info]} { set scanned_info [dict create] } - #some packages, e.g punk::args::tclcore document other namespaces. + #some packages, e.g punk::args::moduledoc::tclcore document other namespaces. #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources variable namespace_docpackages if {![info exists namespace_docpackages]} { @@ -466,6 +466,8 @@ tcl::namespace::eval punk::args { recognised types: any (unvalidated - accepts anything) + unknown + (unvalidated - accepts anything) none (used for flags/switches only. Indicates this is a 'solo' flag ie accepts no value) @@ -475,6 +477,8 @@ tcl::namespace::eval punk::args { number list indexexpression + indexset + (as accepted by punk::lib::is_indexset) dict double float @@ -632,7 +636,7 @@ tcl::namespace::eval punk::args { from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { punk::args::define { @id -id ::myns::myfunc @cmd -name myns::myfunc -help\ @@ -764,24 +768,25 @@ tcl::namespace::eval punk::args { if {[dict exists $rawdef_cache $args]} { return [dict get [dict get $rawdef_cache $args] -id] } else { - set id [rawdef_id $args] + set lvl 2 + set id [rawdef_id $args $lvl] if {[id_exists $id]} { #we seem to be re-creating a previously defined id... #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + undefine $id 0 - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id + ##dict unset argdata_cache $prevraw ;#silently does nothing if key not present + #dict for {k v} $argdata_cache { + # if {[dict get $v id] eq $id} { + # dict unset argdata_cache $k + # } + #} + #dict for {k v} $rawdef_cache { + # if {[dict get $v -id] eq $id} { + # dict unset rawdef_cache $k + # } + #} + #dict unset id_cache_rawdef $id } set is_dynamic [rawdef_is_dynamic $args] set defspace [uplevel 1 {::namespace current}] @@ -790,6 +795,35 @@ tcl::namespace::eval punk::args { return $id } } + proc undefine {id {quiet 0}} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[id_exists $id]} { + if {!$quiet} { + puts stderr "punk::args::undefine clearing existing data for id:$id" + } + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } else { + if {!$quiet} { + puts stderr "punk::args::undefine unable to find id: '$id'" + } + } + } + #'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated + # In this case we don't see the autoid in order to delete it + #proc undefine_deflist {deflist} { + #} proc idquery_info {id} { variable id_cache_rawdef @@ -889,7 +923,8 @@ tcl::namespace::eval punk::args { set textargs $args if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} + #punk::args::get_by_id ::punk::args::define {} + punk::args::parse {} -errorstyle minimal withid ::punk::args::define return } #if {[lindex $args 0] eq "-dynamic"} { @@ -1184,7 +1219,7 @@ tcl::namespace::eval punk::args { } ref { #a reference within the definition - #e.g see punk::args::tclcore ::after + #e.g see punk::args::moduledoc::tclcore ::after #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id @@ -1952,6 +1987,7 @@ tcl::namespace::eval punk::args { char - character {set normtype char} dict - dictionary {set normtype dict} index - indexexpression {set normtype indexexpression} + indexset {set normtype indexset} "" - none - solo { if {$is_opt} { #review - are we allowing clauses for flags? @@ -1975,6 +2011,10 @@ tcl::namespace::eval punk::args { } } any - anything {set normtype any} + unknown { + #'unspecified' ?? + set normtype unknown + } ansi - ansistring {set normtype ansistring} string - globstring {set normtype $lc_firstword} literal { @@ -2705,25 +2745,38 @@ tcl::namespace::eval punk::args { #@dynamic only has meaning as 1st element of a def in the deflist } - #@id must be within first 4 lines of a block - or assign auto + #@id must be within first 4 lines of first 3 blocks - or assign auto #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { + proc rawdef_id {rawdef {lvl 1}} { set id "" - foreach d $rawdef { + set found_id_line 0 + foreach d [lrange $rawdef 0 2] { foreach ln [lrange [split $d \n] 0 4] { if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { if {$firstword eq "@id"} { + set found_id_line 1 + #review - uplevel 2 would be a call from punk::args::define ?? + set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]] if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { set id [dict get $rest -id] - break } + break } } } - if {$id ne ""} { + if {$found_id_line} { break } } + if {$id eq "" && $found_id_line} { + #Looked like an @id - but presumable the rest of the line was malformed. + #we won't produce an autoid for such a definition. + set first3blocks "" + foreach b [lrange $rawdef 0 2] { + append first3blocks $b\n + } + error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks" + } if {$id eq "" || [string tolower $id] eq "auto"} { variable id_counter set id "autoid_[incr id_counter]" @@ -2916,7 +2969,9 @@ tcl::namespace::eval punk::args { set seen_documentedns [list] ;#seen per pkgns foreach definitionlist [set ${pkgns}::PUNKARGS] { #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] + #set id [rawdef_id $definitionlist] + set lvl 1 ;#level at which tstr substitution occurs in @id line + set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]] if {[string match autoid_* $id]} { puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" puts stderr "definition:\n" @@ -2958,6 +3013,9 @@ tcl::namespace::eval punk::args { } else { set needed [list] foreach pkgns $nslist { + if {[string match (autodef)* $pkgns]} { + set pkgns [string range $pkgns 9 end] + } if {![string match ::* $pkgns]} { puts stderr "warning: update_definitions received unqualified ns: $pkgns" set pkgns ::$pkgns @@ -3443,18 +3501,28 @@ tcl::namespace::eval punk::args { set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO + #review - when can there be more than one selected form? set argdisplay_header "" set argdisplay_body "" - set is_custom_argdisplay 0 + if {[llength $selected_forms] == 1} { + set fid [lindex $selected_forms 0] + set FRM [dict get $spec_dict FORMS $fid] + if {[dict size [dict get $FRM FORMDISPLAY]]} { + set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""] + set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""] + } + } + + + # if {![dict size $F $fid $FORMDISPLAY]} {} + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + #set is_custom_argdisplay 0 set blank_header_col [list] @@ -4335,7 +4403,7 @@ tcl::namespace::eval punk::args { documentation generated dynamically and may not yet have an id. IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - Generally punk::ns::arginfo (aliased as i in the punk shell) should + Generally punk::ns::cmdhelp (aliased as i in the punk shell) should be used in preference - as it will search for a documentation mechanism and call punk::args::usage as necessary. " @@ -5730,6 +5798,15 @@ tcl::namespace::eval punk::args { break } } + indexset { + if {![punk::lib::is_indexset $e_check]} { + set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + break + } + } string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks @@ -8729,7 +8806,7 @@ tcl::namespace::eval punk::args { } set type_expression [string trim $typespec ?] - if {$type_expression in {any none}} { + if {$type_expression in {any none unknown}} { continue } #puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]" @@ -8790,7 +8867,8 @@ tcl::namespace::eval punk::args { dict set finalopts $o $v } } - return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + set docid [dict get $argspecs id] + return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid] } lappend PUNKARGS [list { @@ -9570,8 +9648,15 @@ tcl::namespace::eval punk::args { } } - set cinfo [punk::ns::resolve_command {*}$cmd] - set tp [dict get $cinfo cmdtype] + #don't use full cmdinfo if $cmd is a single element + if {[llength $cmd] == 1} { + set cinfo [punk::ns::cmdwhich $cmd] + set tp [dict get $cinfo whichtype] + } else { + puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo" + set cinfo [punk::ns::cmdinfo {*}$cmd] + set tp [dict get $cinfo cmdtype] + } dict set choiceinfodict $sc [list [list resolved $cmd]] @@ -9584,9 +9669,23 @@ tcl::namespace::eval punk::args { } } - if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + #could be more than one punk::args id - choose a precedence by how we order the id_exists checks. + if {[punk::args::id_exists [list $ensemble $sc]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc] + } elseif {[punk::args::id_exists $cmd]} { dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}$cmd] + } elseif {[punk::args::id_exists [dict get $cinfo origin]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]] + } else { + #puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]" } + + #if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + # dict lappend choiceinfodict $sc {doctype punkargs} + #} } set argdef "" @@ -9699,9 +9798,18 @@ tcl::namespace::eval punk::args::lib { ooc { lappend marks [punk::ns::Cmark ooc cyan] } + classmethod { + lappend marks [punk::ns::Cmark classmethod term-orange1] + } + coremethod { + lappend marks [punk::ns::Cmark coremethod term-plum1] + } ooo { lappend marks [punk::ns::Cmark ooo cyan] } + objectmethod { + lappend marks [punk::ns::Cmark objectmethod term-orange1] + } native { lappend marks [punk::ns::Cmark native] } @@ -9724,11 +9832,11 @@ tcl::namespace::eval punk::args::lib { @id -id ::punk::args::lib::tstr @cmd -name punk::args::lib::tstr\ -summary\ - "Templating with \$\{$varName\}"\ + "Templating with placeholders such as: \$\{$varName\}"\ -help\ - "A rough equivalent of js template literals + "Roughly analogous to js template literals - Substitutions: + Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm similarity index 89% rename from src/modules/punk/args/tclcore-999999.0a1.0.tm rename to src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm index dc88d51b..c40bc191 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::tclcore 999999.0a1.0 +# Application punk::args::moduledoc::tclcore 999999.0a1.0 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,11 +18,11 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args::tclcore 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 999999.0a1.0] #[copyright "2025"] #[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] #[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] -#[require punk::args::tclcore] +#[require punk::args::moduledoc::tclcore] #[keywords module] #[description] #[para] - @@ -31,10 +31,10 @@ #*** !doctools #[section Overview] -#[para] overview of punk::args::tclcore +#[para] overview of punk::args::moduledoc::tclcore #[subsection Concepts] -#[para] - - +#[para] This is a punk::args module documentation package. +#[para] It provides punk::args definitions for core Tcl commands, # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements @@ -42,7 +42,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::args::tclcore +#[para] packages used by punk::args::moduledoc::tclcore #[list_begin itemized] package require Tcl 8.6- @@ -52,6 +52,7 @@ package require textblock #*** !doctools #[item] [package {Tcl 8.6}] #[item] [package {punk::args}] +#[item] [package {punk::ansi}] #[item] [package {textblock}] #*** !doctools @@ -66,7 +67,7 @@ package require textblock # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tclcore { +tcl::namespace::eval punk::args::moduledoc::tclcore { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase #variable xyz @@ -114,7 +115,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { tcl::namespace::import ::punk::ansi::a+ - tcl::namespace::import ::punk::args::tclcore::manpage_tcl + tcl::namespace::import ::punk::args::moduledoc::tclcore::manpage_tcl # -- --- --- --- --- #non colour SGR codes # we can use these directly via ${$I} etc without marking a definition with @dynamic @@ -135,149 +136,16 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { + #*** !doctools + #[subsection {Namespace punk::args::moduledoc::tclcore::argdoc}] + #[para] This is the main documentation namespace where calls to punk::args::define are made, and definitions are added to the punk::args::moduledoc::tclcore::argdoc::PUNKARGS variable. + #[para] Some utility functions exist here for use in the definitions. + #[list_begin definitions] + variable PUNKARGS - #lappend PUNKARGS [list { - # @id -id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # @cmd -name ::punk::args::tclcore::argdoc::ensemble_subcommands_definition -help\ - # "Helper function to return a punk::args definition snippet for subcommands" - # @leaders -max 0 -min 0 - # -groupdict -default {} -type dict -help\ - # "Dictionary keyed on arbitrary groupname, where value - # is a list of known subcommands that should be displayed - # by groupname. Each groupname forms the title of a subtable - # in the choices list. - # Subcommands not assigned to a groupname will appear first - # in an untitled subtable." - # -columns -default 4 -type integer -help\ - # "Max number of columns for all subtables in the choices - # display area" - # @values -min 1 -max 1 - # ensemble -optional 0 -help\ - # "Name of ensemble command" - - #}] - #proc ensemble_subcommands_definition {args} { - # #args manually parsed - with use of argdef for unhappy-path only - # if {![llength $args]} { - # #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - # punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # return - # } - # set ensemble [lindex $args end] - # set optlist [lrange $args 0 end-1] - # if {[llength $optlist] % 2} { - # #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - # punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # return - # } - # set defaults [dict create\ - # -groupdict {}\ - # -columns 4\ - # ] - # set optlist [dict merge $defaults $optlist] - # dict for {k v} $optlist { - # switch -- $k { - # -groupdict - -columns {} - # default { - # #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - # punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # return - # } - # } - # } - # set opt_groupdict [dict get $optlist -groupdict] - # set opt_columns [dict get $optlist -columns] - - # package require punk::ns - # set subdict [punk::ns::ensemble_subcommands -return dict $ensemble] - # set allsubs [dict keys $subdict] - # # ---------------------------------------------- - # # manually defined group members may have subcommands that are obsoleted/missing - # # we choose to make the situation obvious by re-classifying into a corresponding group with the " - MISSING" suffix - # set checked_groupdict [dict create] - # dict for {g members} $opt_groupdict { - # set validmembers {} - # set invalidmembers {} - # foreach m $members { - # if {$m in $allsubs} { - # lappend validmembers $m - # } else { - # lappend invalidmembers $m - # } - # } - # dict set checked_groupdict $g $validmembers - # if {[llength $invalidmembers]} { - # dict set checked_groupdict "${g}_MISSING" $invalidmembers - # } - # } - # if {[dict exists $checked_groupdict ""]} { - # set others [dict get $checked_groupdict ""] - # dict unset checked_groupdict "" - # } else { - # set others [list] - # } - - # #REVIEW - # set debug 0 - # if {$debug} { - # puts "punk::args::tclcore::argdoc::ensemble_subcommands_definition" - # if {[catch { - # ::punk::lib::pdict checked_groupdict - # } msg]} { - # puts stderr "punk::args::tclcore::ensemble_subcommands_definition Cannot call pdict\n$msg" - # } - # puts -------------------- - # puts "$checked_groupdict" - # puts -------------------- - # } - - # set opt_groupdict $checked_groupdict - # # ---------------------------------------------- - # set allgrouped [list] - # dict for {g members} $opt_groupdict { - # lappend allgrouped {*}$members - # } - # set choiceinfodict [dict create] - # foreach {sc cmd} $subdict { - # if {$sc ni $allgrouped} { - # if {$sc ni $others} { - # lappend others $sc - # } - # } - # set cinfo [punk::ns::resolve_command {*}$cmd] - # set tp [dict get $cinfo cmdtype] - - # dict set choiceinfodict $sc [list [list resolved $cmd]] - - # switch -- $tp { - # ensemble - native { - # dict lappend choiceinfodict $sc [list doctype $tp] - # } - # object { - # dict lappend choiceinfodict $sc [list doctype oo] - # } - # } - - # if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { - # dict lappend choiceinfodict $sc {doctype punkargs} - # } - # } - - # set argdef "" - # append argdef "subcommand -choicegroups \{" \n - # append argdef " \"\" \{$others\}" \n - # dict for {g members} $opt_groupdict { - # append argdef " \"$g\" \{$members\}" \n - # } - # append argdef " \} -choicecolumns $opt_columns -choiceinfo {$choiceinfodict}" \n - - # #todo -choicelabels - # #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. - # #consider a different mechanism to add a label on rhs of same line as choice (for (i) marker) - - # return $argdef - #} + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore::argdoc ---}] } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -366,7 +234,7 @@ tcl::namespace::eval punk::args::tclcore { "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." @values -min 1 -max 1 procname -type string -optional 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" punk::args::define { @id -id ::tcl::info::body @@ -374,19 +242,15 @@ tcl::namespace::eval punk::args::tclcore { "Returns the body procedure named ${$I}procname${$NI}." @values -min 1 -max 1 procname -type string -optional 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" punk::args::define { - @id -id ::tcl::info::default - @cmd -name "Built-in: tcl::info::default" -help\ - "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} - has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. - Otherwise, returns ${$B}0${$N}." - @values -min 3 -max 3 - procname -type string -optional 0 - parameter - varname - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + @id -id ::tcl::info::cmdcount + @cmd -name "Built-in: tcl::info::cmdcount" -help\ + "Returns the total number of commands evaluated in this interpreter." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" punk::args::define { @id -id ::tcl::info::cmdtype @@ -420,7 +284,116 @@ tcl::namespace::eval punk::args::tclcore { " @values -min 1 -max 1 commandName -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::coroutine + @cmd -name "Built-in: tcl::info::coroutine" -help\ + "Returns the name of the current ${$B}coroutine${$N}, or the empty string if there + is no current coroutine or the current coroutine has been deleted." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::default + @cmd -name "Built-in: tcl::info::default" -help\ + "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} + has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. + Otherwise, returns ${$B}0${$N}." + @values -min 3 -max 3 + procname -type string -optional 0 + parameter + varname + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::functions + @cmd -name "Built-in: tcl::info::functions" -help\ + "If ${$I}pattern${$NI} is not given, returns a list of all the math functions currently defined. + If ${$I}pattern${$NI} is given, returns only those names that match ${$I}pattern${$NI} according to ${$B}string match${$N}." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::globals + @cmd -name "Built-in: tcl::info::globals" -help\ + "If ${$I}pattern${$NI} is not given, returns a list of all the names of currently-defined + global variables. Global variables are variables in the global namespace. If ${$I}pattern${$NI} is + given, only those names matching ${$I}pattern${$NI} are returned. Matching is determined using the + same rules as for ${$B}string match${$N}." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::hostname + @cmd -name "Built-in: tcl::info::hostname" -help\ + "Returns the name of the current host. + This name is not guaranteed to be the fully-qualified domain name of the host. + Where machines have several different names, as is common on systems with + both TCP/IP (DNS) and NetBIOS-based networking installed, it is the name that + is suitable for TCP/IP networking that is returned." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::level + @cmd -name "Built-in: tcl::info::level" -help\ + "If number is not given, the level this routine was called from. Otherwise + returns the complete command active at the given level. If number is greater + than ${$B}0${$N}, it is the desired level. Otherwise, it is number levels up from the + current level. A complete command is the words in the command, with all + substitutions performed, meaning that it is a list. See ${$B}uplevel${$N} for more + information on levels." + @values -min 0 -max 2 + level -type integer -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::library + @cmd -name "Built-in: tcl::info::library" -help\ + "Returns the value of ${$B}tcl_library${$N}, which is the name of the library + directory in which the scripts distributed with Tcl scripts are stored." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::loaded + @cmd -name "Built-in: tcl::info::loaded" -help\ + "Returns the name of each file loaded in interp by the load command with + prefix prefix . If prefix is not given, returns a list where each item is + the name of the loaded file and the prefix for which the file was loaded. + For a statically-loaded package the name of the file is the empty string. + For interp, the empty string is the current interpreter." + @values -min 0 -max 2 + interp -type string -optional 1 + prefix -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::locals + @cmd -name "Built-in: tcl::info::locals" -help\ + "If ${$I}pattern${$NI} is given, returns the name of each local variable matching + pattern according to ${$B}string match${$N}. Otherwise, returns the name of each local + variable. A variables defined with the ${$B}global${$N}, ${$B}upvar${$N} or ${$B}variable${$N} is not local." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + + punk::args::define { + @id -id ::tcl::info::nameofexecutable + @cmd -name "Built-in: tcl::info::nameofexecutable" -help\ + "Returns the absolute pathname of the program for the current interpreter. + If such a file can not be identified an empty string is returned." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + punk::args::define { @id -id ::oo::InfoObject::call @@ -440,7 +413,7 @@ tcl::namespace::eval punk::args::tclcore { class, or the literal string ${$B}object${$N} if the method implementation is on an instance) element 3: a word describing the type of method implementation - (see ${$B}info object methodtype${$N} + (see ${$B}info object methodtype${$N}) Note that there is no inspection of whether the method implementations actually use ${$B}next${$N} to transfer control along the call chain, and the call chains that @@ -450,6 +423,39 @@ tcl::namespace::eval punk::args::tclcore { method } "@doc -name Manpage: -url [manpage_tcl info]" + + #--------- + punk::args::define { + @id -id ::oo::InfoClass::call + @cmd -name "Built-in: oo::InfoClass::call" -help\ + "Returns a description of the method implementations that are used to provide + a stereotypical instance of ${$I}class's${$NI} implementation of ${$I}method${$NI}. + (stereotypical instances being objects instantiated by a class without having any + object-specific definitions added). + This consists of a + list of lists of four elements, where each sublist consists of: + element 0: a word that describes the general type of method implementation, being + one of + ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, + ${$B}filter${$N} for an applied filter, + ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that + is invoked as part of unknown method handling. + element 1: a word giving the name of the particular method invoked (which is always + the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" + for the ${$B}unknown${$N} type) + element 2: a word giving the fully qualified name of the class that defined the + method + element 3: a word describing the type of method implementation + (see ${$B}info class methodtype${$N}) + + Note that there is no inspection of whether the method implementations actually use + ${$B}next${$N} to transfer control along the call chain, and the call chains that + this command files do not actually contain private methods." + @values -min 2 -max 2 + class + method + } "@doc -name Manpage: -url [manpage_tcl info]" + proc info_subcommands {} { #package require punk::ns #set subdict [punk::ns::ensemble_subcommands -return dict info] @@ -461,17 +467,20 @@ tcl::namespace::eval punk::args::tclcore { return [punk::args::ensemble_subcommands_definition -groupdict $groups -columns 4 info] } - set DYN_INFO_SUBCOMMANDS {${[punk::args::tclcore::argdoc::info_subcommands]}} + set DYN_INFO_SUBCOMMANDS {${[punk::args::moduledoc::tclcore::argdoc::info_subcommands]}} lappend PUNKARGS [list { @dynamic @id -id ::info - @cmd -name "Built-in: info" -help\ + @cmd -name "Built-in: info"\ + -summary\ + "Information about the state of the Tcl interpreter"\ + -help\ "Information about the state of the Tcl interpreter" @leaders -min 1 -max 1 ${$DYN_INFO_SUBCOMMANDS} @values -min 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl array]" ] + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl array]" ] } @@ -522,17 +531,20 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id "::tcl::binary::encode::hex" @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" + @cmd -name "binary encode hex"\ + -summary "Encode each byte to a pair of hex digits (lower case output)" @values -min 1 -max 1 data -type string } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::hex" @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" + @cmd -name "binary encode hex"\ + -summary "Decode contiguous pairs of hex digits to bytes (input may be upper or lower case)" -strict -type none -help\ "Instructs the decoder to throw an error if it encounters whitespace - characters. Otherwise it ignores them." + characters. Otherwise it ignores them. + Whether -strict is applied or not, a trailing unpaired hex digit is ignored." @values -min 1 -max 1 data -type string }] @@ -580,6 +592,101 @@ tcl::namespace::eval punk::args::tclcore { data -type string } ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::convertfrom" + @cmd -name "encoding convertfrom" -help\ + "Converts data, which should be in the form of a binary string encoded as per encoding, + to a Tcl string. If encoding is not specified, the current system encoding is used." + + @form -form basic + @values -min 1 -max 2 + encoding -type string -typesynopsis ${$I}encoding${$NI} -optional 1 + data -type string -help "binary string" + + @form -form full + @leaders -min 0 -max 0 + @opts + -profile -type string -typesynopsis ${$I}profile${$NI} -help\ + "Determines the command behavior in the presence of conversion errors. + Any premature termination of processing due to errors is reported through an exception + if the -failindex option is not specified. + + Operations involving encoding transforms may encounter several types of errors such as + invalid sequences in the source data, characters that cannot be encoded in the target + encoding and so on. A profile prescribes the strategy for dealing with such errors in + one of two ways: + + Terminating further processing of the source data. The profile does not determine how + this premature termination is conveyed to the caller. By default, this is signalled + by raising an exception. If the -failindex option is specified, errors are reported + through that mechanism. + + Continue further processing of the source data using a fallback strategy such as + replacing or discarding the offending bytes in a profile-defined manner. + + The following profiles are currently implemented with strict being the default if the -profile is not specified."\ + -choicecolumns 1\ + -choices {strict tcl8 replace}\ + -choiceprefix 0\ + -choicelabels { + strict + " The strict profile always stops processing when an conversion error is encountered. + The error is signalled via an exception or the -failindex option mechanism. + The strict profile implements a Unicode standard conformant behavior." + tcl8 + " The tcl8 profile always follows the first strategy above and corresponds to the behavior + of encoding transforms in Tcl 8.6. When converting from an external encoding other than + utf-8 to Tcl strings with the encoding convertfrom command, invalid bytes are mapped to + their numerically equivalent code points. For example, the byte 0x80 which is invalid in + ASCII would be mapped to code point U+0080. When converting from utf-8, invalid bytes + that are defined in CP1252 are mapped to their Unicode equivalents while those that are + not fall back to the numerical equivalents. For example, byte 0x80 is defined by CP1252 + and is therefore mapped to its Unicode equivalent U+20AC while byte 0x81 which is not + defined by CP1252 is mapped to U+0081. As an additional special case, the sequence + 0xC0 0x80 is mapped to U+0000. When converting from Tcl strings to an external encoding + format using encoding convertto, characters that cannot be represented in the target + encoding are replaced by an encoding-dependent character, usually the question mark ?." + replace + " Like the tcl8 profile, the replace profile always continues processing on conversion + errors but follows a Unicode standard conformant method for substitution of invalid + source data. When converting an encoded byte sequence to a Tcl string using encoding + convertfrom, invalid bytes are replaced by the U+FFFD REPLACEMENT CHARACTER code point. + When encoding a Tcl string with encoding convertto, code points that cannot be represented + in the target encoding are transformed to an encoding-specific fallback character, U+FFFD + REPLACEMENT CHARACTER for UTF targets and generally `?` for other encodings." + } + -failindex -type string -typesynopsis ${$I}var${$NI} -help\ + "If specified, instead of an exception being raised on premature termination, + the result of the conversion up to the point of the error is returned as the + result of the command. In addition, the index of the source byte triggering + the error is stored in var. If no errors are encountered, the entire result + of the conversion is returned and the value -1 is stored in var." + @values -min 2 -max 2 + encoding -type string -optional 0 + data -type string -help "binary string" + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + + lappend PUNKARGS [list { + @id -id "::tcl::encoding::convertto" + @cmd -name "encoding convertto" -help\ + "Convert string to the specified encoding. The result is a Tcl binary string that + contains the sequence of bytes representing the converted string in the specified + encoding. If encoding is not specified, the current system encoding is used." + @form -form basic + @values -min 1 -max 2 + encoding -type string -typesynopsis ${$I}encoding${$NI} -optional 1 + data -type string + + @form -form full + @leaders -min 0 -max 0 + @opts + ${[punk::args::resolved_def -form 1 -types opts ::tcl::encoding::convertfrom -*]} + @values -min 2 -max 2 + encoding -type string -optional 0 + data -type string + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } namespace eval argdoc { lappend PUNKARGS [list { @id -id "::tcl::encoding::dirs" @@ -597,6 +704,46 @@ tcl::namespace::eval punk::args::tclcore { directoryList -optional 1 -type list } "@doc -name Manpage: -url [manpage_tcl encoding]" ] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::names" + @cmd -name "encoding names" -help\ + "Returns a list containing the names of all of the encodings that are + currently available. The encodings “utf-8” and “iso8859-1” are + guaranteed to be present in the list." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::profiles" + @cmd -name "encoding profiles" -help\ + "Returns a list of the names of encoding profiles. See PROFILES below." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::system" + @cmd -name "encoding system" -help\ + "Set the system encoding to ${$I}encoding${$NI}. If ${$I}encoding${$NI} is + omitted then the command returns the current system encoding. + The system encoding is used whenever Tcl passes strings to system calls." + @values -min 0 -max 1 + encoding -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::user" + @cmd -name "encoding user" -help\ + "Returns the name of encoding as per the user's preferences. + On Windows systems, this is based on the user's code page settings in + the registry. On other platforms, the returned value is the same as + returned by encoding system." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } lappend PUNKARGS [list { @id -id ::time @@ -1124,7 +1271,7 @@ tcl::namespace::eval punk::args::tclcore { arguments as second (and possibly subsequent) arguments. This facilitates lookups in nested dictionaries. For example, the following two commands are equivalent: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { dict get $dict foo bar spong dict get [dict get [dict get $dict foo] bar] spong\ } @@ -1704,7 +1851,7 @@ tcl::namespace::eval punk::args::tclcore { The handler is invoked when a command called from within the namespace cannot be found in the current namespace, the namespace's path nor in the global namespace. - When the handler is invoiked, the full invocation line will be appended to + When the handler is invoked, the full invocation line will be appended to the script and the result evaluated in the context of the namespace. The default handler for all namespaces is ${[a+ italic]}::unknown${[a+ noitalic]}. If no argument is given, it returns the handler for the current namespace." @@ -1725,11 +1872,13 @@ tcl::namespace::eval punk::args::tclcore { See the section NAME RESOLUTION in the manpage for an explanation of the rules regarding name resolution. " - @opts - -command -type none - #todo - make mutually exclusive - (separate forms) - -variable -type none - @values -min 1 -max 1 + @leaders -min 0 -max 1 + option -type {literalprefix(-command)|literalprefix(-variable)} -optional 1 -choices {-command -variable} + #@opts + #-command -type none + ##todo - make mutually exclusive - (separate forms) + #-variable -type none + #@values -min 1 -max 1 name } "@doc -name Manpage: -url [manpage_tcl namespace]" ] @@ -1921,7 +2070,7 @@ tcl::namespace::eval punk::args::tclcore { namespace even if its name does not start with “::”. The semantics of ${$B}apply${$N} can also be described by approximately this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc apply {fun args} { set len [llength $fun] if {($len < 2) || ($len > 3)} { @@ -1965,7 +2114,7 @@ tcl::namespace::eval punk::args::tclcore { arrayName must be the name of an existing array variable. The subcommand argument determines what action is carried out by the command." @leaders - ${[punk::args::tclcore::argdoc::array_subcommands]} + ${[punk::args::moduledoc::tclcore::argdoc::array_subcommands]} } "@doc -name Manpage: -url [manpage_tcl array]" ] @@ -2128,6 +2277,163 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl catch]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + #TODO - add CLOCK_ARITHMETIC documentation + #TODO - TIME ZONES documentation? + lappend PUNKARGS [list { + @id -id ::tcl::clock::add + @cmd -name "Built-in: tcl::clock::add"\ + -summary\ + "Add an offset to timeVal in seconds (base 1970-01-01 00:00 UTC)"\ + -help\ + "Adds a (possibly negative) offset to a time that is expressed as an integer number of seconds. See CLOCK ARITHMETIC for a full description." + @leaders -min 1 -max -1 + timeVal -type integer|literal(now) -help\ + "Time value in integer number of seconds since epoch time. + Instead of timeVal a non-integer value now can be used as replacement for today, + which is simply interpolated to the run-time as value of clock seconds." + count_unit -type {int string} -multiple 1 -optional 1 -help\ + "unit is one of seconds,minutes,hours,cays,weekdays,weeks,months or years" + @opts + -timezone -type string -choicerestricted 0 -choiceprefix 0 -choicecolumns 7\ + -help\ + "e.g (from tzdata file) + :localtime + :UTC + :Australia/Sydney + :America/New_York + Note that the choices listed below are case insensitive, but the location based timezones + beginning with a colon are case sensitive. + See 'TIME ZONES' in the clock manpage"\ + -choices { + gmt ut utc bst wet wat at + nft nst ndt ast adt est edt + cst cdt mst mdt pst pdt yst + ydt hst hdt cat ahst nt idlw + cet cest met mewt mest swt sst + eet eest bt it zp4 zp5 ist + zp6 wast wadt jt cct jst cast + cadt east eadt gst nzt nzst nzdt + idle + } + -locale -type string -help\ + "Specifies that locale-dependent scanning and formatting (and date arithmetic for dates preceding + the adoption of the Gregorian calendar) is to be done in the locale identified by localeName. + The locale name may be any of the locales acceptable to the msgcat package, or it may be the special + name system, which represents the current locale of the process, or the null string, which + represents Tcl's default locale. + e.g en_US" + -gmt -type boolean -help\ + "If boolean is true, specifies that a time specified to clock add, clock format or clock scan should be processed in UTC. + If boolean is false, the processing defaults to the local time zone. This usage is obsolete; the correct current usage + is to specify the UTC time zone with “-timezone :UTC” or any of the equivalent ways to specify it." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::clock::format + @cmd -name "Built-in: tcl::clock::format"\ + -summary\ + "Format a time that is expressed as an integer number of seconds."\ + -help\ + "Formats a time that is expressed as an integer number of seconds into a format intended + for consumption by users or external programs. See ${$B}CLOCK ARITHMETIC${$N} for a full description." + @leaders -min 1 -max -1 + timeVal -type integer|literal(now) -help\ + "Time value in integer number of seconds since epoch time. + Instead of timeVal a non-integer value now can be used as replacement for today, + which is simply interpolated to the run-time as value of clock seconds." + @opts + ${[punk::args::resolved_def -types opts ::tcl::clock::add -*]} + -format -type string -help\ + "A string that specifies how the date and time are to be formatted. + The string consists of any number of characters other than the per-cent sign (“%”) + interspersed with any number of format groups, which are two-character sequences + beginning with the per-cent sign. The permissible format groups, and their + interpretation, are described under ${$B}FORMAT GROUPS${$N}." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + #::tcl::clock::clicks + #::tcl::clock::format + + + #review - definition doesn't preclude supplying both -milliseconds and -microseconds, but they are mutually exclusive + #lappend PUNKARGS [list { + # @id -id ::tcl::clock::clicks + # @cmd -name "Built-in: tcl::clock::clicks"\ + # -summary\ + # "high-resolution time value as system-dependent integer."\ + # -help\ + # "If no -option argument is supplied, returns a high-resolution time value as a system-dependent integer value. + # The unit of the value is system-dependent but should be the highest resolution clock available on the system + # such as a CPU cycle counter. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + # @opts + # -milliseconds -type none -help\ + # "Synonymous with ${$B}clock milliseconds${$N}. + # This usage is obsolete, and ${$B}clock milliseconds${$N} is to be + # considered the preferred way of obtaining a count of milliseconds." + # -microseconds -type none -help\ + # "Synonymous with ${$B}clock microseconds${$N}. + # This usage is obsolete, and ${$B}clock microseconds${$N} is to be + # considered the preferred way of obtaining a count of microseconds." + # @values -min 0 -max 0 + #} "@doc -name Manpage: -url [manpage_tcl clock]" ] + lappend PUNKARGS [list { + @id -id ::tcl::clock::clicks + @cmd -name "Built-in: tcl::clock::clicks"\ + -summary\ + "high-resolution time value as system-dependent integer."\ + -help\ + "If no option argument is supplied, returns a high-resolution time value as a system-dependent integer value. + The unit of the value is system-dependent but should be the highest resolution clock available on the system + such as a CPU cycle counter. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + @values -min 0 -max 1 + option -optional 1 -type {literalprefix(-milliseconds)|literalprefix(-microseconds)} -choices {-milliseconds -microseconds}\ + -choicelabels { + -milliseconds + "Synonymous with ${$B}clock milliseconds${$N}. + This usage is obsolete, and ${$B}clock milliseconds${$N} is to be + considered the preferred way of obtaining a count of milliseconds." + -microseconds + "Synonymous with ${$B}clock microseconds${$N}. + This usage is obsolete, and ${$B}clock microseconds${$N} is to be + considered the preferred way of obtaining a count of microseconds." + }\ + -choicecolumns 1 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + + lappend PUNKARGS [list { + @id -id ::tcl::clock::microseconds + @cmd -name "Built-in: tcl::clock::microseconds"\ + -summary\ + "Current time as an integer number of microseconds."\ + -help\ + "Returns the current time as an integer number of microseconds. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::clock::milliseconds + @cmd -name "Built-in: tcl::clock::milliseconds"\ + -summary\ + "Current time as an integer number of milliseconds."\ + -help\ + "Returns the current time as an integer number of milliseconds. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::clock::seconds + @cmd -name "Built-in: tcl::clock::seconds"\ + -summary\ + "Current time as an integer number of seconds."\ + -help\ + "Returns the current time as an integer number of seconds." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { @dynamic @id -id ::concat @@ -2230,14 +2536,14 @@ tcl::namespace::eval punk::args::tclcore { Historically, this feature had been most useful in conjunction with the catch command: if a caught error cannot be handled successfully, info can be used to return a stack trace reflecting the original point of occurrence of the error: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { catch {...} errMsg set savedInfo $::errorInfo ... error $errMsg $savedInfo }]} When working with Tcl 8.5 or later, the following code should be used intead: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { catch {...} errMsg options ... return -options $options $errMsg @@ -2280,7 +2586,7 @@ tcl::namespace::eval punk::args::tclcore { with extra values appended. This technique is used in a number of places throughout the Tcl core (e.g. in ${$B}fcopy${$N}, ${$B}lsort${$N} and ${$B}trace${$N} command callbacks). This example shows how to do this using core Tcl commands: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set script { puts "logging now" lappend $myCurrentLogVar @@ -2301,7 +2607,7 @@ tcl::namespace::eval punk::args::tclcore { pattern. It is less general than the eval command, and hence easier to make robust in practice. The following procedure acts in a way that is analogous to the lappend command, except it inserts the argument values at the start of the list in the variable: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc lprepend {varName args} { upvar 1 $varName var # Ensure that the variable exists and contains a list @@ -2311,11 +2617,11 @@ tcl::namespace::eval punk::args::tclcore { } }]} However, the last line would now normally be written without eval, like this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set var [linsert $var 0 {*}$args] }]} Or indeed like this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set var [list {*}$args {*}$var] }]} } @@ -2336,7 +2642,7 @@ tcl::namespace::eval punk::args::tclcore { Since non-zero exit codes are usually interpreted as error cases by the calling process, the exit command is an important part of signaling that something fatal has gone wrong. This code fragment is useful in scripts to act as a general problem trap: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc main {} { # ... put the real main code in here ... } @@ -2457,7 +2763,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl buildinfo]"\ {@examples -help { These show the use of ::tcl::build-info. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ::tcl::build-info → 9.0.2+af16c07b81655fabde8028374161ad54b84ef9956843c63f49976b4ef601b611.gcc-1204 ::tcl::build-info commit @@ -2507,7 +2813,10 @@ tcl::namespace::eval punk::args::tclcore { one will be treated as the first ${$I}arg${$NI} even if it starts with a -." @values -min 1 -max -1 - arg -type string -multiple 1 -optional 0 + arg -type string\ + -help "Command and arguments to be executed. May be interspersed with + various 'control of flow' operators which are not passed to the subprocess."\ + -multiple 1 -optional 0 -choicerestricted 0 -choices {"|" "|&" ">>" "2>>" ">>&"} #we must give an optional value a -default - or it will be processed as empty string and won't validate if not received! #(default values are never validated) stderr_to_result -type {literal(2>@1)} -optional 1 -default 0 @@ -2680,7 +2989,7 @@ tcl::namespace::eval punk::args::tclcore { The two forms may be mixed, so -types {d f r w} will find all regular files OR directories that have both read AND write permissions. The following are equivalent: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { glob -type d * glob */} ]} @@ -2912,24 +3221,24 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl ledit]"\ {@examples -help { Prepend to a list. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set lst {c d e f g} -> c d e f g ledit lst -1 -1 a b -> a b c d e f g }]} Append to the list. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ledit lst end+1 end+1 h i -> a b c d e f g h i }]} Delete the third and fourth elements. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ledit lst 2 3 -> a b e f g h i }]} Replace two elements with three. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ledit lst 2 3 x y z -> a b x y z g h i set lst @@ -3309,7 +3618,7 @@ tcl::namespace::eval punk::args::tclcore { included, it's sign should agree with the direction of the sequence (descending -> negative and ascending -> positive), otherwise an empty list is returned. For example: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { % lseq 1 to 5 ;#increasing -> 1 2 3 4 5 @@ -3515,15 +3824,15 @@ tcl::namespace::eval punk::args::tclcore { sublist (as if the overall element and the indexList were passed to lindex) and sort based on the given element. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -integer -index 1 \ {{First 24} {Second 18} {Third 30}} }]} returns ${$B}{Second 18} {First 24} {Third 30}${$N}, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -index end-1 \ {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}} }]} returns ${$B}{c 4 5 6 d h} {a 1 e i} {b 2 3 f 5}${$N}, and - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -index {0 1} { {{b i g} 12345} {{d e m o} 34512} @@ -3542,10 +3851,10 @@ tcl::namespace::eval punk::args::tclcore { The list length must be an integer multiple of the strideLength, which in turn must be at least 2. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -stride 2 {carrot 10 apple 50 banana 25} }]} returns "apple 50 banana 25 carrot 10", and - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -stride 2 -index 1 -integer {carrot 10 apple 50 banana 25} }]} returns "carrot 10 banana 25 apple 50".} -nocase -type none -help\ @@ -3675,7 +3984,7 @@ tcl::namespace::eval punk::args::tclcore { in the directory that it was started in (unless the user specifies otherwise) since that minimizes user confusion. The way to do this is to save the current directory while the external command is being run: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set tarFile [file normalize somefile.tar] set savedDir [pwd] cd /tmp @@ -3691,7 +4000,7 @@ tcl::namespace::eval punk::args::tclcore { in the directory that it was started in (unless the user specifies otherwise) since that minimizes user confusion. The way to do this is to save the current directory while the external command is being run: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set tarFile [file normalize somefile.tar] set savedDir [pwd] cd /tmp @@ -4134,7 +4443,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl socket]"\ {@examples -help { Here is a very simple time server: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc Server {startTime channel clientaddr clientport} { puts "Connection from $clientaddr registered" set now [clock seconds] @@ -4146,7 +4455,7 @@ tcl::namespace::eval punk::args::tclcore { socket -server [list Server [clock seconds]] 9900 vwait forever}]} And here is the corresponding client to talk to the server and extract some information: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set server localhost set sockChan [socket $server 9900] gets $sockChan line1 @@ -4190,11 +4499,11 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl source]"\ {@examples -help { Run the script in the file ${B}foo.tcl${$N} and then the script in ${$B}bar.tcl${$N}: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { source foo.tcl source bar.tcl }]} Alternatively: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { foreach scriptFile {foo.tcl bar.tcl} { source $scriptFile }}]} @@ -4295,10 +4604,10 @@ tcl::namespace::eval punk::args::tclcore { specified (in any of the forms described in STRING_INDICES), then the search is constrained to start with the character in ${$I}haystackString${$NI} specified by the index. For Example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string first a 0a23456789abcdef 5 }]} will return ${$B}10${$N}, but - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string first a 0a23456789abcdef 11 }]} will return ${$B}-1${$N}. " @@ -4350,10 +4659,10 @@ tcl::namespace::eval punk::args::tclcore { specified (in any of the forms described in STRING_INDICES), then only the characters in ${$I}haystackString${$NI} at or before the specified lastIndex will be considered by the search. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string last a 0a23456789abcdef 15 }]} will return ${$B}10${$N}, but - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string last a 0a23456789abcdef 9 }]} will return ${$B}1${$N}." @values -min 1 -max 3 @@ -4385,12 +4694,12 @@ tcl::namespace::eval punk::args::tclcore { key appearing first in the list will be checked first, and so on. ${$I}string${$NI} is only iterated over once, so earlier key replacements will have no affect for later key matches. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc }]} will return the string ${$B}01321221${$N}. Note that if an earlier key is a prefix of a later one, it will completely mask the later one, So if the previous example were reordered like this, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string map {1 0 ab 2 a 3 abc 1} 1abcaababcabababc }]} it will return the string ${$B}02c322c222c${$N}. " @@ -4960,7 +5269,7 @@ tcl::namespace::eval punk::args::tclcore { ${B}EXAMPLES${$N} The following produces an error that is identical to that produced by expr when trying to divide a value by zero. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { throw {ARITH DIVZERO {divide by zero}} {divide by zero} }]}" @values -min 2 -max 2 @@ -4988,7 +5297,8 @@ tcl::namespace::eval punk::args::tclcore { obsolete {variable vdelete vinfo} }\ -choiceinfo { - add {{doctype punkargs} {subhelp ::trace add}} + add {{doctype punkargs} {subhelp ::trace add}} + remove {{doctype punkargs} {subhelp ::trace remove}} } @values -min 0 -max 0 @@ -4996,23 +5306,30 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id "::trace add" - @cmd -name "Built-in: trace add" -help\ - "" + @cmd -name "Built-in: trace add"\ + -summary\ + "Add a command, execution or variable trace."\ + -help\ + "Add a command, execution or variable trace." @form -synopsis "trace add type name ops ?args?" @leaders type -choicegroups { "" {command execution variable} }\ -choiceinfo { - command {{doctype punkargs}} - execution {{doctype punkargs}} + command {{doctype punkargs} {subhelp ::trace add command}} + execution {{doctype punkargs} {subhelp ::trace add execution}} + variable {{doctype punkargs}} } } "@doc -name Manpage: -url [manpage_tcl trace]" punk::args::define { @id -id "::trace add command" - @cmd -name "Built-in: trace add command" -help\ + @cmd -name "Built-in: trace add command"\ + -summary\ + "Add command trace for operation(s): rename delete"\ + -help\ "Arrange for commandPrefix to be executed (with additional arguments) whenever command name is modified in one of the ways given by the list ops. Name will be resolved using the usual namespace resolution rules @@ -5056,10 +5373,126 @@ tcl::namespace::eval punk::args::tclcore { " } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { + @id -id "::trace add variable" + @cmd -name "Built-in: trace add variable"\ + -summary\ + "Add variable trace for operation(s): array read write unset."\ + -help\ + "Arrange for commandPrefix to be executed whenever variable name is accessed + in one of the ways given by the list ops. Name may refer to a normal variable, + an element of an array, or to an array as a whole (i.e. name may be just the + name of an array, with no parenthesized index). If name refers to a whole + array, then commandPrefix is invoked whenever any element of the array is + manipulated. If the variable does not exist, it will be created but will not + be given a value, so it will be visible to namespace which queries, but not to + info exists queries." + name -type string -help\ + "Name of variable" + # --------------------------------------------------------------- + ops -type list -choices {array read write unset} -choiceprefix 0\ + -choicemultiple {1 4}\ + -choicecolumns 1\ + -choicelabels { + array\ + " Invoke commandPrefix whenever the variable is accessed or + modified via the array command, provided that name is not a + scalar variable at the time that the array command is invoked. + If name is a scalar variable, the access via the array command + will not trigger the trace." + read\ + " Invoke commandPrefix whenever the variable isread." + write\ + " Invoke commandPrefix whenever the variable is written." + unset\ + " Invoke commandPrefix whenever the variable is unset. Variables + can be unset explicitly with the unset command, or implicitly + when procedures return (all of their local variables are unset). + Variables are also unset when interpreters are deleted, but + traces will not be invoked because there is no interpreter in + which to execute them." + }\ + -help\ + "Indicates which operations are of interest." + commandPrefix -type string -help\ + "When the trace triggers, three arguments are appended to commandPrefix + so that the actual command is as follows: + ----------------------------------------- + commandPrefix name1 name2 op + ----------------------------------------- + Name1 gives the name for the variable being accessed. This is not + necessarily the same as the name used in the trace add variable command: + the upvar command allows a procedure to reference a variable under a + different name. If the trace was originally set on an array or array + element, name2 provides which index into the array was affected. This + information is present even when name1 refers to a scalar, which may + happen if the upvar command was used to create a reference to a single + array element. If an entire array is being deleted and the trace was + registered on the overall array, rather than a single element, then + name1 gives the array name and name2 is an empty string. Op indicates + what operation is being performed on the variable, and is one of read, + write, or unset as defined above. + + CommandPrefix executes in the same context as the code that invoked the + traced operation: if the variable was accessed as part of a Tcl procedure, + then commandPrefix will have access to the same local variables as code in + the procedure. This context may be different than the context in which the + trace was created. If commandPrefix invokes a procedure (which it normally + does) then the procedure will have to use upvar or uplevel if it wishes to + access the traced variable. Note also that name1 may not necessarily be + the same as the name used to set the trace on the variable; differences + can occur if the access is made through a variable defined with the upvar + command. + + For read and write traces, commandPrefix can modify the variable to affect + the result of the traced operation. If commandPrefix modifies the value of + a variable during a read or write trace, then the new value will be + returned as the result of the traced operation. The return value from + commandPrefix is ignored except that if it returns an error of any sort + then the traced operation also returns an error with the same error message + returned by the trace command (this mechanism can be used to implement + read-only variables, for example). For write traces, commandPrefix is + invoked after the variable's value has been changed; it can write a new + value into the variable to override the original value specified in the + write operation. To implement read-only variables, commandPrefix will have + to restore the old value of the variable. + + While commandPrefix is executing during a read or write trace, traces on + the variable are temporarily disabled. This means that reads and writes + invoked by commandPrefix will occur directly, without invoking + commandPrefix (or any other traces) again. However, if commandPrefix + unsets the variable then unset traces will be invoked. + + When an unset trace is invoked, the variable has already been deleted: it + will appear to be undefined with no traces. If an unset occurs because of + a procedure return, then the trace will be invoked in the variable context + of the procedure being returned to: the stack frame of the returning + procedure will no longer exist. Traces are not disabled during unset + traces, so if an unset trace command creates a new trace and accesses the + variable, the trace will be invoked. Any errors in unset traces are ignored. + + If there are multiple traces on a variable they are invoked in order of + creation, most-recent first. If one trace returns an error, then no further + traces are invoked for the variable. If an array element has a trace set, + and there is also a trace set on the array as a whole, the trace on the + overall array is invoked before the one on the element. + + Once created, the trace remains in effect either until the trace is removed + with the trace remove variable command described below, until the variable + is unset, or until the interpreter is deleted. Unsetting an element of array + will remove any traces on that element, but will not remove traces on the + overall array. + + This command returns an empty string." + } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { @id -id "::trace add execution" - @cmd -name "Built-in: trace add execution" -help\ + @cmd -name "Built-in: trace add execution"\ + -summary\ + "Add execution trace for operation(s): enter leave enterstep leavestep."\ + -help\ "Arrange for commandPrefix to be executed (with additional arguments) whenever command name is executed, with traces occurring at the points indicated by the list ops. Name will be resolved using the usual namespace @@ -5159,6 +5592,25 @@ tcl::namespace::eval punk::args::tclcore { " } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { + @id -id "::trace remove" + @cmd -name "Built-in: trace remove"\ + -summary\ + "Remove a command, execution or variable trace."\ + -help\ + "Remove a command, execution or variable trace." + @form -synopsis "trace remove type name ops ?args?" + @leaders + type -choicegroups { + "" {command execution variable} + }\ + -choiceinfo { + command {{doctype punkargs} {subhelp ::trace remove command}} + execution {{doctype punkargs} {subhelp ::trace remove execution}} + variable {{doctype punkargs} {subhelp ::trace remove variable}} + } + + } "@doc -name Manpage: -url [manpage_tcl trace]" punk::args::define { @id -id "::trace remove command" @cmd -name "Built-in: trace remove command" -help\ @@ -5175,6 +5627,44 @@ tcl::namespace::eval punk::args::tclcore { delete" commandPrefix } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove execution" + @cmd -name "Built-in: trace remove execution" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string. If + name does not exist, the command will throw an error" + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + enter + leave + enterstep + leavestep" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove variable" + @cmd -name "Built-in: trace remove variable" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string." + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + array + read + write + unset" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -5263,7 +5753,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl try]"\ {@examples -help { Ensure that a file is closed no matter what: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set f [open /some/file/name a] try { puts $f "some message" @@ -5273,7 +5763,7 @@ tcl::namespace::eval punk::args::tclcore { } }]} Handle different reasons for a file to not be openable for reading: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { try { set f [open /some/file/name r] } trap {POSIX EISDIR} {} { @@ -5286,7 +5776,7 @@ tcl::namespace::eval punk::args::tclcore { The file is closed in success and error case by the finally clause. It is allowed to call return within the try block. Remark that with tcl 9, the read command may also throw utf-8 conversion errors: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc readfile {filename} { set f [open $filename r] try { @@ -5442,15 +5932,15 @@ tcl::namespace::eval punk::args::tclcore { varName -type string -multiple 1 -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl vwait]"\ + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl vwait]"\ {@examples -help { Run the event-loop continually until some event calls exit. (You can use any variable not mentioned elsewhere, but the name forever reminds you at a glance of the intent.) - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { vwait forever }]} Wait five seconds for a connection to a server socket, otherwise close the socket and continue running the script: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { # Initialise the state after 5000 set state timeout set server [socket -server accept 12345] @@ -5480,7 +5970,7 @@ tcl::namespace::eval punk::args::tclcore { }]} A command that will wait for some time delay by waiting for a namespace variable to be set. Includes an interlock to prevent nested waits. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { namespace eval example { variable v done proc wait {delay} { @@ -5500,7 +5990,7 @@ tcl::namespace::eval punk::args::tclcore { the waiting for the a variable never finishes; that vwait command is still waiting for a script scheduled with after to complete, which just happens to be running an inner vwait (for b) even though the event that the outer vwait was waiting for (the setting of a) has occurred. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { after 500 { puts "waiting for b" vwait b @@ -5517,7 +6007,7 @@ tcl::namespace::eval punk::args::tclcore { set b 42 }]} If you run the above code, you get this output: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { waiting for a waiting for b setting a @@ -5526,7 +6016,7 @@ tcl::namespace::eval punk::args::tclcore { commands, and yet b will not be set until after the outer vwait returns, so the script has deadlocked. The only ways to avoid this are to either structure the overall program in continuation-passing style or to use coroutine to make the continuations implicit. The first of these options would be written as: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { after 500 { puts "waiting for b" trace add variable b write {apply {args { @@ -5552,7 +6042,7 @@ tcl::namespace::eval punk::args::tclcore { vwait done }]} The second option, with coroutine and some helper procedures, is done like this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { # A coroutine-based wait-for-variable command proc waitvar globalVar { trace add variable ::$globalVar write \ @@ -5659,7 +6149,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl update]"\ {@examples -help { Run computations for about a second and then finish: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set x 1000 set done 0 after 1000 set done 1 @@ -5703,12 +6193,12 @@ tcl::namespace::eval punk::args::tclcore { The uplevel command causes the invoking procedure to disappear from the procedure calling stack while the command is being executed. In the above example, suppose c invokes the command: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { uplevel 1 {set x 43; d}}]} where d is another Tcl procedure. The set command will modify the variable x in b's context, and d will execute at level 3, as if called from b. If it in turn executes the command: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { uplevel 1 {set x 42}}]} then the set command will modify the same variable x in b's context: the procedure c does not appear to be on the call stack when d is executing. @@ -5757,7 +6247,7 @@ tcl::namespace::eval punk::args::tclcore { calling and also makes it easier to build new control constructs as Tcl procedures. For example, consider the following procedure: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc add2 name { upvar $name x set x [expr {$x + 2}] @@ -5821,7 +6311,7 @@ tcl::namespace::eval punk::args::tclcore { evaluated (before each loop iteration), so changes in the variables will be visible. For an example, try the following script with and without the braces around ${$B}$x<10:${$N} - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set x 0 while {$x<10} { puts "x is $x" @@ -5860,7 +6350,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string initValue -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -5876,7 +6366,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string initValue -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -5892,7 +6382,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string level -type integer -range {0 9} -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @dynamic @@ -5907,7 +6397,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string bufferSize -type integer -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib deflate" @@ -5918,7 +6408,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string level -type integer -range {0 9} -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib push" @@ -6019,7 +6509,7 @@ tcl::namespace::eval punk::args::tclcore { compressed stream back to the channel, making them appear as unread to further readers." @values -min 0 -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gunzip" @@ -6053,7 +6543,7 @@ tcl::namespace::eval punk::args::tclcore { @opts -headerVar -type string -typesynopsis ${$I}varName${$NI} @values -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gzip" @@ -6090,7 +6580,7 @@ tcl::namespace::eval punk::args::tclcore { -level -type integer -range {0 9} -typesynopsis ${$I}level${$NI} -header -type dict -typesynopsis ${$I}dict${$NI} @values -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -6144,22 +6634,22 @@ tcl::namespace::eval punk::args::tclcore { -choicelabels {${$CHOICELABELS}}\ -choiceinfo {${$CHOICEINFO}} - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"\ + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]"\ {@examples -help { To compress a Tcl string, it should be first converted to a particular charset encoding since the zlib command always operates on binary strings. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set binData [encoding convertto utf-8 $string] set compData [zlib compress $binData] }]} When converting back, it is also important to reverse the charset encoding: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set binData [zlib decompress $compData] set string [encoding convertfrom utf-8 $binData] }]} The compression operation from above can also be done with streams, which is especially helpful when you want to accumulate the data by stages: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set strm [zlib stream compress] $strm put [encoding convertto utf-8 $string] # ... @@ -6176,7 +6666,7 @@ tcl::namespace::eval punk::args::tclcore { dict set groups "ZIP Creation" {mkzip mkimg mkkey lmkimg lmkzip} return [punk::args::ensemble_subcommands_definition -groupdict $groups -columns 3 zipfs] } - set DYN_ZIPFS_SUBCOMMANDS {${[punk::args::tclcore::argdoc::zipfs_subcommands]}} + set DYN_ZIPFS_SUBCOMMANDS {${[punk::args::moduledoc::tclcore::argdoc::zipfs_subcommands]}} punk::args::define { @dynamic @id -id ::zipfs @@ -6201,7 +6691,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 1 -max 1 ${$DYN_ZIPFS_SUBCOMMANDS} @values -min 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::canonical @@ -6214,7 +6704,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 1 mountpoint -type string -optional 1 filename -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::exists @@ -6223,7 +6713,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 filename -type file - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::find @@ -6235,7 +6725,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 directoryName -type directory - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::info @@ -6254,7 +6744,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 file -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::list @@ -6275,7 +6765,7 @@ tcl::namespace::eval punk::args::tclcore { #patterntype -type literalprefix(-glob)|literalprefix(-regexp) -optional 1 patterntype -type string -default -glob -choices {-glob -regexp} -typesynopsis -glob|-regex pattern -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkimg @@ -6290,7 +6780,7 @@ tcl::namespace::eval punk::args::tclcore { inlist -type dict password -type any -optional 1 infile -type file -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkzip @@ -6304,7 +6794,7 @@ tcl::namespace::eval punk::args::tclcore { outfile -type file inlist -type dict password -type any -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mount @@ -6349,7 +6839,7 @@ tcl::namespace::eval punk::args::tclcore { mountpoint -type string password -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mountdata @@ -6359,7 +6849,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 1 data -type any mountpoint -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkzip @@ -6382,7 +6872,7 @@ tcl::namespace::eval punk::args::tclcore { strip -type string -optional 1 -help\ "file name prefix" password -type any -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkimg @@ -6424,7 +6914,7 @@ tcl::namespace::eval punk::args::tclcore { "file name prefix" password -type string -optional 1 infile -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkkey @@ -6434,7 +6924,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 password -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::root @@ -6445,7 +6935,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @opts -min 0 -max 0 @values -min 0 -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::unmount @@ -6457,7 +6947,7 @@ tcl::namespace::eval punk::args::tclcore { @opts -min 0 -max 0 @values -min 1 -max 1 mountpoint - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- } @@ -6466,8 +6956,8 @@ tcl::namespace::eval punk::args::tclcore { #*** !doctools - #[subsection {Namespace punk::args::tclcore}] - #[para] Core API functions for punk::args::tclcore + #[subsection {Namespace punk::args::moduledoc::tclcore}] + #[para] Core API functions for punk::args::moduledoc::tclcore #[list_begin definitions] @@ -6488,7 +6978,7 @@ tcl::namespace::eval punk::args::tclcore { #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tclcore ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -6496,11 +6986,11 @@ tcl::namespace::eval punk::args::tclcore { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tclcore::lib { +tcl::namespace::eval punk::args::moduledoc::tclcore::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] #*** !doctools - #[subsection {Namespace punk::args::tclcore::lib}] + #[subsection {Namespace punk::args::moduledoc::tclcore::lib}] #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -6514,33 +7004,23 @@ tcl::namespace::eval punk::args::tclcore::lib { #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tclcore::lib ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::args::tclcore::system { - #*** !doctools - #[subsection {Namespace punk::args::tclcore::system}] - #[para] Internal functions that are not part of the API - -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore ::punk::args::tclcore::argdoc + lappend ::punk::args::register::NAMESPACES ::punk::args::moduledoc::tclcore ::punk::args::moduledoc::tclcore::argdoc } ## Ready -package provide punk::args::tclcore [tcl::namespace::eval punk::args::tclcore { - variable pkg punk::args::tclcore +package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore { + variable pkg punk::args::moduledoc::tclcore variable version set version 999999.0a1.0 }] diff --git a/src/modules/punk/args/tclcore-buildversion.txt b/src/modules/punk/args/moduledoc/tclcore-buildversion.txt similarity index 100% rename from src/modules/punk/args/tclcore-buildversion.txt rename to src/modules/punk/args/moduledoc/tclcore-buildversion.txt diff --git a/src/modules/punk/args/tkcore-999999.0a1.0.tm b/src/modules/punk/args/moduledoc/tkcore-999999.0a1.0.tm similarity index 93% rename from src/modules/punk/args/tkcore-999999.0a1.0.tm rename to src/modules/punk/args/moduledoc/tkcore-999999.0a1.0.tm index beebd6fd..848ae6ba 100644 --- a/src/modules/punk/args/tkcore-999999.0a1.0.tm +++ b/src/modules/punk/args/moduledoc/tkcore-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::tkcore 999999.0a1.0 +# Application punk::args::moduledoc::tkcore 999999.0a1.0 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,11 +18,11 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::args::tkcore 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::args::moduledoc::tkcore 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::args::tkcore] +#[require punk::args::moduledoc::tkcore] #[keywords module] #[description] #[para] - @@ -31,7 +31,7 @@ #*** !doctools #[section Overview] -#[para] overview of punk::args::tkcore +#[para] overview of punk::args::moduledoc::tkcore #[subsection Concepts] #[para] - @@ -42,7 +42,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::args::tkcore +#[para] packages used by punk::args::moduledoc::tkcore #[list_begin itemized] package require Tcl 8.6- @@ -65,13 +65,13 @@ package require textblock -tcl::namespace::eval punk::args::tkcore { +tcl::namespace::eval punk::args::moduledoc::tkcore { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools - #[subsection {Namespace punk::args::tkcore}] - #[para] Core API functions for punk::args::tkcore + #[subsection {Namespace punk::args::moduledoc::tkcore}] + #[para] Core API functions for punk::args::moduledoc::tkcore #[list_begin definitions] tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase @@ -102,7 +102,7 @@ tcl::namespace::eval punk::args::tkcore { namespace eval argdoc { tcl::namespace::import ::punk::ansi::a+ - tcl::namespace::import ::punk::args::tkcore::manpage + tcl::namespace::import ::punk::args::moduledoc::tkcore::manpage # -- --- --- --- --- #non colour SGR codes # we can use these directly via ${$I} etc without marking a definition with @dynamic @@ -124,15 +124,15 @@ tcl::namespace::eval punk::args::tkcore { namespace eval argdoc { lappend PUNKARGS [list { - @id -id "(default)::punk::args::tkcore::common" + @id -id "(default)::punk::args::moduledoc::tkcore::common" } "@doc -name Manpage: -url [manpage index]" ] #list all tk_standardoptions #use punk::args::resolved_spec - #{${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions -disabledforeground -font ...]}} + #{${[punk::args::resolved_def -types opts (default)::punk::args::moduledoc::tkcore::tk_standardoptions -disabledforeground -font ...]}} ::punk::args::define { - @id -id "(default)::punk::args::tkcore::tk_standardoptions" + @id -id "(default)::punk::args::moduledoc::tkcore::tk_standardoptions" -activebackground -type colour -help\ "Specifies background color to use when drawing active elements. An element (a widget or portion of a widget) is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some @@ -388,7 +388,7 @@ tcl::namespace::eval punk::args::tkcore { @opts -type string -parsekey "" -group "STANDARD OPTIONS" -grouphelp\ "" }\ - {${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions\ + {${[punk::args::resolved_def -types opts (default)::punk::args::moduledoc::tkcore::tk_standardoptions\ -activebackground\ -activeforeground\ -anchor\ @@ -461,7 +461,7 @@ tcl::namespace::eval punk::args::tkcore { } #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tkcore ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tkcore ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -469,62 +469,41 @@ tcl::namespace::eval punk::args::tkcore { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tkcore::lib { +tcl::namespace::eval punk::args::moduledoc::tkcore::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] #*** !doctools - #[subsection {Namespace punk::args::tkcore::lib}] - #[para] Secondary functions that are part of the API + #[subsection {Namespace punk::args::moduledoc::tkcore::lib}] + #[para] Secondary functions that are part of the API #[list_begin definitions] - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tkcore::lib ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tkcore::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::args::tkcore::system { - #*** !doctools - #[subsection {Namespace punk::args::tkcore::system}] - #[para] Internal functions that are not part of the API - - - -#} - # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation # == === === === === === === === === === === === === === === -tcl::namespace::eval punk::args::tkcore { +tcl::namespace::eval punk::args::moduledoc::tkcore { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS variable PUNKARGS_aliases lappend PUNKARGS [list { - @id -id "(package)punk::args::tkcore" - @package -name "punk::args::tkcore" -help\ - "Package - Description" + @id -id "(package)punk::args::moduledoc::tkcore" + @package -name "punk::args::moduledoc::tkcore" -help\ + "punk::args documentation for Tk package" }] namespace eval argdoc { #namespace for custom argument documentation proc package_name {} { - return punk::args::tkcore + return punk::args::moduledoc::tkcore } proc about_topics {} { #info commands results are returned in an arbitrary order (like array keys) @@ -540,11 +519,11 @@ tcl::namespace::eval punk::args::tkcore { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::args::tkcore + punk::args::lib::tstr [string trim { + package punk::args::moduledoc::tkcore punk::args documentation for Tk } \n] } @@ -552,7 +531,7 @@ tcl::namespace::eval punk::args::tkcore { return "MIT" } proc get_topic_Version {} { - return "$::punk::args::tkcore::version" + return "$::punk::args::moduledoc::tkcore::version" } proc get_topic_Contributors {} { set authors {{Julian Noble -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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::tzint 999999.0a1.0 +# Application punk::args::moduledoc::tzint 999999.0a1.0 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,11 +18,11 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::args::tzint 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::args::moduledoc::tzint 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::args::tzint] +#[require punk::args::moduledoc::tzint] #[keywords module] #[description] #[para] - @@ -31,7 +31,7 @@ #*** !doctools #[section Overview] -#[para] overview of punk::args::tzint +#[para] overview of punk::args::moduledoc::tzint #[subsection Concepts] #[para] - @@ -42,7 +42,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::args::tzint +#[para] packages used by punk::args::moduledoc::tzint #[list_begin itemized] package require Tcl 8.6- @@ -62,13 +62,13 @@ package require Tcl 8.6- #[section API] -tcl::namespace::eval punk::args::tzint { +tcl::namespace::eval punk::args::moduledoc::tzint { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools - #[subsection {Namespace punk::args::tzint}] - #[para] Core API functions for punk::args::tzint + #[subsection {Namespace punk::args::moduledoc::tzint}] + #[para] Core API functions for punk::args::moduledoc::tzint #[list_begin definitions] variable PUNKARGS @@ -119,7 +119,7 @@ tcl::namespace::eval punk::args::tzint { #This implies "varName data" is optional - but in practice it seems not to be (?) "varName data" -type {string string} -optional 0 @opts - -symbology -type string -choicerestricted 0 -choices {${[::punk::args::tzint::argdoc::get_symbologies]}} + -symbology -type string -choicerestricted 0 -choices {${[::punk::args::moduledoc::tzint::argdoc::get_symbologies]}} -height -type integer -help\ "The height of a 1d symbol" -whitespace -type integer -help\ @@ -182,7 +182,7 @@ tcl::namespace::eval punk::args::tzint { #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tzint ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tzint ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -193,22 +193,21 @@ tcl::namespace::eval punk::args::tzint { # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation # == === === === === === === === === === === === === === === -tcl::namespace::eval punk::args::tzint { +tcl::namespace::eval punk::args::moduledoc::tzint { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS variable PUNKARGS_aliases lappend PUNKARGS [list { - @id -id "(package)punk::args::tzint" - @package -name "punk::args::tzint" -help\ - "Package - Description" + @id -id "(package)punk::args::moduledoc::tzint" + @package -name "punk::args::moduledoc::tzint" -help\ + "punk::args documentation for tzint package" }] namespace eval argdoc { #namespace for custom argument documentation proc package_name {} { - return punk::args::tzint + return punk::args::moduledoc::tzint } proc about_topics {} { #info commands results are returned in an arbitrary order (like array keys) @@ -216,7 +215,7 @@ tcl::namespace::eval punk::args::tzint { set about_topics [list] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + lappend about_topics [string range $tail [string length get_topic_] end] } #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] @@ -224,11 +223,11 @@ tcl::namespace::eval punk::args::tzint { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::args::tzint + punk::args::lib::tstr [string trim { + package punk::args::moduledoc::tzint description to come.. } \n] } @@ -236,7 +235,7 @@ tcl::namespace::eval punk::args::tzint { return "MIT" } proc get_topic_Version {} { - return "$::punk::args::tzint::version" + return "$::punk::args::moduledoc::tzint::version" } proc get_topic_Contributors {} { set authors {} @@ -261,23 +260,23 @@ tcl::namespace::eval punk::args::tzint { # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] - dict set overrides @id -id "::punk::args::tzint::about" - dict set overrides @cmd -name "punk::args::tzint::about" + dict set overrides @id -id "::punk::args::moduledoc::tzint::about" + dict set overrides @cmd -name "punk::args::moduledoc::tzint::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::args::tzint + About punk::args::moduledoc::tzint documentation for tzint package }] \n] - dict set overrides topic -choices [list {*}[punk::args::tzint::argdoc::about_topics] *] + dict set overrides topic -choices [list {*}[punk::args::moduledoc::tzint::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 - dict set overrides topic -default [punk::args::tzint::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + dict set overrides topic -default [punk::args::moduledoc::tzint::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] lappend PUNKARGS [list $newdef] proc about {args} { package require punk::args #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on - set argd [punk::args::parse $args withid ::punk::args::tzint::about] + set argd [punk::args::parse $args withid ::punk::args::moduledoc::tzint::about] lassign [dict values $argd] _leaders opts values _received - punk::args::package::standard_about -package_about_namespace ::punk::args::tzint::argdoc {*}$opts {*}[dict get $values topic] + punk::args::package::standard_about -package_about_namespace ::punk::args::moduledoc::tzint::argdoc {*}$opts {*}[dict get $values topic] } } # end of sample 'about' function @@ -291,14 +290,14 @@ tcl::namespace::eval punk::args::tzint { # variable PUNKARGS_aliases namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::args::tzint ::punk::args::tzint::argdoc + lappend ::punk::args::register::NAMESPACES ::punk::args::moduledoc::tzint ::punk::args::moduledoc::tzint::argdoc } # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready -package provide punk::args::tzint [tcl::namespace::eval punk::args::tzint { - variable pkg punk::args::tzint +package provide punk::args::moduledoc::tzint [tcl::namespace::eval punk::args::moduledoc::tzint { + variable pkg punk::args::moduledoc::tzint variable version set version 999999.0a1.0 }] diff --git a/src/modules/punk/args/tzint-buildversion.txt b/src/modules/punk/args/moduledoc/tzint-buildversion.txt similarity index 100% rename from src/modules/punk/args/tzint-buildversion.txt rename to src/modules/punk/args/moduledoc/tzint-buildversion.txt diff --git a/src/modules/punk/args/testcmd-999999.0a1.0.tm b/src/modules/punk/args/testcmd-999999.0a1.0.tm new file mode 100644 index 00000000..e27c2416 --- /dev/null +++ b/src/modules/punk/args/testcmd-999999.0a1.0.tm @@ -0,0 +1,349 @@ +# -*- 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.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::args::testcmd 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::args::testcmd { + variable PUNKARGS + namespace export * + namespace ensemble create + + proc proc1 {args} {return proc1-$args} + namespace eval aaa_ensemble { + namespace export * + namespace ensemble create + proc a1 {} {} + proc a2 {} {} + namespace eval deep_ensemble { + namespace export * + namespace ensemble create + punk::args::define { + @id -id ::punk::args::testcmd::aaa_ensemble::deep_ensemble::d1 + @cmd -name punk::args::testcmd::aaa_ensemble::deep_ensemble::d1\ + -summary\ + "d1 summary"\ + -help\ + "d1 help info" + @leaders + subcmd -help "d1 subcmd" + @opts + -force -type none -help "apply force" + @values -min 0 -max -1 + arg -type any -multiple 1 -optional 1 -help "items" + } + proc d1 {args} { + set argd [punk::args::parse $args withid ::punk::args::testcmd::aaa_ensemble::deep_ensemble::d1] + lassign [dict values $argd] leaders opts values received + puts "got leaders: $leaders" + puts "got opts : $opts" + puts "got values : $values" + } + proc d2 {} {} + punk::args::define\ + {@id -id ${[namespace current]}::d3}\ + {@cmd -name ${[namespace current]}::d3\ + -summary\ + "${[namespace current]}::d3 summary"\ + -help\ + "d3 help info" + @leaders + subcmd -help "d3 subcmd" + @opts + -force -type none -help "apply force" + @values -min 0 -max -1 + arg -type any -multiple 1 -optional 1 -help "items" + } + proc d3 {args} { + set argd [punk::args::parse $args withid [namespace current]::d3] + lassign [dict values $argd] leaders opts values received + puts "d3 got leaders: $leaders" + puts "d3 got opts : $opts" + puts "d3 got values : $values" + } + } + } + namespace eval custom_ensemble { + namespace export * + namespace ensemble create + namespace ensemble configure [namespace current] -map {sub ::punk::args::testcmd::custom_ensemble::tricky} + #this ensemble named 'sub' is actually not part of the 'undocumented' command's subcommands - as sub points to tricky" + namespace eval sub { + namespace export * + namespace ensemble create + proc s1 {} {} + proc s2 {args} {} + proc s3 {a b} {} + proc s4 {a {b defaultvalue}} {} + } + namespace eval tricky { + namespace export * + namespace ensemble create + proc t1 {} {} + proc t2 {args} {} + proc t3 {a b} {} + proc t4 {a {b defaultvalue}} {} + } + } + namespace eval bbb_subensemble { + namespace export * + namespace ensemble create + proc b1 {} {} + proc b2 {} {} + + #here we create a def for the trace subcommand from scratch + #we could also have pulled it directly from the "::trace" definition + #using something like: punk::args::resolved_def -override {@id {-id ::punk::args::testcmd::bbb_subensemble::trace}} ::trace + #instead we've chosen to hide some of the deprecated subcommands (these are only available in tcl < 9 anyway) + punk::args::define { + @id -id ::punk::args::testcmd::bbb_subensemble::trace + @cmd -name "simulated built-in: punk::args::testcmd::bbb_subensemble::trace"\ + -summary\ + "Monitor variable accesses, command usages and command executions."\ + -help\ + "This command causes Tcl commands to be executed whenever certain + operations are invoked. " + + @leaders -min 1 -max 1 + option -choicegroups { + "" {add remove info} + }\ + -choiceinfo { + add {{doctype punkargs} {subhelp ::trace add}} + remove {{doctype punkargs} {subhelp ::trace remove}} + info {{doctype punkargs} {subhelp ::trace info}} + } + @values -min 0 -max 0 + + } + proc trace {args} { + tailcall ::trace {*}$args + } + } + #undocumented intermediate command 'gapped' with documented subcommand 'g1' + proc undocumented {args} { + set subcommands [list doc1 undoc1 ensemble sub] + switch -- [lindex $args 0] { + doc1 { + punk::args::testcmd::undocumented::doc1 {*}[lrange $args 1 end] + } + undoc1 { + punk::args::testcmd::undocumented::undoc1 {*}[lrange $args 1 end] + } + ensemble { + punk::args::testcmd::undocumented::ensemble {*}[lrange $args 1 end] + } + sub { + #deliberately mismatch the subcommand identifier to the location of the ensemble. + #this is just to emphasize the fact that we can't assume anything about the location + #of any subcommands after the undocumented point. They may not even be in the ::punk::args::testcmd::undocumented namespace + #so guessing would be a bad idea. + punk::args::testcmd::undocumented::tricky {*}[lrange $args 1 end] + } + default { + error "unknown subcommand '[lindex $args 0]' known subcommands: $subcommands" + } + } + } + namespace eval undocumented { + punk::args::define { + @id -id "::punk::args::testcmd::undocumented doc1" + @cmd -name "punk::args::testcmd::undocumented doc1"\ + -summary\ + "doc1 summary"\ + -help\ + "doc1 help info" + @leaders + subcmd -help "doc1 subcmd" + @opts + -force -type none -help "apply force" + @values -min 0 -max -1 + arg -type any -multiple 1 -optional 1 -help "items" + } + proc doc1 {args} { + set argd [punk::args::parse $args withid "::punk::args::testcmd::undocumented doc1"] + lassign [dict values $argd] leaders opts values received + puts "got leaders: $leaders" + puts "got opts : $opts" + puts "got values : $values" + } + proc undoc1 {args} { + return undoc1 + } + namespace eval ensemble { + namespace export * + namespace ensemble create + proc e1 {} {} + proc e2 {args} {} + proc e3 {a b} {} + proc e4 {a {b defaultvalue}} {} + } + #this ensemble named 'sub' is actually not part of the 'undocumented' command's subcommands - as sub points to tricky" + namespace eval sub { + namespace export * + namespace ensemble create + proc s1 {} {} + proc s2 {args} {} + proc s3 {a b} {} + proc s4 {a {b defaultvalue}} {} + } + namespace eval tricky { + namespace export * + namespace ensemble create + proc t1 {} {} + proc t2 {args} {} + proc t3 {a b} {} + proc t4 {a {b defaultvalue}} {} + } + } +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::testcmd::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::args::testcmd::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::args::testcmd { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::args::testcmd" + @package -name "punk::args::testcmd" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::args::testcmd + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::args::testcmd + description to come.. + } \n] + } + proc get_topic_License {} { + return "" + } + proc get_topic_Version {} { + return "$::punk::args::testcmd::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::args::testcmd::about" + dict set overrides @cmd -name "punk::args::testcmd::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::args::testcmd + }] \n] + dict set overrides topic -choices [list {*}[punk::args::testcmd::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::args::testcmd::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::args::testcmd::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::args::testcmd::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::args::testcmd +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args::testcmd [tcl::namespace::eval punk::args::testcmd { + variable pkg punk::args::testcmd + variable version + set version 999999.0a1.0 +}] +return + diff --git a/src/modules/punk/args/tkcore-buildversion.txt b/src/modules/punk/args/testcmd-buildversion.txt similarity index 100% rename from src/modules/punk/args/tkcore-buildversion.txt rename to src/modules/punk/args/testcmd-buildversion.txt diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index a52ed555..13b77697 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -66,12 +66,14 @@ namespace eval punk::cap::handlers::templates { set multivendor_package_whitelist [list punk::mix::templates] - #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called + #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the base rather than rechecking it each time the templates handler api is called #for template pathtype absolute - we can do the same. #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. - #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #adhoc and currentproject* pathtypes are relative to cwd - so no base information can be stored at registration time. + #module pathtype base is resolved by the providing package itself at load time using 'info script' + + #not all template item types will need base information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -86,44 +88,19 @@ namespace eval punk::cap::handlers::templates { if {[file pathtype $path] ne "relative"} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" } - - #todo - check for mounted modpod (or tarjar?) - #e.g //zipfs:/#modpod/d1/d2/#mounted-modpod-libname-V.v - #(or equivalent for vfs eg c:/repo/jn/shellspy/modules/test/#modpod/test/#mounted-modpod-libname-V.v - - set provide_statement [package ifneeded $pkg [package require $pkg]] - set tmfile [lindex $provide_statement end] - if {[interp issafe]} { - #default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable - if {[catch {file exists $tmfile} tm_exists]} { - puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" - flush stderr - return 0 - } - } else { - set tm_exists [file exists $tmfile] - } - if {!$tm_exists} { - puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" - flush stderr + #The package should have provided a base folder (by using 'info script') when it was loaded + #'package ifneeded' for a module gives initial path information for a package - but it might redirect to sourcing from a different location such as being mounted elsewhere in a vfs, + #in which case we wouldn't get the correct path. + if {![dict exists $capdict base]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'base' key (required when pathtype is 'module')" return 0 } - set tmfolder [file dirname $tmfile] - #todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately - #set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - - #set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW - - #REVIEW - do we even want project base relative to where the lib came from?? - #should be relative to executable? or cwd? - set projectbase [punk::repo::find_project $tmfolder] - - #store the projectbase even if it's empty string set extended_capdict $capdict - set resolved_path [file join $tmfolder $path] + set base [dict get $capdict base] + set resolved_path [file join $base $path] dict set extended_capdict resolved_path $resolved_path - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base $base } currentproject_multivendor { #currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense @@ -156,14 +133,18 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" return 0 } - set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + #set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]] + #set projectinfo [punk::repo::find_repos $shellbase] - #set projectbase [dict get $projectinfo closest] - set projectbase [punk::repo::find_project $shellbase] + #set base [dict get $projectinfo closest] + + #may result in empty base for no project found + set base [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base $base } shellproject_multivendor { #currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense @@ -175,14 +156,15 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" return 0 } - set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + #set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]] #set projectinfo [punk::repo::find_repos $shellbase] - #set projectbase [dict get $projectinfo closest] - set projectbase [punk::repo::find_project $shellbase] + #set base [dict get $projectinfo closest] + set base [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base $base } absolute { if {[file pathtype $path] ne "absolute"} { @@ -194,15 +176,12 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" return 0 } - #set projectinfo [punk::repo::find_repos $normpath] - #set projectbase [dict get $projectinfo closest] - set projectbase [punk::repo::find_project $normpath] #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base "" } default { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype" @@ -332,16 +311,16 @@ namespace eval punk::cap::handlers::templates { set path [dict get $capdecl_extended path] set pathtype [dict get $capdecl_extended pathtype] set vendor [dict get $capdecl_extended vendor] - # projectbase not present in capdecl_extended for all template pathtypes + # base not present in capdecl_extended for all template pathtypes ? if {$pathtype eq "adhoc"} { #e.g (cwd)/templates set targetpath [file join $startdir [dict get $capdecl_extended path]] if {[file isdirectory $targetpath]} { - dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype] + dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype base $startdir] } } elseif {$pathtype eq "module"} { - set module_projectroot [dict get $capdecl_extended projectbase] - dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] + set mbase [dict get $capdecl_extended base] + dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $mbase] } elseif {$pathtype eq "currentproject_multivendor"} { #set searchbase $startdir #set pathinfo [punk::repo::find_repos $searchbase] @@ -357,11 +336,11 @@ namespace eval punk::cap::handlers::templates { set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *] foreach vf $vendorfolders { if {$vf ne "_project"} { - dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $pwd_projectroot] } } if {[file isdirectory [file join $vendorbase _project]]} { - dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $pwd_projectroot] } } set custombase [file join $deckbase custom] @@ -369,11 +348,11 @@ namespace eval punk::cap::handlers::templates { set customfolders [glob -nocomplain -dir $custombase -type d -tails *] foreach cf $customfolders { if {$cf ne "_project"} { - dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $pwd_projectroot] } } if {[file isdirectory [file join $custombase _project]]} { - dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $pwd_projectroot] } } } @@ -385,7 +364,7 @@ namespace eval punk::cap::handlers::templates { #path relative to projectroot already validated by handler as being within a currentproject_multivendor tree set targetfolder [file join $pwd_projectroot $path] if {[file isdirectory $targetfolder]} { - dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype] + dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $pwd_projectroot] } } } elseif {$pathtype eq "shellproject_multivendor"} { @@ -394,7 +373,7 @@ namespace eval punk::cap::handlers::templates { #set pathinfo [punk::repo::find_repos $shellbase] #set pwd_projectroot [dict get $pathinfo closest] - set shell_projectroot [dict get $capdecl_extended projectbase] + set shell_projectroot [dict get $capdecl_extended base] if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { @@ -406,11 +385,11 @@ namespace eval punk::cap::handlers::templates { set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *] foreach vf $vendorfolders { if {$vf ne "_project"} { - dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $shell_projectroot] } } if {[file isdirectory [file join $vendorbase _project]]} { - dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $shell_projectroot] } } set custombase [file join $deckbase custom] @@ -418,11 +397,11 @@ namespace eval punk::cap::handlers::templates { set customfolders [glob -nocomplain -dir $custombase -type d -tails *] foreach cf $customfolders { if {$cf ne "_project"} { - dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $shell_projectroot] } } if {[file isdirectory [file join $custombase _project]]} { - dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $shell_projectroot] } } @@ -434,17 +413,17 @@ namespace eval punk::cap::handlers::templates { #set pathinfo [punk::repo::find_repos $shellbase] #set pwd_projectroot [dict get $pathinfo closest] - set shell_projectroot [dict get $capdecl_extended projectbase] + set shell_projectroot [dict get $capdecl_extended base] if {$shell_projectroot ne ""} { set targetfolder [file join $shell_projectroot $path] if {[file isdirectory $targetfolder]} { - dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $shell_projectroot] } } } elseif {$pathtype eq "absolute"} { #lappend found_paths [dict get $capdecl_extended resolved_path] - set abs_projectroot [dict get $capdecl_extended projectbase] - dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot] + set abs_projectroot [dict get $capdecl_extended base] + dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $abs_projectroot] } } @@ -460,19 +439,19 @@ namespace eval punk::cap::handlers::templates { dict for {vendor pathinfolist} $found_paths_module { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } #Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD) dict for {vendor pathinfolist} $found_paths_shellproject_multivendor { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } dict for {vendor pathinfolist} $found_paths_shellproject { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } @@ -488,7 +467,7 @@ namespace eval punk::cap::handlers::templates { } dict for {vendor pathinfolist} $found_paths_absolute { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } #adhoc paths relative to cwd (or specified -startdir) can override any @@ -540,9 +519,9 @@ namespace eval punk::cap::handlers::templates { set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] - if {[dict exists $refinfo sourceinfo projectbase]} { + if {[dict exists $refinfo sourceinfo base]} { #some template pathtypes refer to the projectroot from the template - not the cwd - set ref_projectroot [dict get $refinfo sourceinfo projectbase] + set ref_projectroot [dict get $refinfo sourceinfo base] } else { set ref_projectroot $projectroot } diff --git a/src/modules/punk/icomm-999999.0a1.0.tm b/src/modules/punk/icomm-999999.0a1.0.tm index 4cc10b9b..48b3fd4d 100644 --- a/src/modules/punk/icomm-999999.0a1.0.tm +++ b/src/modules/punk/icomm-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::icomm 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::icomm 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/imap4-999999.0a1.0.tm b/src/modules/punk/imap4-999999.0a1.0.tm index 522d75fb..a9567b4a 100644 --- a/src/modules/punk/imap4-999999.0a1.0.tm +++ b/src/modules/punk/imap4-999999.0a1.0.tm @@ -1489,7 +1489,7 @@ tcl::namespace::eval punk::imap4 { Returns the Tcl channel to use in subsequent calls to the API. Other API commands will return zero on success. e.g - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { % set chan [CONNECT mail.example.com] sock123aaa456789 % AUTH_PLAIN $chan user pass diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 7455cb54..9e05020e 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -497,78 +497,6 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } - #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) - proc aliases {{glob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - set ns_mapped [string map {:: \uFFFF} $ns] - #puts stderr "aliases ns: $ns_mapped" - set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: - if {![string length [lindex $segments end]]} { - #special case for :: only include leading segment rather thatn {} {} - set segments [lrange $segments 0 end-1] - } - set segcount [llength $segments] ;#only match number of segments matching current ns - - - set all_aliases [interp aliases {}] - set matched [list] - foreach a $all_aliases { - #normalize with leading :: - if {![string match ::* $a]} { - set abs ::$a - } else { - set abs $a - } - - set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] - set acount [llength $asegs] - #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {($acount - 1) == $segcount} { - if {[lrange $asegs 0 end-1] eq $segments} { - if {[string match $glob [lindex $asegs end]]} { - #report this alias in the current namespace - even though there may be no matching command - lappend matched $a ;#add raw alias token which may or may not have leading :: - } - } - } - } - #set matched_abs [lsearch -all -inline $all_aliases $glob] - - return $matched - } - - proc alias {{aliasorglob ""} args} { - set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - if {[llength $args]} { - if {$aliasorglob in [interp aliases ""]} { - set existing [interp alias "" $aliasorglob] - puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" - } - if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { - #use empty string/whitespace as intention to delete alias - return [interp alias "" $aliasorglob ""] - } - return [interp alias "" $aliasorglob "" {*}$args] - } else { - if {![string length $aliasorglob]} { - set aliaslist [punk::lib::aliases] - puts -nonewline stderr $aliaslist - return - } - #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias - set target [interp alias "" $aliasorglob] - if {[llength $target]} { - return $target - } - - if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { - set aliaslist [punk::lib::aliases $aliasorglob] - puts -nonewline stderr $aliaslist - return - } - return [list] - } - } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -2242,7 +2170,51 @@ namespace eval punk::lib { } } + punk::args::define { + @id -id ::punk::lib::is_indexset + @cmd -name punk::lib::is_indexset\ + -summary\ + "Validate string is a comma-delimited 'indexset'."\ + -help\ + "Validate that a string is an 'indexset' + An indexset consists of a comma delimited list of indexes or index-ranges. + The indexes are 0-based. + Ranges must be specified with .. as the separator. + Common whitespace elements space,tab,newlines are ignored. + Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, + e.g end-2 or 2+2. + + see indexset_resolve" + @values -min 2 -max 2 + indexset -type string + } + proc is_indexset {indexset} { + #collapse internal whitespace (for basic whitespace set we allow) + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] + if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + return 0 + } + set ranges [split $indexset ,] + foreach r $ranges { + set validateindices [list] + set rposn [string first .. $r] + if {$rposn >= 0} { + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } else { + #'range' is just an index + set validateindices [list $r] + } + foreach v $validateindices { + if {$v eq "" || $v eq "end"} {continue} + if {[string is integer -strict $v]} {continue} + if {[catch {lindex {} $v}]} { + return 0 + } + } + } + return 1 + } #review - compare to IMAP4 methods of specifying ranges? punk::args::define { @id -id ::punk::lib::indexset_resolve @@ -2251,6 +2223,8 @@ namespace eval punk::lib { "Resolve an indexset to a list of integers based on supplied list or string length."\ -help\ "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. + e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 + An indexset consists of a comma delimited list of indexes or index-ranges. The indexes are 0-based. Ranges must be specified with .. as the separator. @@ -2258,27 +2232,30 @@ namespace eval punk::lib { Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. - end means the last page. - end-1 means the second last page. + end means the last item. + end-1 means the second last item. 0.. is the same as 0..end. - examples: + indexset examples: 1,3.. - output the page index 1 (2nd page) followed by all from index 3 to the end. + output the index 1 (2nd item) followed by all from index 3 to the end. + 'indexset_resolve 4 1,3..' -> 1 3 + 'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9 0-2,end - output the first 3 pages, and the last page. + output the first 3 indices, and the last index. end-1..0 - output the indexes in reverse order from 2nd last page to first page." + output the indexes in reverse order from 2nd last item to first item." @values -min 2 -max 2 numitems -type integer - indexset -type string + indexset -type indexset -help "comma delimited specification for indices to return" } proc indexset_resolve {numitems indexset} { - if {![string is integer -strict $numitems] || ![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] - } - set index_list [list] ;#list of actual indexes within the range + } + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace + set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] set index_list [list] foreach ipart $iparts { @@ -2286,7 +2263,7 @@ namespace eval punk::lib { set rposn [string first .. $ipart] if {$rposn>=0} { #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb + lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb set rawa [string trim $rawa] set rawb [string trim $rawb] if {$rawa eq ""} {set rawa 0} diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm index f9dfaf56..e0532e41 100644 --- a/src/modules/punk/libunknown-0.1.tm +++ b/src/modules/punk/libunknown-0.1.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# 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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::libunknown 0 0.1] +#[manpage_begin punkshell_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-0.2.tm b/src/modules/punk/mix-0.2.tm index 1ac6a836..e3f2cb16 100644 --- a/src/modules/punk/mix-0.2.tm +++ b/src/modules/punk/mix-0.2.tm @@ -7,6 +7,11 @@ tcl::namespace::eval punk::mix { package require punk::cap::handlers::templates ;#handler for templates cap punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap set t [time { if {[catch {punk::mix::templates::provider register *} errM]} { diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates-999999.0a1.0.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates-999999.0a1.0.tm new file mode 100644 index 00000000..3f4ecd6d --- /dev/null +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates-999999.0a1.0.tm @@ -0,0 +1,97 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::templates 999999.0a1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + +# The default provider for the 'punk.templates' capability + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::cap + +namespace eval punk::mix::templates [list variable modulefile [info script]] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::templates { + variable pkg punk::mix::templates + variable cap_provider + variable decls [list] + + lappend decls [list punk.templates [list path templates pathtype module base [file dirname $modulefile] vendor punk]] + + lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? + + #only punk::templates is allowed to register a _multivendor path - review + #other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only + lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] + lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] + + + #we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! + #need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version + #perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) + #review - the job of this templates package is just to point to where the templates are located, not to specify how they're updated? + lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] + lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. + #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. + + namespace eval capsystem { + if {[info commands capprovider.registration] eq ""} { + punk::cap::class::interface_capprovider.registration create capprovider.registration + oo::objdefine capprovider.registration { + method get_declarations {} { + return $::punk::mix::templates::decls + } + } + } + } + + if {[info commands provider] eq ""} { + punk::cap::class::interface_capprovider.provider create provider punk::mix::templates + oo::objdefine provider { + method register {{capabilityname_glob *}} { + #puts registering punk::mix::templates $capabilityname + next $capabilityname_glob + } + method capabilities {} { + next + } + } + } + + # -- --- + #provider api + # -- --- + #none - declarations only + #todo - template folder install/update/status methods? +} + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::templates [namespace eval punk::mix::templates { + variable version + set version 999999.0a1.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/templates/layout_refs/project@vendor+punk+project-0.1.ref b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layout_refs/project@vendor+punk+project-0.1.ref similarity index 100% rename from src/modules/punk/mix/templates/layout_refs/project@vendor+punk+project-0.1.ref rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layout_refs/project@vendor+punk+project-0.1.ref diff --git a/src/modules/punk/mix/templates/layouts/project/src/build.tcl b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/build.tcl similarity index 100% rename from src/modules/punk/mix/templates/layouts/project/src/build.tcl rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/build.tcl diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/make.tcl similarity index 100% rename from src/modules/punk/mix/templates/layouts/project/src/make.tcl rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/make.tcl diff --git a/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl similarity index 100% rename from src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl diff --git a/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modpod/template_modpod-0.0.1/modpod-module-version/z similarity index 100% rename from src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modpod/template_modpod-0.0.1/modpod-module-version/z diff --git a/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modpod/template_modpod-0.0.1/test.zip similarity index 100% rename from src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modpod/template_modpod-0.0.1/test.zip diff --git a/src/modules/punk/mix/templates/modules/modulename_buildversion.txt b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/modulename_buildversion.txt similarity index 100% rename from src/modules/punk/mix/templates/modules/modulename_buildversion.txt rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/modulename_buildversion.txt diff --git a/src/modules/punk/mix/templates/modules/modulename_description.txt b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/modulename_description.txt similarity index 100% rename from src/modules/punk/mix/templates/modules/modulename_description.txt rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/modulename_description.txt diff --git a/src/modules/punk/mix/templates/modules/template_anyname-0.0.2.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_anyname-0.0.2.tm similarity index 100% rename from src/modules/punk/mix/templates/modules/template_anyname-0.0.2.tm rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_anyname-0.0.2.tm diff --git a/src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_cli-0.0.1.tm similarity index 100% rename from src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_cli-0.0.1.tm diff --git a/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.1.tm similarity index 100% rename from src/modules/punk/mix/templates/modules/template_module-0.0.1.tm rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.1.tm diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm new file mode 100644 index 00000000..cad941f9 --- /dev/null +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm @@ -0,0 +1,161 @@ +# -*- 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: %moduletemplate% +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) %year% +# +# @@ Meta Begin +# Application %pkg% 999999.0a1.0 +# Meta platform tcl +# Meta license %license% +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval %pkg% { + variable PUNKARGS + + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval %pkg%::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval %pkg%::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval %pkg% { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)%pkg%" + @package -name "%pkg%" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return %pkg% + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package %pkg% + description to come.. + } \n] + } + proc get_topic_License {} { + return "%license%" + } + proc get_topic_Version {} { + return "$::%pkg%::version" + } + proc get_topic_Contributors {} { + set authors {%authors%} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::%pkg%::about" + dict set overrides @cmd -name "%pkg%::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About %pkg% + }] \n] + dict set overrides topic -choices [list {*}[%pkg%::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [%pkg%::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::%pkg%::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::%pkg%::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::%pkg% +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide %pkg% [tcl::namespace::eval %pkg% { + variable pkg %pkg% + variable version + set version 999999.0a1.0 +}] +return + diff --git a/src/modules/punk/mix/templates/modules/template_moduleexactversion-0.0.1.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_moduleexactversion-0.0.1.tm similarity index 100% rename from src/modules/punk/mix/templates/modules/template_moduleexactversion-0.0.1.tm rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_moduleexactversion-0.0.1.tm diff --git a/src/modules/punk/mix/templates/utility/multishell.ps1 b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/multishell.ps1 similarity index 100% rename from src/modules/punk/mix/templates/utility/multishell.ps1 rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/multishell.ps1 diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd similarity index 99% rename from src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd index 3bf8e0b1..dbe4c1d4 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd @@ -442,11 +442,19 @@ SETLOCAL EnableDelayedExpansion :: Example usage @rem call :getUniqueFile "d:\test\myFile" ".txt" myFile @rem echo myFile="%myFile%" - +@rem 2025 - wmic deprecated :/ +@rem 2025 - output of 'wmic os get localDateTime' was something like: +@rem LocalDateTime +@rem 20251015234316.777000+660 +@rem !time! has a resolution of centiseconds. As we test in a loop for file existence, that should be ok. :getUniqueFile baseName extension rtnVar -setlocal +setlocal enabledelayedexpansion :getUniqueFileLoop -for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +set "r=!date!_!time!" +set "r=%r::=.%" +set "r=%r: =%" +set "rtn=%~1_!r!%~2" +echo "### %rtn%" if exist "%rtn%" ( goto :getUniqueFileLoop ) else ( @@ -454,6 +462,7 @@ if exist "%rtn%" ( ) endlocal & set "%~3=%rtn%" exit /b + %= ---------------------------------------------------------------------- =% @REM padding diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell1.cmd similarity index 100% rename from src/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell1.cmd diff --git a/src/modules/punk/mix/templates/utility/shellbat_v1.txt b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/shellbat_v1.txt similarity index 100% rename from src/modules/punk/mix/templates/utility/shellbat_v1.txt rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/shellbat_v1.txt diff --git a/src/modules/punk/mix/templates/utility/tclbatheader.txt b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/tclbatheader.txt similarity index 100% rename from src/modules/punk/mix/templates/utility/tclbatheader.txt rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/tclbatheader.txt diff --git a/src/modules/punk/mix/templates/utility/tclbattest.bat b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/tclbattest.bat similarity index 100% rename from src/modules/punk/mix/templates/utility/tclbattest.bat rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/tclbattest.bat diff --git a/src/modules/punk/mix/templates/utility/tclbattest2.bat b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/tclbattest2.bat similarity index 100% rename from src/modules/punk/mix/templates/utility/tclbattest2.bat rename to src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/tclbattest2.bat diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm index 1ff76ba1..02e14428 100644 --- a/src/modules/punk/mix/cli-999999.0a1.0.tm +++ b/src/modules/punk/mix/cli-999999.0a1.0.tm @@ -480,7 +480,7 @@ namespace eval punk::mix::cli { } #repotypes *could* be both git and fossil - so report both if so if {"git" in $repotypes} { - append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n + append result "\nGIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n if {[string length [set git_prog [auto_execok git]]]} { set git_remotes [exec {*}$git_prog remote -v] append result $git_remotes @@ -791,10 +791,10 @@ namespace eval punk::mix::cli { if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { - puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" $event targetset_end FAILED -note "could not copy $modulefile" } else { - puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" # -- --- --- --- --- --- $event targetset_end OK -note "zip modpod" } @@ -821,7 +821,7 @@ namespace eval punk::mix::cli { if {$tmfile_versionsegment eq $magicversion} { set versionfiledata "" if {![file exists $versionfile]} { - puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]" puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" set module_build_version "0.1" } else { @@ -830,7 +830,7 @@ namespace eval punk::mix::cli { set ln0 [lindex [split $versionfiledata \n] 0] set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] if {![util::is_valid_tm_version $ln0]} { - puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + puts stderr "ERROR:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]" exit 3 } set module_build_version $ln0 @@ -973,10 +973,10 @@ namespace eval punk::mix::cli { if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { - puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]" $event targetset_end FAILED -note "could not copy $modulefile" } else { - puts stderr "Copied tarjar module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]" # -- --- --- --- --- --- $event targetset_end OK -note "tarjar" } diff --git a/src/modules/punk/mix/templates-999999.0a1.0.tm b/src/modules/punk/mix/templates-999999.0a1.0.tm deleted file mode 100644 index a1d36631..00000000 --- a/src/modules/punk/mix/templates-999999.0a1.0.tm +++ /dev/null @@ -1,94 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2023 -# -# @@ Meta Begin -# Application punk::mix::templates 999999.0a1.0 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz -package require punk::cap - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::mix::templates { - variable pkg punk::mix::templates - variable cap_provider - - namespace eval capsystem { - if {[info commands capprovider.registration] eq ""} { - punk::cap::class::interface_capprovider.registration create capprovider.registration - oo::objdefine capprovider.registration { - method get_declarations {} { - set decls [list] - lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? - - lappend decls [list punk.templates {path templates pathtype module vendor punk}] - #only punk::templates is allowed to register a _multivendor path - review - #other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only - lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] - lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] - - - #we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! - #need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version - #perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) - lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] - lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. - #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. - return $decls - } - } - } - } - - if {[info commands provider] eq ""} { - punk::cap::class::interface_capprovider.provider create provider punk::mix::templates - oo::objdefine provider { - method register {{capabilityname_glob *}} { - #puts registering punk::mix::templates $capabilityname - next $capabilityname_glob - } - method capabilities {} { - next - } - } - } - - # -- --- - #provider api - # -- --- - #none - declarations only - #todo - template folder install/update/status methods? -} - - - - - - - - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::mix::templates [namespace eval punk::mix::templates { - variable version - set version 999999.0a1.0 -}] -return \ No newline at end of file diff --git a/src/modules/punk/mix/templates-buildversion.txt b/src/modules/punk/mix/templates-buildversion.txt index f47d01c8..32568297 100644 --- a/src/modules/punk/mix/templates-buildversion.txt +++ b/src/modules/punk/mix/templates-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.2 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/netbox-999999.0a1.0.tm b/src/modules/punk/netbox-999999.0a1.0.tm index 6f7ce699..c391dc66 100644 --- a/src/modules/punk/netbox-999999.0a1.0.tm +++ b/src/modules/punk/netbox-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::netbox 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::netbox 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/netbox/man-999999.0a1.0.tm b/src/modules/punk/netbox/man-999999.0a1.0.tm index 93baf0c6..490519b1 100644 --- a/src/modules/punk/netbox/man-999999.0a1.0.tm +++ b/src/modules/punk/netbox/man-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::netbox::man 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::netbox::man 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 945737cc..9b09b2be 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -36,7 +36,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -172,7 +172,7 @@ tcl::namespace::eval punk::ns { #needed to use n/ to change to an oddly named namespace such as ":x" proc nsexists {nspath} { if {$nspath eq ""} {return 0} - set parts [nsparts $nspath] + set parts [nsparts_cached $nspath] if {[lindex $parts 0] ne ""} { #relative set ns_caller [uplevel 1 {::namespace current}] @@ -191,7 +191,7 @@ tcl::namespace::eval punk::ns { #approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection #WARNING: creates namespaces if they don't exist proc nseval_getscript {location} { - set parts [nsparts $location] + set parts [nsparts_cached $location] if {[lindex $parts 0] eq ""} { lset parts 0 :: } @@ -400,19 +400,185 @@ tcl::namespace::eval punk::ns { return [join $nonempty_segments ::] } + #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) + #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #nsparts will prefer leading colon (ie greedy on ::) + #This is important to support leading colon commands such as :/ + # ie ::punk:::jjj:::etc -> :: punk :jjj :etc + proc nsparts1 {nspath} { + set nspath [string map {:::: ::} $nspath] + set mapped [string map {:: \u0FFF} $nspath] + set parts [split $mapped \u0FFF] + #if {[lindex $parts end] eq ""} { + #} + return $parts + } + + + #Memory leak for systems that create and delete a lot of differently names namespaces/commands - review + #consider configuration option to disable for large long-running systems? + #re-code nsparts in c/zig to make a performant version and avoid caching? + variable nsparts_cache [dict create] + proc nsparts_cached {nspath} { + variable nsparts_cache + if {[dict exists $nsparts_cache $nspath]} { + return [dict get $nsparts_cache $nspath] + } + set parts [nsparts $nspath] + dict set nsparts_cache $nspath $parts + return $parts + } + #not that nsparts is insanely slow - but it's called frequently - hence nsparts_cached + #noticeable for example when calling punk::ns::aliases whilst in global namespaces. + proc nsparts {nspath} { + #note that if all of :, :ns and ns: are valid namespace names (and they technically are in Tcl) + #we get ambiguities if trying to join them. + #eg ::a:::b could be "::a: b" or "::a :b" + #however a::::b would unambiguously be "a: :b" + #and a:::::b could only be "a : b" + # a::::::b could be "a: : b" or "a : :b" + #(ambiguities on mod 3 == 0 number of colons only?) + #leading ::::x could be ": :x" - but it is probably commonly relied on in tcl scripts that this resolves to just ::x + #A consistent rule to avoid ambiguity would need to be + # "no leading/trailing colons in namespace names" + # or "no leading colons in namespace names (except bare colon)" + # or "no trailing colons in namespace names (except bare colon)" + # + #The no trailing version has more utility - (sorting of colon namespaces together) and would allow processing of runs of colons left-to-right + #There remains ambiguity in that a relative namespace involving leading colons can't always be distinguished from an absolute namespace. + #ie :::x could represent ":x" in absolute terms or ": x" as a relative path. + #as leading :: is the normal way to decide a namespace is absolute - this leaves no way of specifying a relative namespace if the next sub namespace is just ":" + # + #for no trailing colon + #number of intermediate colons cannot be a number in the sequence + #4,7,10,13,16,19,22... + #if it is - we must trip 2 colons + #4 x::::x -> x::x = x,x + #7 x:::::::x -> x:::::x = x,:,x + #10 x::::::::::x -> x::::::::x = x,:,:,x + + #after stripping 2 - valid nums are + #1 x:x (internal - part of ns) + #2 x::x + #3 x:: :x + #5 x:: : ::x + #6 x:: : :: :x + #8 x:: : :: : ::x + #9 x:: : :: : :: :x + #11 x:: : :: : :: : ::x + #12 x:: : :: : :: : :: :x + #14 x:: : :: : :: : :: : ::x + #15 x:: : :: : :: : :: : :: :x + #17 x:: : :: : :: : :: : :: : ::x + #18 x:: : :: : :: : :: : :: : :: :x + + if {$nspath eq ""} { + return "" + } + + set s 0 + set parts [list] + set p "" + set cend -1 + while {[regexp -start $s -indices {(:+)[^:]*} $nspath _all cindices]} { + lassign $cindices cstart cend + append p [string range $nspath $s $cstart-1] + set numcolons [expr {$cend - $cstart + 1}] + if {$numcolons == 1} { + #internal colon + append p : + set s [expr {$cend+1}] + continue + } elseif {$numcolons == 2} { + lappend parts $p + set p "" + set s [expr {$cend+1}] + continue + } elseif {($numcolons -1) % 3 == 0} { + set numcolons [expr {$numcolons -2}] + } + #assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence + if {$numcolons % 3 == 0} { + #if numcolons % 3 == 0 we have a leading colon left for next ns + #this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y + #we resolve with allowing leading colons only for each ns. + set singlec_count [expr {($numcolons /3) -1}] + if {$singlec_count > 0} { + lappend parts $p {*}[lrepeat $singlec_count :] + } else { + lappend parts $p + } + set p ":" + set s [expr {$cend+1}] + continue + } else { + set singlec_count [expr {(($numcolons +1)/3) -1}] + if {$singlec_count > 0} { + lappend parts $p {*}[lrepeat $singlec_count :] + } else { + lappend parts $p + } + set p "" + set s [expr {$cend+1}] + } + } + if {$cend < ([string length $nspath]-1)} { + lappend parts $p[string range $nspath $cend+1 end] + } else { + #trailing colons + set numcolons [expr {$cend - $cstart + 1}] + lappend parts $p + } + return $parts + } + + proc nsprefix {{nspath ""}} { + set prefixparts [lrange [nsparts_cached $nspath] 0 end-1] + if {[llength $prefixparts] == 1 && [lindex $prefixparts 0] eq ""} { + return :: + } + return [join $prefixparts ::] + } #REVIEW - the combination of nsprefix & nstail are designed to *almost* always be able to reassemble the input, and to be independent of what namespaces actually exist #The main difference being collapsing (or ignoring) repeated double-colons #we need to distinguish unprefixed from prefixed ie ::x vs x #There is an apparent inconsistency with nstail ::a:::x being able to return :x - #whereas nsprefix :::a will return just a + #whereas nsprefix :::a will return just ::a #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. # - #nsprefix is *somewhat* like 'namespace parent' execept that it is string based - ie no requirement for the namespaces to actually exist + #nsprefix is *somewhat* like 'namespace parent' except that it is string based - ie no requirement for the namespaces to actually exist # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. - proc nsprefix {{nspath ""}} { + #nsprefix is more like 'namespace qualifiers' - but can return the global namespace as :: instead of empty string. + proc nsprefix1 {{nspath ""}} { + #normalize the common case of leading :::: and also collapse any internal runs of 4 (there can be no namespace named as empty string - as this is reserved for global ns by Tcl) + + while {[regexp {::::} $nspath]} { + set nspath [string map {:::: ::} $nspath] + } + set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + #return [string trimright $rawprefix :] + } + } + #deprecated + proc nsprefix_orig {{nspath ""}} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] @@ -428,13 +594,19 @@ tcl::namespace::eval punk::ns { } } + proc nstail {nspath} { + return [lindex [nsparts_cached $nspath] end] + } + #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands #For most purposes 'namespace tail' is fine. - proc nstail {nspath args} { + proc nstail1 {nspath args} { #normalize the common case of :::: - set nspath [string map {:::: ::} $nspath] + while {[regexp {::::} $nspath]} { + set nspath [string map {:::: ::} $nspath] + } #it's unusual - but namespaces *can* have spaced in them. set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] @@ -454,28 +626,31 @@ tcl::namespace::eval punk::ns { #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. return [lindex $parts end] } - - #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) - #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them - #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string - #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. - #nsparts will prefer leading colon (ie greedy on ::) - #This is important to support leading colon commands such as :/ - # ie ::punk:::jjj:::etc -> :: punk :jjj :etc - proc nsparts {nspath} { + #deprecated + proc nstail_orig {nspath args} { + #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] + #it's unusual - but namespaces *can* have spaced in them. set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] - #if {[lindex $parts end] eq ""} { - #} - return $parts + + set defaults [list -strict 0] + set opts [dict merge $defaults $args] + set strict [dict get $opts -strict] + + if {$strict} { + foreach p $parts { + if {[string match :* $p]} { + error "nstail unpaired colon ':' in $nspath" + } + } + } + + #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. + return [lindex $parts end] } + #tcl 8.x has creative writing var weirdness.. tcl 9 is likely to differ proc nsvars {{nsglob "*"}} { set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $nsglob]] @@ -484,7 +659,7 @@ tcl::namespace::eval punk::ns { set searchns [nsprefix $ns_absolute] ;#the ns within which we want to searchns set searchall [nsjoin $searchns *] ;#will correctly form ::* or ::childns::* - set nsparts [nsparts $searchns] + set nsparts [nsparts_cached $searchns] set weird_ns 0 if {[lsearch $nsparts :*] >=0} { set weird_ns 1 @@ -522,7 +697,7 @@ tcl::namespace::eval punk::ns { proc nsglob_as_re {glob} { #any segment that is not just * must match exactly one segment in the path set pats [list] - foreach seg [nsparts $glob] { + foreach seg [nsparts_cached $glob] { if {$seg eq ""} { set seg "" } @@ -609,7 +784,7 @@ tcl::namespace::eval punk::ns { set base "" set tailparts [list] if {$CALLDEPTH == 0} { - set parts [nsparts $ns_absolute] + set parts [nsparts_cached $ns_absolute] lset parts 0 :: set idx 0 if {$has_globchars} { @@ -635,8 +810,10 @@ tcl::namespace::eval punk::ns { #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] + #jjj #set allchildren [lsort [nseval $base [list ::namespace children]]] - set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] + #set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] + set allchildren [lsort [nseval $base [list ::namespace children]]] #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" @@ -767,18 +944,22 @@ tcl::namespace::eval punk::ns { } + #review ooc vs classmethod ooo vs objectmethod ? punk::args::define { @id -id ::punk::ns::Cmark @cmd -name punk::ns::Cmark @leaders - type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { - oo " symbol \u25c6" - ooc " symbol \u25c7" - ooo " symbol \u25c8" - punkargs " symbol \u24d8" - ensemble " symbol \u24ba" - native " symbol \u24c3" - unknown " symbol \u2370" + type -choices {oo ooc classmethod coremethod ooo objectmethod punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + classmethod " symbol \u25c7" + coremethod " symbol \u25c9" + ooo " symbol \u25c8" + objectmethod " symbol \u25c8" + punkargs " symbol \u24d8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" } @opts @values -min 0 -max -1 @@ -794,23 +975,134 @@ tcl::namespace::eval punk::ns { return; #should be unreachable - parse should raise usage error } set type [lindex $args 0] - set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set type [tcl::prefix::match -error "" {oo ooc classmethod coremethod ooo objectmethod punkargs ensemble native unknown} $type] set ansinames [lrange $args 1 end] switch -- $type { - oo - ooc - ooo - punkargs - ensemble - native - unknown {} + oo - ooc - classmethod - coremethod - ooo - objectmethod - punkargs - ensemble - native - unknown {} default { #punk::args::usage ::punk::ns::Cmark punk::args::parse $args withid ::punk::ns::Cmark return; #should be unreachable - parse should raise usage error } } - set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] + set marks [dict create oo \u25c6 ooc \u25c7 classmethod \u25c7 coremethod \u25c9 ooo \u25c8 objectmethod \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { return [dict get $marks $type] } } + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{tailglob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + + set ns_segments [nsparts_cached $ns] ;#include empty string before leading :: + if {![string length [lindex $ns_segments end]]} { + #special case for :: only include leading segment rather than {} {} + set ns_segments [lrange $ns_segments 0 end-1] + } + set segcount [llength $ns_segments] ;#only match number of segments matching current ns + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + if {[string match ${ns}* $abs] && [string match *::$tailglob $abs]} { + #Note that string match *::$tailglob $abs is not a proper match for all possible tailglobs + #It reduces our search space to avoid too many 'nsparts' calls, but has false positives - still need to match tailglob to last segment only in the loop. + set asegs [nsparts_cached $abs] + #set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $ns_segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $ns_segments} { + if {[string match $tailglob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + return $matched + } + proc aliases1 {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::ns::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::ns::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } #REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc.. punk::args::define { @@ -1316,6 +1608,14 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } + punk::args::define { + @id -id ::punk::ns::cmdtype + @cmd -name punk::ns::cmdtype -help\ + "" + @values -min 1 -max 1 + cmd -help\ + "namespace-relative or namespace-absolute path of command." + } #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc @@ -1323,7 +1623,7 @@ tcl::namespace::eval punk::ns { #it is not desirable to do a partial cmdtype support here proc cmdtype {cmd} { #set cmd [namespace which $cmd] ;#will return empty result for empty string command or command such as :x or any command that doesn't exist - set fqcmd [namespace which $cmd] ;#will resolve for example 'namespace path' reachable commands + set fqcmd [uplevel 1 [list ::namespace which $cmd]] ;#will resolve for example 'namespace path' reachable commands if {$fqcmd eq ""} { #e.g ::ns:::x will return empty result from namespace which even if :x is a command in ::ns set where [nsprefix $cmd] @@ -1338,7 +1638,7 @@ tcl::namespace::eval punk::ns { set what [nstail $fqcmd] } #ensure we con't call 'namespace eval' on a nonexistent ns and create cruft namespaces - set parts [nsparts $where] + set parts [nsparts_cached $where] if {[lsearch $parts :*] > -1} { set weird_ns 1 if {![nsexists $where]} { @@ -1356,11 +1656,12 @@ tcl::namespace::eval punk::ns { if {[interp issafe]} { #todo - weird_ns if {[catch {namespace eval $where [list ::tcl::info::cmdtype $what]} result]} { - if {[info commands ::cmdtype] ne ""} { - #hack - look for an alias that may have been specifically enabled to bring this back - tailcall ::cmdtype $cmd + #hack - look for an alias that may have been specifically enabled to bring this back + #review - why this name? + if {[info commands ::info_cmdtype] ne ""} { + return [namespace eval $where [list ::info_cmdtype $what]] } - return na + #fall-through to below } else { return $result } @@ -1370,19 +1671,103 @@ tcl::namespace::eval punk::ns { if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { return notfound } else { - return [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] + set tclcmdtype [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] + if {$tclcmdtype eq "object"} { + if {[nseval_ifexists $where [list ::info object isa class $what]]} { + set tclcmdtype ooclass + } else { + set tclcmdtype ooobject + } + } } } else { if {[namespace eval $where [list ::info commands $what]] eq ""} { #e.g parray if it hasn't yet been called (an auto_path loaded command) return notfound } else { - tailcall namespace eval $where [list ::tcl::info::cmdtype $what] + set tclcmdtype [namespace eval $where [list ::tcl::info::cmdtype $what]] + if {$tclcmdtype eq "object"} { + if {[namespace eval $where [list ::info object isa class $what]]} { + set tclcmdtype ooclass + } else { + set tclcmdtype ooobject + } + } + } + } + return $tclcmdtype + } + # CCC + set locationparts [nsparts_cached $where] + set weird_ns 0 + set c "" + if {[lsearch $locationparts :*] >= 0} { + set weird_ns 1 + } + if {$weird_ns} { + if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { + return notfound + } + } else { + if {[namespace eval $where [list ::info commands $what]] eq ""} { + #e.g parray if it hasn't yet been called (an auto_path loaded command) + return notfound + } + } + if {$weird_ns} { + set cmdorigin [nseval_ifexists $where [list ::namespace origin $what]] + } else { + set cmdorigin [namespace eval $where [list ::namespace origin $what]] + } + if {[nsprefix $cmdorigin] ne $where} { + return import + } + if {$weird_ns} { + set c [nseval_ifexists $where [list ::info commands $what]] + } else { + set c [tcl::namespace::eval $where [list ::info commands $what]] + } + if {$c ne ""} { + #if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} {} + set script [string map [list %w% $what] { + ::if {![::catch [::list ::namespace ensemble configure "%w%"]]} { + ::return ensemble + } elseif {[::info object isa class "%w%"]} { + ::return ooclass + } elseif {[::info object isa object "%w%"]} { + ::return ooobject } + }] + if {$weird_ns} { + set o [nseval_ifexists $where $script] + } else { + set o [tcl::namespace::eval $where $script] + } + if {$o ne ""} { + return $o } + } else { + return notfound + } + if {$weird_ns} { + set p [nseval_ifexists $where [list ::info procs $what]] + } else { + set p [tcl::namespace::eval $where [list ::info procs $what]] + } + if {$p ne ""} { + return proc + } + + #punk::ns::aliases last - as probably slowest + if {$weird_ns} { + set a [nseval_ifexists $where [list ::punk::ns::aliases $what]] + } else { + set a [tcl::namespace::eval $where [list ::punk::ns::aliases $what]] + } + if {$a ne ""} { + return alias } - #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller - #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob @@ -1391,7 +1776,6 @@ tcl::namespace::eval punk::ns { #glob chars in the path will result in multiple namespaces being matched #e.g ::tcl::*::d* will match commands beginning with d and child namespaces beginning with d in any namespaces 1 below ::tcl proc get_ns_dicts {fq_glob args} { - #JMN #puts stderr "get_ns_dicts $fq_glob" set glob_is_absolute [expr {[string match ::* $fq_glob]}] if {!$glob_is_absolute} { @@ -1456,9 +1840,9 @@ tcl::namespace::eval punk::ns { } -#JMN +# CCC set location $ch - set locationparts [nsparts $location] + set locationparts [nsparts_cached $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { set weird_ns 1 @@ -1537,11 +1921,11 @@ tcl::namespace::eval punk::ns { set allundetermined [list] set interp_aliases [interp aliases ""] #use aliases glob - because aliases can be present with or without leading :: - #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases + #NOTE: alias may not have matching command in the relevant namespace (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::ns::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::ns::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] @@ -1567,144 +1951,107 @@ tcl::namespace::eval punk::ns { # lappend allaliases $cmd #} set ctype [cmdtype ${location}::$cmd] - switch -- $ctype { - na { - if {$weird_ns} { - set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] - } else { - set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] - } - if {[nsprefix $cmdorigin] ne $location} { - #import - lappend allimported $cmd - set origin_location [nsprefix $cmdorigin] - } else { - set origin_location $location - } - #tcl 8.6 (info cmdtype unavailable) - #todo - use catch tcl::unsupported::corotype to see if coroutine - set originlocationparts [nsparts $origin_location] - set weird_origin 0 - if {[lsearch $originlocationparts :*] >= 0} { - set weird_origin 1 - } - if {$weird_origin} { - if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd - } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { - lappend allooobjects $cmd - if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { - lappend allooclasses $cmd - } - } else { - - } - } else { - if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd - } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { - lappend allooobjects $cmd - if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { - lappend allooclasses $cmd - } - } else { - + if {$ctype eq "import"} { + if {$weird_ns} { + set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] + } else { + set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] + } + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #ie we don't need to follow a chain of 'imported' results. + set origin_location [nsprefix $cmdorigin] + set origin_cmd [nstail $cmdorigin] + + set originlocationparts [nsparts_cached $origin_location] + set weird_origin 0 + if {[lsearch $originlocationparts :*] >= 0} { + set weird_origin 1 + } + if {$weird_origin} { + set mixedtype i-[nseval_ifexists $origin_location [list ::punk::ns::cmdtype $origin_cmd]] + } else { + set mixedtype i-[namespace eval $origin_location [list ::punk::ns::cmdtype $origin_cmd]] + } + lappend allimported $cmd + } else { + set mixedtype $ctype + } + #assert mixedtype != import + #review - we don't have a way to mark as both native and ensemble + switch -- $mixedtype { + i-native - native { + lappend allnative $cmd + } + i-ensemble - ensemble { + lappend allensembles $cmd + } + i-alias - alias { + #review + lappend allaliases $cmd + } + i-object - object { + #punk::ns::cmdtype will return ooobject or ooclass directly + if {[info object isa object ${location}::$cmd]} { + lappend allooobjects $cmd + if {[info object isa class ${location}::$cmd]} { + lappend allooclasses $cmd } } } + i-ooobject - ooobject { + lappend allooobjects $cmd + } + i-ooclass - ooclass { + lappend allooclasses $cmd + } + i-privateObject - privateObject { + lappend allooobjects $cmd + lappend allooprivateobjects $cmd + } + i-privateClass - privateClass { + lappend allooobjects $cmd + lappend allooprivateclasses $cmd + } + i-interp - interp { + lappend allinterps $cmd + } + i-coroutine - coroutine { + lappend allcoroutines $cmd + } + i-zlibStream - zlibStream { + lappend allzlibstreams $cmd + } default { - if {$ctype eq "import"} { - if {$weird_ns} { - set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] - } else { - set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] - } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source - #ie we don't need to follow a chain of 'imported' results. - set origin_location [nsprefix $cmdorigin] - set origin_cmd [nstail $cmdorigin] - - set originlocationparts [nsparts $origin_location] - set weird_origin 0 - if {[lsearch $originlocationparts :*] >= 0} { - set weird_origin 1 - } - if {$weird_origin} { - set mixedtype i-[nseval_ifexists $origin_location [list ::tcl::info::cmdtype $origin_cmd]] - } else { - set mixedtype i-[namespace eval $origin_location [list ::tcl::info::cmdtype $origin_cmd]] - } - lappend allimported $cmd - } else { - set mixedtype $ctype - } - #assert mixedtype != import - #review - we don't have a way to mark as both native and ensemble - switch -- $mixedtype { - i-native - native { - lappend allnative $cmd - } - i-ensemble - ensemble { - lappend allensembles $cmd - } - i-alias - alias { - #review - lappend allaliases $cmd - } - i-object - object { - if {[info object isa object ${location}::$cmd]} { - lappend allooobjects $cmd - if {[info object isa class ${location}::$cmd]} { - lappend allooclasses $cmd - } - } - } - i-privateObject - privateObject { - lappend allooobjects $cmd - lappend allooprivateobjects $cmd - } - i-privateClass - privateClass { - lappend allooobjects $cmd - lappend allooprivateclasses $cmd - } - i-interp - interp { - lappend allinterps $cmd - } - i-coroutine - coroutine { - lappend allcoroutines $cmd - } - i-zlibStream - zlibStream { - lappend allzlibstreams $cmd - } - default { - #there may be other registered types - #(extensible with Tcl_RegisterCommandTypeName) - lappend allothers $cmd - } - - } - + #there may be other registered types + #(extensible with Tcl_RegisterCommandTypeName) + lappend allothers $cmd } } - #JMN TODO - if {[catch { - if {$cmd eq ""} { - #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. - set nsorigin [namespace origin ${location}::] - } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] - } else { - set nsorigin [namespace origin [nsjoin $location $cmd]] - } - } errM]} { - puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" - puts stderr "error message: $errM" - lappend allundetermined $cmd - } else { - if {[nsprefix $nsorigin] ne $location} { - lappend allimported $cmd - } - } + #JMN TODO? + #if {[catch { + # #if {$cmd eq ""} { + # # #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. + # # set nsorigin [namespace origin ${location}::] + # #} elseif {[string match :* $cmd]} { + # # set nsorigin [nseval $location "::namespace origin $cmd"] + # #} else { + # # set nsorigin [namespace origin [nsjoin $location $cmd]] + # #} + # set locparts [nsparts_cached $location] + # if {[lsearch $locparts :*] >=0 || [string match :* $cmd]} { + # set nsorigin [nseval $location [list namespace origin $cmd]] + # } else { + # set nsorigin [namespace origin [nsjoin $location $cmd]] + # } + #} errM]} { + # puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" + # puts stderr "error message: $errM" + # lappend allundetermined $cmd + #} else { + # if {[nsprefix $nsorigin] ne $location} { + # lappend allimported $cmd + # } + #} } if {$glob ne "*"} { set childtailmatches [lsearch -all -inline $childtails $glob] @@ -1712,7 +2059,8 @@ tcl::namespace::eval punk::ns { set exported [lsearch -all -inline $allexported $glob] set procs [lsearch -all -inline $allprocs $glob] - #set aliases [lsearch -all -inline $allaliases $glob] + # ccc + set aliases [lsearch -all -inline $allaliases $glob] set ensembles [lsearch -all -inline $allensembles $glob] set native [lsearch -all -inline $allnative $glob] set coroutines [lsearch -all -inline $allcoroutines $glob] @@ -1729,7 +2077,8 @@ tcl::namespace::eval punk::ns { #set fqchildren $allchildren set exported $allexported set procs $allprocs - #set aliases $allaliases + # ccc + set aliases $allaliases set ensembles $allensembles set native $allnative set coroutines $allcoroutines @@ -1765,54 +2114,104 @@ tcl::namespace::eval punk::ns { if {$has_punkargs || $has_tepam} { set ns_updated [dict create] foreach c $commands { - if {$c in $imported} { - set fq [namespace origin [nsjoin $location $c]] - } elseif {$c in $aliases} { + set found_documentation 0 + #we first need to check if there is direct documentation for the command at this location, before diverting to examine the target of imports/aliases for docs + if {$has_punkargs} { + set id [nsjoin $location $c] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } + if {[::punk::args::id_exists $id]} { + lappend usageinfo $c + set found_documentation 1 + } + } + + + if {!$found_documentation && $c in $aliases} { + #could be an alias in $location, or an imported alias + #TODO - use which_alias ? - set tgt [interp alias "" [nsjoin $location $c]] + if {$c in $imported} { + if {$weird_ns} { + set fq [nseval $location [list namespace origin $c]] + } else { + set fq [namespace origin [nsjoin $location $c]] + } + } else { + set fq [nsjoin $location $c] + } + + set tgt [interp alias "" $fq] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft $fq :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options + set id [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) if {[string match ::* $word1]} { - set fq $word1 + set id $word1 } else { - set fq ::$word1 + set id ::$word1 } } - } else { - set fq [nsjoin $location $c] - } - if {$has_punkargs} { - #set id [string trimleft $fq :] - set id $fq - set id_ns [namespace qualifiers $id] - if {![dict exists $ns_updated $id_ns]} { - #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" - punk::args::update_definitions [list $id_ns] - dict set ns_updated $id_ns 1 - } if {[::punk::args::id_exists $id]} { lappend usageinfo $c - } else { - if {$has_tepam} { - if {$fq in $::tepam::ProcedureList} { - lappend usageinfo $c - } - } + set found_documentation 1 } + #todo - alias to an alias + #e.g n/new jjj + # interp alias "" ::jjj::corp2 "" ::corp + #todo -pseudocode + #cmdwhich id + #while origin ne whichtype && origintype eq "alias" { + # if id_exists $origin { + # lappend usageinfo $c; set found_documentation 1 + # break + # } + # cmdwhich id + #} + + # CCC + #or just use punk::ns::cmdinfo + } else { + #all non-alias + if {!$found_documentation && $has_punkargs && $c in $imported} { + if {$weird_ns} { + set fq [nseval $location [list namespace origin $c]] + } else { + set fq [namespace origin [nsjoin $location $c]] + } + + #set id [string trimleft $fq :] + set id $fq + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } + if {[::punk::args::id_exists $id]} { + lappend usageinfo $c + set found_documentation 1 + } + } + } + if {!$found_documentation && $has_tepam} { + set fq [namespace origin [nsjoin $location $c]] if {$fq in $::tepam::ProcedureList} { lappend usageinfo $c } } + } } #catch {package require natsort} @@ -1947,99 +2346,6 @@ tcl::namespace::eval punk::ns { #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { - ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 - } - if {![llength $args]} { - lappend args * - } - ::foreach search $args { - ::if {$ci > [::llength $colors]-1} { - ::set ci 0 - } - ::if {$ci == 0 || $do_raw} { - ::set col "" - ::set rst "" - } else { - ::set col [a+ [::lindex $colors $ci] bold] - ::set rst [a+] - } - ::incr ci ;#colourindex - #inspect -label search $search - - ::if {![::llength $search]} { - ::set base $commandns - ::set what "*" - } else { - ::if {[::string match ::* $search]} { - ::set base [::punk::ns::nsprefix $search] - ::set what [::punk::ns::nstail $search] - } else { - ::set base $commandns - ::set what $search - } - } - set weird_ns 0 - if {[string match *:::* $base]} { - set weird_ns 1 - } - #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created - if {$weird_ns} { - ::if {![nsexists $base]} { - ::continue - } - #info commands can't glob with weird_ns prefix - puts ">>> base: $base what: $what" - ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { - set _all [uplevel 1 [list ::info commands]] - set _matches [list] - foreach _a $_all { - set _c [uplevel 1 [list ::namespace which $_a]] - if {[::string match ${loc}::${what} $_c]} { - ::lappend _matches $_a - } - } - return $_matches - }} $base $what ]] - } else { - ::if {![::tcl::namespace::exists $base]} { - ::continue - } - ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] - } - ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] - foreach c $all_ns_tails { - ::if {$do_raw} { - ::lappend commandlist [::list $c $c] - } else { - ::lappend commandlist [::list $c $col[::list $c]$rst] - } - } - } - set commandlist [lsort -index 0 $commandlist] - set results [list] - foreach pair $commandlist { - lappend results [lindex $pair 1] - } - #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) - #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - if {![llength $results]} { - return {} - } else { - return [join $results \n]\n - } - } - interp alias {} nscommands {} punk::ns::nscommands - interp alias {} nscommands1 {} .= ,'ok'@0.= { @@ -2114,19 +2420,19 @@ tcl::namespace::eval punk::ns { set subcommand_dict [dict create] set commands [list] - set nscommands [list] + set ns_commands [list] if {[llength [dict get $ensembleinfo -subcommands]]} { #set exportspecs [namespace eval $ns {namespace export}] #foreach pat $exportspecs { - # lappend nscommands {*}[info commands ${ns}::$pat] + # lappend ns_commands {*}[info commands ${ns}::$pat] #} #when using -subcommands, even unexported commands are available - set nscommands [info commands ${ns}::*] + set ns_commands [info commands ${ns}::*] foreach sub [dict get $ensembleinfo -subcommands] { if {[dict exists $map $sub]} { #-map takes precence over same name exported from -namespace dict set subcommand_dict $sub [dict get $map $sub] - } elseif {"${ns}::$sub" in $nscommands} { + } elseif {"${ns}::$sub" in $ns_commands} { dict set subcommand_dict $sub ${ns}::$sub } else { #subcommand probably supplied via -unknown handler? @@ -2139,9 +2445,9 @@ tcl::namespace::eval punk::ns { } else { set exportspecs [namespace eval $ns {namespace export}] foreach pat $exportspecs { - lappend nscommands {*}[info commands ${ns}::$pat] + lappend ns_commands {*}[info commands ${ns}::$pat] } - foreach fqc $nscommands { + foreach fqc $ns_commands { dict set subcommand_dict [namespace tail $fqc] $fqc } } @@ -2153,30 +2459,224 @@ tcl::namespace::eval punk::ns { } } - punk::args::define { - @id -id ::punk::ns::resolve_command - @cmd -name punk::ns::resolve_command -help\ - "Return a dict with command resolution info" - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 + proc nscommands {args} { + set commandns [uplevel 1 [list ::namespace current]] + set commandlist [::list] + #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + set colors [::list none cyan yellow green] + set ci 0 ;#colourindex + set do_raw 0 + if {[::set posn [::lsearch $args -raw]] >= 0} { + ::set args [::lreplace $args $posn $posn] + ::set do_raw 1 + } + if {![llength $args]} { + lappend args * + } + ::foreach search $args { + ::if {$ci > [::llength $colors]-1} { + ::set ci 0 + } + ::if {$ci == 0 || $do_raw} { + ::set col "" + ::set rst "" + } else { + ::set col [a+ [::lindex $colors $ci] bold] + ::set rst [a+] + } + ::incr ci ;#colourindex + #inspect -label search $search + + ::if {![::llength $search]} { + ::set base $commandns + ::set what "*" + } else { + ::if {[::string match ::* $search]} { + ::set base [::punk::ns::nsprefix $search] + ::set what [::punk::ns::nstail $search] + } else { + ::set base $commandns + ::set what $search + } + } + set weird_ns 0 + if {[string match *:::* $base]} { + set weird_ns 1 + } + #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created + if {$weird_ns} { + ::if {![nsexists $base]} { + ::continue + } + #info commands can't glob with weird_ns prefix + puts ">>> base: $base what: $what" + ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { + set _all [uplevel 1 [list ::info commands]] + set _matches [list] + foreach _a $_all { + set _c [uplevel 1 [list ::namespace which $_a]] + if {[::string match ${loc}::${what} $_c]} { + ::lappend _matches $_a + } + } + return $_matches + }} $base $what ]] + } else { + ::if {![::tcl::namespace::exists $base]} { + ::continue + } + ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] + } + ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] + foreach c $all_ns_tails { + ::if {$do_raw} { + ::lappend commandlist [::list $c $c] + } else { + ::lappend commandlist [::list $c $col[::list $c]$rst] + } + } + } + set commandlist [lsort -index 0 $commandlist] + set results [list] + foreach pair $commandlist { + lappend results [lindex $pair 1] + } + #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) + #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. + if {![llength $results]} { + return {} + } else { + return [join $results \n]\n + } } - proc resolve_command {args} { - if {[llength $args] == 0} { - return + interp alias {} nscommands {} punk::ns::nscommands + proc nscommandlist {{ns *}} { + set nsparts [nsparts_cached $ns] + set tail [lindex $nsparts end] + if {[string match ::* $ns]} { + if {[regexp {\*} $tail]} { + set targetns [nsprefix $ns] + set search $tail + } else { + set targetns $ns + set search * + } + } else { + set nscaller [uplevel 1 [list ::namespace current]] + if {[regexp {\*} $tail]} { + if {[nsprefix $ns] ne ""} { + set targetns [nsjoin $nscaller [nsprefix $ns]] + } else { + set targetns $nscaller + } + set search $tail + } else { + set targetns [nsjoin $nscaller $ns] + set search * + } } - set querycommand [lindex $args 0] - set queryargs [lrange $args 1 end] + if {![string match "*:::*" $targetns]} { + #ordinary namespace path - can use standard info commands with glob + set all_cmds [info commands [::punk::ns::nsjoin $targetns $search]] + set all_cmds [lmap v $all_cmds {namespace tail $v}] + return [lsort $all_cmds] + } else { + # 'unwisely' named ns: cannot rely on 'info commands ' + # running 'info commands' from within the namespace will return all commands resolvable from the space - not just those that are defined there. + # this includes global commands and those supplied by namespaces configured in 'namespace path' + # we can't just use a 'diff' of what commands are visible compared to those that are available from global or 'namespace path' + # because there may be overrides/duplicates that are present in the namespace bing searched. + # we rely on the *apparent* (undocumented?) fact that in the list of commands resolved by 'info commands', + # the commands that are actually in the namespace are listed first. + # This means we can stop processing on the first command for which 'namespace which' shows another namespace. + set remaining [nseval_ifexists $targetns [list apply {{loc} { + ::set _visiblecommands [::uplevel 1 [::list ::info commands]] + ::set _matches [::list] + ::foreach _v $_visiblecommands { + ::set _commandns [::uplevel 1 [::list ::namespace which $_v]] + ::if {[::string match ${loc}::* $_commandns]} { + ::lappend _matches $_v + } else { + #abort at first in list that resolves from some other namespace + break + } + } + ::return $_matches + }} $targetns]] + if {$search ne "*"} { + set remaining [lsearch -all -inline -glob $remaining $search] + } + return [lsort $remaining] + } + + } + interp alias {} nscommandlist {} punk::ns::nscommandlist + + + punk::args::define { + @id -id ::punk::ns::cmdwhich + @cmd -name punk::ns::cmdwhich\ + -summary\ + "Return a dict with keys origin, origintype, which, whichtype."\ + -help\ + "Return a dict with keys origin, origintype, which, whichtype. + 'which' represents the full namespace path of the resolved command. + The command is first resolved by Tcl by looking for it in the namespace + in which whichcmd was run, then at each of any entries configured with + 'namespace path' for that namespace, and finally in the global namespace. + 'origin' represents the full namespace path of where the command represented + by 'which' points to, or the target of the alias if 'whichtype' is 'alias'. + This differs from the Tcl 'namespace origin' result. + In the usual case of a simple proc in a namespace, + 'which' and 'origin' will be the same, but for an imported command or an + alias - 'origin' could be a different location, or a different name, or in + the case of an alias, have additional curried-in arguments. + + Note that 'origin' is not necessarily the earliest point in the chain. + For example an alias in one namespace could be imported into another. + This may give a result with origintype alias and whichtype import. + cmdwhich would have to be called on the origin value to inspect further. + An alias pointing to a target with curried-in arguments will show an + origintype of 'script' - whereas an alias to a single word will show the + origintype of the target command. + + An alias that has been renamed into another namespace does not have full + ability to be introspected easily by Tcl. In such a case 'which' and 'origin' + may show the same target, both with type 'alias'. Another mechanism such as + pattern::which_alias may need to be used to inspect the origin alias further. + Such mechanisms may involve actually running the command - which can be risky + to do on arbitrary commands, and so is not automated. + + An alias may point to a command that is runnable, but not available for + introspection by the current interp (e.g in safe interps). + Such an alias may return an origintype of 'notfound', just as a nonexistant + command or alias target would." + + @values -min 1 -max 1 + cmd -multiple 0 -optional 0 + } + #REVIEW! todo - change 'origin' in resultdict to 'next'? + #(origin too similar to 'namespace origin' - but we are using it for that as well as alias target) + proc cmdwhich {querycommand} { set nscaller [uplevel 1 [list ::namespace current]] - #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented + #puts "cmdwhich nscaller: $nscaller" if {[string match ::* $querycommand]} { - set targetns [nsprefix $querycommand] - set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global - #when arginfo given a fully qualified path - we only want an answer for that exact command - set nscommands [info commands ${targetns}::*] - if {[lsearch -exact $nscommands $querycommand] >= 0} { + #absolute + set targetns [nsprefix $querycommand] + set name [nstail $querycommand] + set targetparts [nsparts_cached $targetns] + if {[lsearch $targetparts :*] >=0} { + # + #for an *unwisely* named ns - info commands ${targetns}::* will not work + set ns_commands [nscommandlist $targetns] ;#results are tails only + set ns_commands_fq [lmap v $ns_commands {string cat $targetns ::$v}] + + } else { + set ns_commands_fq [info commands ${targetns}::*] ;#results remain fully qualified + } + if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths if {[catch { set origin [nseval_ifexists $targetns [list ::namespace origin $name]] @@ -2192,7 +2692,7 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #relative comandpath + #relative commandpath if {[string match (autodef)* $querycommand]} { #pass through - should be found with id lookup set origin $querycommand @@ -2202,7 +2702,7 @@ tcl::namespace::eval punk::ns { set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] set targetns [nsprefix $thispath] set name [nstail $thispath] - set targetparts [nsparts $targetns] + set targetparts [nsparts_cached $targetns] if {[lsearch $targetparts :*] >=0} { #weird ns set valid_ns [nsexists $targetns] @@ -2224,72 +2724,346 @@ tcl::namespace::eval punk::ns { #namespace as relative to current doesn't seem to exist #Tcl would also attempt to resolve as global if {$nscaller ne "::"} { - return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] } set origin $querycommand set resolved $querycommand - } } } - #ns::cmdtype only detects alias type on 8.7+? - set initial_cmdtype [punk::ns::cmdtype $origin] - switch -- $initial_cmdtype { - na - alias { - #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) - set tgt [interp alias "" $origin] - if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft $origin :]] - } - #first word of tgt may be namespace relative or absolute - if {$tgt ne ""} { - set word1 [lindex $tgt 0] - if {$word1 eq "punk::mix::base::_cli"} { - #special case for punk deck - REVIEW - #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set targetword [lindex $tgt end] - } else { - #todo - alias may have prefilled some leading args - so usage report should reflect that??? - #(possible curried arguments) - #review - curried arguments could be for ensembles! - set targetword $word1 - return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] - } - - + set origintype [punk::ns::cmdtype $origin] + set whichtype [punk::ns::cmdtype $resolved] + + if {$resolved eq $origin && $origintype in {na alias} && $whichtype in {na alias}} { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + #even if it was marked as na (8.6?) - it's an alias + set whichtype alias + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] set origin $targetword #retest cmdtype on modified origin - set cmdtype [punk::ns::cmdtype $origin] + set origintype [punk::ns::cmdtype $origin] } else { - set cmdtype $initial_cmdtype + #alias may have some curried-in arguments + if {[llength $tgt] == 1} { + set whichinfo [uplevel 1 [list cmdwhich $tgt]] + set origin [dict get $whichinfo origin] + set origintype [dict get $whichinfo origintype] + } else { + set origin $tgt ;#multiword origin + set origintype script + } } - if {$cmdtype eq "na"} { + } else { + #not an alias + if {$whichtype eq "na"} { #tcl 8.6 if {[info object isa object $origin]} { - set cmdtype "object" + if {[info object isa class $origin]} { + set origintype "ooclass" + set whichtype "ooclass" + } else { + set origintype "ooobject" + set whichtype "ooobject" + } } } } - default { - set cmdtype $initial_cmdtype - } } - punk::args::update_definitions [list [namespace qualifiers $origin]] - set id $origin - + return [dict create origin $origin origintype $origintype which $resolved whichtype $whichtype] + } - #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict - if {[punk::args::id_exists $id] && ![llength $queryargs]} { - return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + #review - should be in punk::args? + proc generate_autodef {args} { + set cmd [lindex $args 0] + if {[string match (autodef)* $cmd]} { + set cmd [string range $cmd 9 end] } - - #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" - if {![punk::args::id_exists $origin]} { - if {[namespace ensemble exists $origin]} { - #review + set queryargs [lrange $args 1 end] + set cinfo [punk::ns::cmdwhich $cmd] + set origin [dict get $cinfo origin] + set cmdtype [dict get $cinfo origintype] + switch -- $cmdtype { + script - alias { + #don't generate (autodef) on plain alias or curried alias (script) - let them resolve + } + object - ooobject - ooclass { + #class is also an object + #todo -mixins etc etc + set class [info object class $origin] + #the call: info object methods -all + # seems to do the right thing as far as hiding unexported methods, and showing things like destroy + # - which don't seem to be otherwise easily introspectable + set public_methods [info object methods $origin -all] + #set class_methods [info class methods $class] + #set object_methods [info object methods $origin] + + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] + if {$c1 in $public_methods} { + switch -- $c1 { + new { + set constructorinfo [info class constructor $origin] + set arglist [lindex $constructorinfo 0] + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} new" + @cmd -name "${$origin} new"\ + -summary\ + "Create new object instance."\ + -help\ + "create object with autogenerated command name. + Arguments are passed to the constructor." + @values + }] + set i 0 + foreach a $arglist { + if {[llength $a] == 1} { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } else { + append argdef \n "[lindex $a 0] -default [lindex $a 1]" + } + incr i + } + punk::args::define $argdef + set queryargs_remaining [lrange $queryargs 1 end] + } + create { + set constructorinfo [info class constructor $origin] + set arglist [lindex $constructorinfo 0] + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} create" + @cmd -name "${$origin} create"\ + -summary\ + "Create new object instance with specified command name."\ + -help\ + "create object with specified command name. + Arguments following objectName are passed to the constructor." + @values -min 1 + objectName -type string -help\ + "possibly namespaced name for object instance command" + }] + set i 0 + foreach a $arglist { + if {[llength $a] == 1} { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } else { + append argdef \n "[lindex $a 0] -default [lindex $a 1]" + } + incr i + } + punk::args::define $argdef + set queryargs_remaining [lrange $queryargs 1 end] + } + destroy { + #review - generally no doc + # but we may want notes about a specific destructor + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} destroy" + @cmd -name "destroy"\ + -summary\ + "delete object instance."\ + -help\ + "delete object, calling destructor if any. + destroy accepts no arguments." + @values -min 0 -max 0 + }] + punk::args::define $argdef + set queryargs_remaining [lrange $queryargs 1 end] + } + default { + #use info object call to resolve callchain + #we assume the first impl is the topmost in the callchain + # and its call signature is therefore the one we are interested in - REVIEW + # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? + set implementations [::info object call $origin $c1] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] + set oodef "" + foreach impl $implementations { + lassign $impl generaltype mname location methodtype + switch -- $generaltype { + method - private { + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) + if {$location eq "object"} { + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " + if {[punk::args::id_exists $idcustom]} { + return + } + set oodef [::info object definition $origin $c1] + } else { + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" + if {[punk::args::id_exists $idcustom]} { + return + } + set oodef [::info class definition $location $c1] + } + break + } + filter { + } + unknown { + } + } + } + if {$oodef ne ""} { + set autoid "(autodef)$location $c1" + set arglist [lindex $oodef 0] + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated by generate_autodef) + arglist:${$arglist}" + @values + }] + set i 0 + foreach a $arglist { + switch -- [llength $a] { + 1 { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } + 2 { + append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" + } + default { + puts stderr "generate_autodef unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" + } + } + incr i + } + punk::args::define $argdef + return ok + } else { + return "unable to resolve $origin method $c1" + } + + } + } + } + } + set choicelabeldict [dict create] + set choiceinfodict [dict create] + foreach cmd $public_methods { + switch -- $cmd { + default { + set implementations [::info object call $origin $cmd] + set def "" + foreach impl $implementations { + lassign $impl generaltype mname location methodtype + # + switch -- $generaltype { + method - private { + #private? todo? + if {$location eq $origin} { + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" + #dict set choiceinfodict $cmd {{doctype ooo}} + dict set choiceinfodict $cmd {{doctype objectmethod}} + } elseif {$location eq $class} { + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" + #dict set choiceinfodict $cmd {{doctype ooc}} + dict set choiceinfodict $cmd {{doctype classmethod}} + } else { + #e.g impl: {method destroy ::oo::object {core method: "destroy"}} + set id "$location $cmd" + if {[string match "core method:*" $methodtype]} { + dict lappend choiceinfodict $cmd {doctype coremethod} + } else { + dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] + } + } + if {[punk::args::id_exists $id]} { + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} + dict lappend choiceinfodict $cmd [list subhelp {*}$id] + } + break + } + filter { + #todo? flag if filter is on object vs class? + dict set choiceinfodict $cmd {{doctype filter}} + dict set choiceinfodict $cmd {{doctype TODO}} + #filter chain? + } + unknown { + dict set choiceinfodict $cmd {{doctype unknown}} + } + default { + error "generate_autodef unhandled generaltype:'$generaltype' for info object call $origin $cmd" + } + } + } + } + } + } + + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review + #puts stderr "--->$vline" + set autoid "(autodef)$origin" + if {[info object isa class $origin]} { + set objtype Class + } else { + set objtype Object + } + #An object command name can contain spaces - so we must quote the -id value + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -name "${$objtype}: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated by generate_autodef) + (see 'i punk::ns::Cmark' for symbols)" + @leaders -min 1 + }] + append argdef \n $vline + punk::args::define $argdef + + } + privateObject { + return "Command is a privateObject - no info currently available" + } + privateClass { + return "Command is a privateClass - no info currently available" + } + interp { + #todo + puts stderr "generate_autodef - interp" + } + script { + #todo + puts stderr "generate_autodef - script" + } + ensemble { + #review #todo - check -unknown #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. #presumably -choiceprefix should be zero in that case?? @@ -2340,133 +3114,450 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand - if {$posn_subcommand > 0} { - set params [lrange $queryargs 0 $posn_subcommand-1] - set remaining_queryargs [lrange $queryargs $posn_subcommand end] + if {[llength $queryargs]} { + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] + #subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + tailcall generate_autodef {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] + } + } + } + + #todo - synopsis? + set choicelabeldict [dict create] + + set choiceinfodict [dict create] + + dict for {sub subwhat} $subcommand_dict { + if {[llength $subwhat] > 1} { + #TODO - resolve using cmdinfo? + puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" + } + set targetfirstword [lindex $subwhat 0] + set targetinfo [cmdwhich $targetfirstword] + set targetorigin [dict get $targetinfo origin] + set targetcmdtype [dict get $targetinfo origintype] + set nstarget [nsprefix $targetorigin] + + dict set choiceinfodict $sub [list [list resolved $subwhat]] + dict lappend choiceinfodict $sub [list doctype $targetcmdtype] + + if {[punk::args::id_exists [list $origin $sub]]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] + } elseif {[punk::args::id_exists $targetorigin]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] + } elseif {[punk::args::id_exists ${origin}::$sub]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}${origin}::$sub] + } else { + #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" + } + + } + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + puts "ENSEMBLE auto def $autoid (generate_autodef)" + #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -help\ + "(autogenerated by generate_autodef) + ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" } else { - set params [list] - set remaining_queryargs $queryargs + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } } - if {[llength $remaining_queryargs]} { - if {$prefixes} { - set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + append argdef \n $vline + punk::args::define $argdef + } + proc { + #JJJ + set tepamhelp "" + if {[info exists ::tepam::ProcedureList]} { + if {$origin in $::tepam::ProcedureList} { + set tepamhelp [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout } else { - #must be exact match - not a prefix - set match [lindex $remaining_queryargs 0] + #handle any tepam functions that don't eat their own dogfood but have help variables + #e.g tepam::procedure, tepam::argument_dialogbox + #Rather than hardcode these - we'll guess that any added will use the same scheme.. + if {[namespace qualifiers $origin] eq "::tepam"} { + set func [namespace tail $origin] + #tepam XXXHelp vars don't exactly match procedure names :/ + if {[info exists ::tepam::${func}Help]} { + set tepamhelp [set ::tepam::${func}Help] + } else { + set f2 [string totitle $func] + if {[info exists ::tepam::${f2}Help]} { + set tepamhelp [set ::tepam::${f2}Help] + } else { + #e.g argument_dialogbox -> ArgumentDialogboxHelp + set parts [split $func _] + set uparts [lmap p $parts {string totitle $p}] + set f3 [join [list {*}$uparts Help] ""] + if {[info exists ::tepam::${f3}]} { + set tepamhelp [set ::tepam::${f3}] + } + } + } + } } - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } + set autoid "(autodef)$origin" + #note it's possible for a proc name to have a space - so we need to quote the -id value + if {$tepamhelp ne ""} { + puts "TEPAM PROC auto def $autoid (generate_autodef)" + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -help\ + "(autogenerated by generate_autodef) + proc: ${$origin}" + }] + append argdef \n "@formdisplay -body {$tepamhelp}" + punk::args::define $argdef + } else { + puts "PROC auto def $autoid (generate_autodef)" + set infoargs [info args $origin] + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -help\ + "(autogenerated by generate_autodef) + proc: ${$origin}" + @leaders + }] + set i -1 + #rather than type 'any' - we should use 'unknown' + foreach a $infoargs { + incr i + if {[info default $origin $a def]} { + append argdef \n "$a -type unknown -default \"$def\"" + } else { + if {$i == [llength $infoargs]-1 && $a eq "args"} { + append argdef \n "arg -type unknown -multiple 1 -optional 1" + } else { + append argdef \n "$a -type unknown" + } + } + } + punk::args::define $argdef + } + } + } - #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] - puts "+++> resolve_next: $resolve_next" + } - set sub_resolution [resolve_command {*}$resolve_next] - set sub_args_remaining [dict get $sub_resolution args_remaining] - set sub_args_full [dict get $sub_resolution args_full] - #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] - set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + punk::args::define { + @id -id ::punk::ns::cmdinfo + @cmd -name punk::ns::cmdinfo\ + -summary\ + "Subcommand resolution of ensemble-like tree of commands."\ + -help\ + "Return a dict with command resolution info for ensemble-like tree of commands with subcommands" + @leaders -min 0 -max 0 + @opts + -form -default * -help\ + "Ordinal index or name of command form" + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + variable cmdinfo_reducerid 0 + proc cmdinfo {args} { + set argd [punk::args::parse $args withid ::punk::ns::cmdinfo] + lassign [dict values $argd] leaders opts values received - puts stderr "+++> $sub_resolution" - puts stderr "+++> $f" - dict set sub_resolution args_full $f - return $sub_resolution - } + set cmdlist [dict get $values cmditem] + if {[llength $cmdlist] == 0} { + return ;#review - shouldn't get here anyway + } + set fid [dict get $opts -form] ;#todo + + variable cmdinfo_reducerid + set reduce ::punk::ns::reducer[incr cmdinfo_reducerid] + set nscaller [uplevel 1 [list ::namespace current]] + + set init [coroutine $reduce cmd_traverse $nscaller $fid {*}$cmdlist] + #puts stderr "init: $init" + set final 0 + set origin "" + set stack [list] + set commands [list] + set consumed_args [list] + set docid "" + while {$final == 0} { + lassign [$reduce $origin] final origin consumed remainingargs docid + #if {$final != 1} { + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + #puts "->$final neworigin: $origin consumed:$consumed remaining:$remainingargs docid:$docid" + lappend stack [list $origin {*}$consumed] + lappend commands $origin + lappend consumed_args {*}$consumed + #} + } + set finalcommand [lindex $commands end] + set cinfo [cmdwhich $finalcommand] + set origin [dict get $cinfo origin] + set cmdtype [dict get $cinfo origintype] + return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] + } + proc cmd_traverse {ns formid args} { + set autodefined [dict create] + #puts "cmd_traverse args: $args yielding: [info coroutine]" + yield [info coroutine] + if {![llength $args]} { + return + } + set cmd "" + + #use a for loop over args - as sometimes we may consume more than one in our reduction (e.g when there are ensemble parameters) + set argc [llength $args] + set cmd [lindex $args 0] + set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] + set origin [dict get $whichinfo origin] + set which [dict get $whichinfo which] + set whichtype [dict get $whichinfo whichtype] + + set docid "" + + #An imported or aliased command could be deliberately documented in the target namespace to override the origin + if {$argc == 1 && $origin ne $which} { + punk::args::update_definitions [list [namespace qualifiers $which]] + #we don't call generate_auto_def on the 'which' version of the command + #but we do want to lookup and use any explicit punk::args id that may exist for it + if {[punk::args::id_exists $which]} { + set docid $which + set origin $which ;#Flip our traversal to be on the documented 'which' rather than the actual origin + if {$whichtype eq "alias"} { + #*documented* alias + return [list 1 $origin {} [lrange $args 1 end] $docid] } + } + } - set choiceinfodict [dict create] - set choicelabeldict [dict create] + if {$docid eq ""} { + #there was no explicit documentation for the command at it's actual 'which' location. + punk::args::update_definitions [list [namespace qualifiers $origin]] + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" + } + } - set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set targetfirstword [lindex $subwhat 0] - set ns [::namespace which $targetfirstword] - set ns [nsprefix $ns] - set targettail [namespace tail $targetfirstword] - if {![dict exists $namespaces $ns]} { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] - dict set namespaces $ns $nsinfo - } else { - set nsinfo [dict get $namespaces $ns] + set resolvedargs {} + #if {$argc == 1} { + # return [list 1 $origin {} [lrange $args 1 end] $docid] + #} else { + set origin [yield [list 0 $origin {} [lrange $args 1 end] $docid]] + set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] + set origin [dict get $whichinfo origin] + set origintype [dict get $whichinfo origintype] + set which [dict get $whichinfo origin] + #an alias may have direct documentation + #if so - use it before resolving via origin + punk::args::update_definitions [list [namespace qualifiers $which]] + if {[punk::args::id_exists $which]} { + set docid $which + set origin $which + } else { + set docid "" + } + if {$docid eq ""} { + #review - orgintype classmethod, objectmethod? + if {$origintype eq "script"} { + #a 'script' is essentially an alias-target to a command with curried args + #There will not be documentation or a 'command' matching the entire script, but there may be for the target command (first word of script) + set scriptcmdraw [lindex $origin 0] + set scriptinfo [namespace eval $ns [list punk::ns::cmdwhich $scriptcmdraw]] + set scriptcmd [dict get $scriptinfo which] + set scriptargs [lrange $origin 1 end] + #ledit args -1 -1 {*}$scriptargs ;#prepend + set args [linsert $args 1 {*}$scriptargs] + #JJJ review + #set resolvedargs $scriptargs + punk::args::update_definitions [list [namespace qualifiers $scriptcmd]] + if {![punk::args::id_exists $scriptcmd] && ![dict exists $autodefined $scriptcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $scriptcmd] + dict set autodefined $origin 1 + #if the scriptcmd is itself an alias - no autodef will be generated for it } - dict set choiceinfodict $sub [list [list resolved $subwhat]] + if {[punk::args::id_exists $scriptcmd]} { + set docid $scriptcmd + } elseif {[punk::args::id_exists "(autodef)$scriptcmd"]} { + set docid (autodef)$scriptcmd + } else { - if {$targettail in [dict get $nsinfo usageinfo]} { - dict lappend choiceinfodict $sub {doctype punkargs} - #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] - } - if {$targettail in [dict get $nsinfo ensembles]} { - dict lappend choiceinfodict $sub {doctype ensemble} - } - if {$targettail in [dict get $nsinfo ooobjects]} { - if {$targettail in [dict get $nsinfo ooclasses]} { - dict lappend choiceinfodict $sub {doctype ooc} - } else { - dict lappend choiceinfodict $sub {doctype ooo} - } + set docid "" } + set origin $scriptcmd + } elseif {$origintype eq "alias"} { + #JJJ2 + #puts "==> examining alias $origin" + if {[string match >* [nstail $origin]] && [package provide pattern] ne ""} { + if {![catch {pattern::which_alias $origin} alias_target]} { + #review - todo? + set patternorigin [lindex $alias_target 0] + #set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] + set args [linsert $args 1 {*}[lrange $alias_target 1 end]] + #set resolvedargs [lrange $alias_target 1 end] + punk::args::update_definitions [list [namespace qualifiers $patternorigin]] + if {![punk::args::id_exists $patternorigin] && ![dict exists $autodefined $patternorigin]} { + namespace eval $ns [list punk::ns::generate_autodef $patternorigin] + dict set autodefined $origin 1 + #if the patternorigin is itself an alias - no autodef will be generated for it + } + if {[punk::args::id_exists $patternorigin]} { + set docid $patternorigin + } elseif {[punk::args::id_exists "(autodef)$patternorigin"]} { + set docid (autodef)$patternorigin + } else { - if {$targettail in [dict get $nsinfo native]} { - dict lappend choiceinfodict $sub {doctype native} + set docid "" + } + set origin $patternorigin + } } - } - - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] - set autoid "(autodef)$origin" - set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} - @cmd -help\ - "(autogenerated) - Ensemble: ${$origin}" - @leaders -min 1 - }] - if {[llength $parameters] == 0} { - append argdef \n "@leaders -min 1" } else { - append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" - foreach p $parameters { - append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + punk::args::update_definitions [list [namespace qualifiers $origin]] + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" } } - append argdef \n $vline - punk::args::define $argdef - set id $autoid } + #} + if {[llength $args] == 1} { + return [list 2 $origin $resolvedargs {} $docid] } - #testing where id = $origin or id = (autodef)::$origin - if {[punk::args::id_exists $id]} { - #cycle forward through leading values - set specid $id - set specargs $queryargs - if {[llength $queryargs]} { - #JJJ - set spec [punk::args::get_spec $id] - #TODO -form - set form_names [dict get $spec form_names] + set terminate 0 + for {set i 1} {$i < [llength $args]} {incr i} { + #set a [lindex $args $i] + #puts "i:$i a:$a origin:$origin" + #xxx + #puts "==> origin:'$origin' a:'$a'" + + #this docid may be an (autodef) for a level that had no specific documentation. + #If the command at this level is a proc - such an autodef will not have automatically determined any deeper subcommands. + #If however there exists a definition for a space delimited deeper level - then that docid should ideally be found + #e.g punk::args::id_exists "$origin $a" + #we could/should look deeper going backwards? + #ie examining each docid from start will not work to find deeper documented items if there are gaps in manual docs and autodefs based on intermediate procs + #The idea is to support packages for which documentation is incomplete - and to avoid unnecessary lookups of intermediaries. + #e.g starting at: punk::args::id_exists "$origin {*}[lrange $args $i end]" and shortening? + #for example the fictitious ensemble-like nest "::a b c d" + #c may be an undoc'ed proc but the id "::a b c d" may exist + #or ::a b might resolve somewhere unrelated e.g ::foo::bar and "::foo::bar c d" might exist + #starting at the end may involve testing for many ids based on non subcommand args (args to the deepest subcommand itself) + # while id_exists checks don't seem to be hugely expensive - this may not be the best approach on a very large documented system. + #we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. + #(would not support shor-form prefix of subcommand - even if the proc implementation did) + set docid_exists 0 + if {[punk::args::id_exists "$origin [lindex $args $i]"]} { + set a [lindex $args $i] + #review - tests? + puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" + #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent + #There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. + set docid_exists 1 + set docid "$origin $a" + set origin [list $origin $a] + incr i + set queryargs [lrange $args $i end] + set resolvedargs [list $a] ;#even though the + set queryargs_untested $queryargs + } elseif {[punk::args::id_exists $docid]} { + set docid_exists 1 + set queryargs [lrange $args $i end] + set resolvedargs [list] + set queryargs_untested $queryargs + } else { + #we cannot generate autodoc for any deeper (e.g ensemble/proc after undocumented parent) + #There is nothing to indicate the locations of subcommands - they could be anywhere. + #e.g (dispatched by custom code in a proc) + #'guessing' that they follow a namespace hierarchy would be error-prone and a bad idea even if it sometimes worked. + } - #'subcommands' only allowed in single-form commands - review + if {$docid_exists} { + set spec [punk::args::get_spec $docid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] set fid [lindex $form_names 0] + #set fid "" + #if {$formid eq "*"} { + # if {[llength $form_names] == 1} { + # set fid [lindex $form_names 0] + # } else { + # error "cmd_traverse command has [llength $form_names] forms but no specific -form selected. multiform discrimination not yet supported" + # } + #} elseif {[string is integer -strict $formid]} { + # set fid [lindex $form_names $formid] + #} else { + # set fid [tcl::prefix::match -error "" $form_names $formid] + #} + #if {$fid eq ""} { + # error "cmd_traverse unable to match form $formid. form names: $form_names" + #} + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES] set valnames [dict get $spec FORMS $fid VAL_NAMES] - #'subcommands' are only present in forms that consist solely of leaders - REVIEW - #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) - if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs - set queryargs_untested $queryargs + if {![llength $optnames] && ![llength $valnames]} { + + #set queryargs [lrange $args $i end] + #set resolvedargs [list] + #set queryargs_untested $queryargs set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] foreach q $queryargs lname $leadernames_matched { + #puts "===> queryargs:$queryargs lnames:$leadernames_matched" + #usually we expect only one entry in leadernames (except for -ensembleparameter cases) if {$lname eq ""} { + #todo - return? break } set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] - set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] @@ -2481,122 +3572,175 @@ tcl::namespace::eval punk::ns { lappend allchoices {*}$clist } if {$is_ensembleparam} { - #review - lappend nextqueryargs $q - #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - set specargs $queryargs_untested + lappend resolvedargs $q + lpop queryargs_untested 0 + #ledit queryargs_untested 0 0 + #review - add tests continue } if {![llength $allchoices]} { #review - only leaders with a defined set of choices are eligible for consideration as a subcommand - lappend nextqueryargs $q + #lappend resolvedargs $q #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - set specargs $queryargs_untested - continue + #ledit queryargs_untested 0 0 + #jjj + #continue + return [list 3 $origin $resolvedargs $queryargs_untested $docid] + break } - - set resolved_q [tcl::prefix::match -error "" $allchoices $q] if {$resolved_q eq ""} { + return [list 4 $origin $resolvedargs $queryargs_untested $docid] break } if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { #a unique prefix is not sufficient for this arg + return [list 5 $origin $resolvedargs $queryargs_untested $docid] break } - lappend nextqueryargs $resolved_q - #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] - set sub_resolution [punk::ns::resolve_command {*}$resolvelist] - #return $sub_resolution - - set sub_origin [dict get $sub_resolution origin] - set sub_argsremaining [dict get $sub_resolution args_remaining] - set sub_resolved [dict get $sub_resolution resolved] - set sub_cmdtype [dict get $sub_resolution cmdtype] - set sub_args_full [dict get $sub_resolution args_full] - puts stderr "===> $sub_resolution" - - return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + #if {$resolved_q ne $q} { + # ##we have our first difference + #} + + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + set prevdocid $docid + set docid "" + foreach inf $cinfo { + switch -- [lindex $inf 0] { + "resolved" { + #punk::args::ensemble_subcommands_definition + set mapped_subcmd [lrange $inf 1 end] + if {![punk::args::id_exists $mapped_subcmd]} { + punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] + if {![dict exists $autodefined $mapped_subcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $mapped_subcmd] + dict set autodefined $origin 1 + } + } + #if {![punk::args::id_exists $mapped_subcmd] && [punk::args::id_exists "(autodef)$mapped_subcmd"]} { + # set mapped_subcmd "(autodef)$mapped_subcmd" + #} + if {[punk::args::id_exists $mapped_subcmd]} { + set docid $mapped_subcmd + } elseif {[punk::args::id_exists "(autodef)$mapped_subcmd"]} { + set docid (autodef)$mapped_subcmd + } else { + set docid "" + } + #puts stderr "cmd_traverse 'resolved' $mapped_subcmd" + } + "subhelp" { + set mapped_subcmd [lrange $inf 1 end] + #set mapped_subcmd [lindex $inf 1] + if {![punk::args::id_exists $mapped_subcmd]} { + punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] + if {![dict exists $autodefined $mapped_subcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $mapped_subcmd] + dict set autodefined $origin 1 + } + } + #if {![punk::args::id_exists $mapped_subcmd] && [punk::args::id_exists "(autodef)$mapped_subcmd"]} { + # set mapped_subcmd "(autodef)$mapped_subcmd" + #} + if {[punk::args::id_exists $mapped_subcmd]} { + set docid $mapped_subcmd + } elseif {[punk::args::id_exists "(autodef)$mapped_subcmd"]} { + set docid (autodef)$mapped_subcmd + } else { + set docid "" + } + #allow subhelp override - todo: review/document rationale/usecases + break + } + } } - #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list {*}$specid {*}$nextqueryargs] - if {[punk::args::id_exists $currentid]} { - set spec [punk::args::get_spec $currentid] - set form_names [dict get $spec form_names] - set fid [lindex $form_names 0] - - set specid $currentid - set specargs $queryargs_untested - set nextqueryargs [list] - - if {[llength $form_names] != 1} { - break + if {$mapped_subcmd eq ""} { + if {[string match (autodef)* $origin]} { + set raw_origin [string range $origin 9 end] + } else { + set raw_origin $origin } - set optnames [dict get $spec FORMS $fid OPT_NAMES] - set valnames [dict get $spec FORMS $fid VAL_NAMES] - if {[llength $optnames] || [llength $valnames]} { - break + #puts stderr "cmd_traverse testing punk::args::id_exists \"$raw_origin $resolved_q\"" + if {[punk::args::id_exists "$raw_origin $resolved_q"]} { + set mapped_subcmd "$raw_origin $resolved_q" + set docid $mapped_subcmd + } else { + #REVIEW - there is no reason to assume a subcommand (even in an ensemble) + #will be located at "${raw_origin}::$resolved_q" + #ensemble -map could point resolved_q somewhere else entirely + + #punk::args::update_definitions [list $raw_origin] + #if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} { + # set mapped_subcmd "${raw_origin}::$resolved_q" + # set docid $mapped_subcmd + #} else { + # if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} { + # namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"] + # } + # if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} { + # set mapped_subcmd ${raw_origin}::$resolved_q + # set docid (autodef)${raw_origin}::$resolved_q + # } + #} } - } else { - set is_subcommand_resolved 0 - set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] - set mapped_subcmd "" - foreach inf $cinfo { - if {[lindex $inf 0] eq "resolved"} { - set mapped_subcmd [lindex $inf 1] - set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] - puts "---> resolve_next: $resolve_next" - set sub_resolution [punk::ns::resolve_command {*}$resolve_next] - - set sub_args_remaining [dict get $sub_resolution args_remaining] - set sub_args_full [dict get $sub_resolution args_full] - #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] - set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] - - puts stderr "---> $sub_resolution" - puts stderr "---> $f" - dict set sub_resolution args_full $f - return $sub_resolution - - - #puts stderr "---> $sub_resolution" - #return $sub_resolution - } + } + #puts "----------$mapped_subcmd" + if {$mapped_subcmd ne ""} { + lappend resolvedargs $resolved_q + #ledit queryargs_untested 0 0 + lpop queryargs_untested 0 + + #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] + if {[llength $queryargs_untested] == 0} { + return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid] + } + + set origin [yield [list 0 $mapped_subcmd $resolvedargs $queryargs_untested $docid]] + #set resolvedargs [list] + incr i [expr {-1 * [llength $resolvedargs]+1}] + #puts stderr "... yield-result $origin i:$i" + + set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] + set origin [dict get $whichinfo origin] + set cmdtype [dict get $whichinfo origintype] + punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" } - #We can get no further with custom defs - #It is possible we have a documented lower level subcommand but missing the intermediate - #e.g if ::trace remove command was specified and is documented - it will be found above - #but if ::trace remove is not documented and the query is "::trace remove com" - #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. - #that's probably ok. break + } else { + #test with: i namespace which -v x + return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] } } + } else { + #?? + puts stderr "cmdinfo.cmd_traverse returning 8 $origin $resolvedargs [lrange $args $i end] $docid" + return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] } - #puts "--->origin $specid queryargs: $specargs" - set origin $specid - set queryargs $specargs + } else { + #puts stderr "origin $origin not documented" + return [list 9 $origin {} [lrange $args $i end] ""] } } - - if {[string match (autodef)* $origin]} { - set origin [string range $origin 9 end] - } - - - return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + #REVIEW!!! + puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" + return [list 10 $origin $resolvedargs $queryargs_untested $docid] } + punk::args::define { @id -id ::punk::ns::forms @cmd -name punk::ns::forms\ @@ -2604,16 +3748,17 @@ tcl::namespace::eval punk::ns { "List command forms."\ -help\ "Return names for each form of a command. - Most commands are single-form and will only return the name '_default'." + Most commands are single-form and will only return the name '_default'. + An example of a multiform command is the Tcl builtin '::after'." @opts @values -min 1 -max -1 cmditem -multiple 1 -optional 0 } proc forms {args} { set argd [::punk::args::parse $args withid ::punk::ns::forms] - set cmdmembers [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set id [dict get $cmdinfo origin] + set cmdwords [dict get $argd values cmditem] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + set id [dict get $resolveinfo origin] ::punk::args::forms $id } @@ -2631,9 +3776,9 @@ tcl::namespace::eval punk::ns { } proc eg {args} { set argd [::punk::args::parse $args withid ::punk::ns::eg] - set cmdmembers [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set resolved_id [dict get $cmdinfo origin] + set cmdwords [dict get $argd values cmditem] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + set resolved_id [dict get $resolveinfo origin] set result [::punk::args::eg $resolved_id] } @@ -2650,7 +3795,8 @@ tcl::namespace::eval punk::ns { the synopsis for that form. " @opts - -form -type string -default * + -form -type string -default * -help\ + "Ordinal index or name of command form." -return -type string -default full -choices {full summary dict} @values -min 1 -max -1 cmditem -multiple 1 -optional 0 @@ -2659,20 +3805,35 @@ tcl::namespace::eval punk::ns { set argd [::punk::args::parse $args withid ::punk::ns::synopsis] set form [dict get $argd opts -form] set opt_return [dict get $argd opts -return] - set cmdmembers [dict get $argd values cmditem] + set cmdwords [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set resolved_id [dict get $cmdinfo origin] - set unresolved_args [dict get $cmdinfo args_remaining] - set full_args [dict get $cmdinfo args_full] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + + set resolved_id [dict get $resolveinfo origin] + set doc_id [dict get $resolveinfo docid] + set unresolved_args [dict get $resolveinfo args_remaining] + set resolved_args [dict get $resolveinfo args_resolved] - #puts "---punk::args::synopsis resolve_command result: $cmdinfo" #REVIEW - set n [llength $unresolved_args] - set idparts [lrange $full_args 0 end-$n] + #set n [llength $unresolved_args] + #set cmdargs [lrange $args 1 end] + #set consumedargs [lrange $cmdargs 0 end-$n] + set synopsis_args [lrange $cmdwords 1 end] + set excess 0 + if {[llength $unresolved_args] > [llength $synopsis_args]} { + #we can get excess args_remaining due to alias currying - REVIEW + #This isn't quite right.. e.g see: s pse + #we need to use something like punk::args::parse against the command with the unresolved_args + synopsis_args ?? + set excess [expr {[llength $unresolved_args] - [llength $synopsis_args]}] + } - set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + + if {$doc_id eq ""} { + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + } else { + set syn [::punk::args::synopsis -return $opt_return -form $form $doc_id] + } if {$syn eq ""} { return } @@ -2685,8 +3846,10 @@ tcl::namespace::eval punk::ns { if {[string range $synline 0 1] eq "# "} { append resultstr $synline \n } else { - #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n - append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + #puts stderr [textblock::frame $syn] + #set replaceuntil [expr {[llength $resolved_id]-1}] + set replaceuntil [expr {[llength $resolved_id]-1+$excess}] + append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n } } set resultstr [string trimright $resultstr \n] @@ -2701,19 +3864,16 @@ tcl::namespace::eval punk::ns { proc synopsis_raw {args} { set argd [::punk::args::parse $args withid ::punk::ns::synopsis] set form [dict get $argd opts -form] - set cmdmembers [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set id [dict get $cmdinfo origin] + set cmdwords [dict get $argd values cmditem] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + set id [dict get $resolveinfo origin] ::punk::args::synopsis -form $form $id } - #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? - # - as this is interactive generally introspection should be ok at the top level - # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? punk::args::define { @dynamic - @id -id ::punk::ns::arginfo - @cmd -name punk::ns::arginfo\ + @id -id ::punk::ns::cmdhelp + @cmd -name punk::ns::cmdhelp\ -summary\ "Command usage/help."\ -help\ @@ -2733,7 +3893,7 @@ tcl::namespace::eval punk::ns { generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without - calling them. arginfo deliberately avoids calling commands to elicit + calling them. cmdhelp deliberately avoids calling commands to elicit usage information as this is inherently risky. (could create a file, exit the interp etc) " @@ -2744,8 +3904,8 @@ tcl::namespace::eval punk::ns { -form -default 0 -help\ "Ordinal index or name of command form" -grepstr -default "" -type list -typesynopsis regex -help\ - "list consisting of regex, optionally followed by ANSI names for highlighting - (incomplete - todo)" + "Case insensitive grep for pattern in the output. + list consisting of regex, optionally followed by ANSI names for highlighting" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2756,372 +3916,481 @@ tcl::namespace::eval punk::ns { "subcommand if commandpath is an ensemble. Multiple subcommands can be supplied if ensembles are further nested" } - proc arginfo {args} { - lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received + proc cmdhelp {args} { set nscaller [uplevel 1 [list ::namespace current]] - #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part - #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. + lassign [dict values [punk::args::parse $args withid ::punk::ns::cmdhelp]] leaders opts values received if {![dict exists $received -scheme]} { #dict set opts -scheme info set scheme_received 0 } else { set scheme_received 1; #so we know not to override caller's explicit choice } - set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] - set grepstr [dict get $opts -grepstr] - set opts [dict remove $opts -grepstr] - #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" + set opt_grepstr [dict get $opts -grepstr] + set opt_form [dict get $opts -form] + set opt_return [dict get $opts -return] + switch -- $opt_return { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + set nextopts [dict remove $opts -grepstr] + #JJJ + set whichinfo [uplevel 1 [list cmdwhich $querycommand]] + set rootorigin [dict get $whichinfo origin] + set which [dict get $whichinfo which] + set rootorigintype [dict get $whichinfo origintype] + set whichtype [dict get $whichinfo whichtype] + + + set rootinfo [uplevel 1 [list cmdinfo $which]] + set rootdoc [dict get $rootinfo docid] + #NOTE - we can get 'args_remaining' due to cmdinfo resolving to a curried alias target + set args_remaining [dict get $rootinfo args_remaining] + if {$rootdoc ne ""} { + if {$whichtype eq "alias"} { + #test if we could resolve further + set testinfo [punk::ns::cmdinfo $querycommand {*}$queryargs] + set testresolved [dict get $testinfo args_resolved] + if {[llength $testresolved] == 1} { + #only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand + ledit queryargs -1 -1 {*}$args_remaining ;#prepend + if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { + if {$opt_return eq "tableobject"} { + set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] + } else { + set result $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0 -parsedargs $parseresult] + } + if {$opt_grepstr ne ""} { + if {[llength $opt_grepstr] == 1} { + set result [punk::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] + } else { + set result [punk::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] + } + } + return $result + } + } + } - #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented - if {[string match ::* $querycommand]} { - set targetns [nsprefix $querycommand] - set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global - #when arginfo given a fully qualified path - we only want an answer for that exact command - set nscommands [info commands ${targetns}::*] - if {[lsearch -exact $nscommands $querycommand] >= 0} { - #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths - if {[catch { - set origin [nseval_ifexists $targetns [list ::namespace origin $name]] - set resolved [nseval_ifexists $targetns [list ::namespace which $name]] - }]} { - set origin $querycommand - set resolved $querycommand + #----------------------------------------------------------------------------------------------------------------------------- + #review! + #only divert to target script/alias if rootorigin undocumented + #if we were to jump straight to the alias or script target - we preclude the opportunity + #to lookup any user documentation that was specifically supplied for the alias at $which !!! + + switch -- $rootorigintype { + script { + #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + set scriptargs [lrange $rootorigin 1 end] ;#arguments that were curried into the alias script + set scriptcmd [lindex $rootorigin 0] + set nextqueryargs [list {*}$scriptargs {*}$queryargs] + #puts stderr "cmdhelp $nextopts $scriptcmd $nextqueryargs" + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] + } + alias { + #e.g alias to an alias + #JJJ2 + #puts "JJJ2 rootorigin:$rootorigin" + if {[string match >* [nstail $rootorigin]] && [package provide pattern] ne ""} { + if {![catch {pattern::which_alias $rootorigin} alias_target]} { + #review - todo? + set targetcmd [lindex $alias_target 0] + set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts {*}$targetcmd {*}$queryargs]] + } + } + if {$which eq $rootorigin} { + #origin points to self which is an alias - can happen if an alias has been renamed + } else { + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts {*}$rootorigin {*}$queryargs]] } - } else { - #fully qualified command specified but doesn't exist - set origin $querycommand - set resolved $querycommand } - } else { - #relative comandpath - if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup - set origin $querycommand - set resolved $querycommand - } else { - set thispath [uplevel 1 [list ::nsthis $querycommand]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + } + #----------------------------------------------------------------------------------------------------------------------------- + + #puts "-----> rootorigin $rootorigin queryargs $queryargs" + set cinfo [uplevel 1 [list cmdinfo $rootorigin {*}$queryargs]] + + + set origin [dict get $cinfo origin] + set origindoc [dict get $cinfo docid] + set args_remaining [dict get $cinfo args_remaining] + set origintype [dict get $cinfo cmdtype] + + switch -- $origintype { + script { + #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script + set scriptcmd [lindex $origin 0] + set nextqueryargs [list {*}$scriptargs {*}$args_remaining] + #puts stderr "cmdhelp $nextopts $scriptcmd $args_remaining" + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] + } + } + if {$origindoc ne ""} { + + + if {[catch {punk::args::parse $args_remaining -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { + if {$opt_return eq "tableobject"} { + set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { - set valid_ns [namespace exists $targetns] + set result $parseresult } - if {$valid_ns} { - if {[catch { - set origin [nseval_ifexists $targetns [list ::namespace origin $name]] - set resolved [nseval_ifexists $targetns [list ::namespace which $name]] - }]} { - set thiscmd [nsjoin $targetns $name] - #relative querycommand specified - but Tcl didn't find a match in namespace path - #assume global (todo - look for namespace match in auto_index first ?) - set origin ::$name - set resolved ::$name - } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0 -parsedargs $parseresult] + } + if {$opt_grepstr ne ""} { + if {[llength $opt_grepstr] == 1} { + set result [punk::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] } else { - #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global + set result [punk::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] + } + } + return $result + } else { + return "Undocumented command $origin. Type: $origintype" + } + + #return [cmdinfo $origin {*}$queryargs] + } + + + + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? + # - as this is interactive generally introspection should be ok at the top level + # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? + #TODO - make obsolete - (replaced by punk::ns::cmdhelp) + punk::args::define { + @dynamic + @id -id ::punk::ns::arginfo + @cmd -name punk::ns::arginfo\ + -summary\ + "Command usage/help."\ + -help\ + "Show usage info for a command. + It supports the following: + 1) Procedures or builtins for which a punk::args definition has + been loaded. + 2) tepam procedures (returns string form only) + 3) ensemble commands - auto-generated unless documented via punk::args + (subcommands will show with an indicator if they are + explicitly documented or are themselves ensembles) + 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 5) dereferencing of aliases to find underlying command + (will not work with some renamed aliases) + + Note that native commands commands not explicitly documented will + generally produce no useful info. For example sqlite3 dbcmd objects + could theoretically be documented - but as 'info cmdtype' just shows + 'native' they can't (?) be identified as belonging to sqlite3 without + calling them. arginfo deliberately avoids calling commands to elicit + usage information as this is inherently risky. (could create a file, + exit the interp etc) + " + -return -type string -default table -choices {string table tableobject} + + + } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { + -form -default 0 -help\ + "Ordinal index or name of command form" + -grepstr -default "" -type list -typesynopsis regex -help\ + "list consisting of regex, optionally followed by ANSI names for highlighting + (incomplete - todo)" + -- -type none -help\ + "End of options marker + Use this if the command to view begins with a -" + @values -min 1 + commandpath -help\ + "command (may be alias, ensemble, tcl::oo object, tepam proc etc)" + subcommand -optional 1 -multiple 1 -default {} -help\ + "subcommand if commandpath is an ensemble. + Multiple subcommands can be supplied if ensembles are further nested" + } + proc arginfo {args} { + lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received + set nscaller [uplevel 1 [list ::namespace current]] + #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part + #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. + if {![dict exists $received -scheme]} { + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice + } - #set numvals [expr {[llength $queryargs]+1}] - ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" - #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] - if {$nscaller ne "::"} { - if {!$scheme_received} { - dict unset opts -scheme - } - return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] - } + set querycommand [dict get $values commandpath] + set queryargs [dict get $values subcommand] + set grepstr [dict get $opts -grepstr] + set opts [dict remove $opts -grepstr] + #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" - set origin $querycommand - set resolved $querycommand + #todo - similar to corp? review corp resolution process + #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented - } + set cinfo [uplevel 1 [list cmdwhich $querycommand]] + set origin [dict get $cinfo origin] + set resolved [dict get $cinfo which] + set cmdtype [dict get $cinfo origintype] + switch -- $cmdtype { + script { + #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script + set origin [lindex $origin 0] + set queryargs [list {*}$scriptargs {*}$queryargs] + return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] + } + alias { + #alias to an alias + return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] } } + #JJJ #check for a direct match first - if {[info commands ::punk::args::id_exists] ne ""} { - if {![llength $queryargs]} { - #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" - punk::args::update_definitions [list [namespace qualifiers $origin]] - if {[punk::args::id_exists $origin]} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] - } - } + if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" + punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: + if {![punk::args::id_exists $origin] && ![punk::args::id_exists (autodef)$origin]} { + uplevel 1 [list punk::ns::generate_autodef $origin] } - } - #ns::cmdtype only detects alias type on 8.7+? - set initial_cmdtype [punk::ns::cmdtype $origin] - switch -- $initial_cmdtype { - na - alias { - #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) - set tgt [interp alias "" $origin] - if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft $origin :]] + if {[punk::args::id_exists (autodef)$origin]} { + set origin (autodef)$origin + } + if {[punk::args::id_exists $origin]} { + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } } - #first word of tgt may be namespace relative or absolute - if {$tgt ne ""} { - set word1 [lindex $tgt 0] - if {$word1 eq "punk::mix::base::_cli"} { - #special case for punk deck - REVIEW - #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set targetword [lindex $tgt end] + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] } else { - #todo - alias may have prefilled some leading args - so usage report should reflect that??? - #(possible curried arguments) - #review - curried arguments could be for ensembles! - set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] - #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" - #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] - if {!$scheme_received} { - dict unset opts -scheme - } - return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + return $parseresult } - - - set origin $targetword - #retest cmdtype on modified origin - set cmdtype [punk::ns::cmdtype $origin] } else { - set cmdtype $initial_cmdtype - } - if {$cmdtype eq "na"} { - #tcl 8.6 - if {[info object isa object $origin]} { - set cmdtype "object" + if {!$scheme_received} { + dict set opts -scheme info } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] } } - default { - set cmdtype $initial_cmdtype - } } set id $origin - if {[info commands ::punk::args::id_exists] ne ""} { + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] - #check longest first checking for id matching ::cmd ?subcmd..? - #REVIEW - this doesn't cater for prefix callable subcommands - set argcopy $queryargs - if {[llength $queryargs]} { - #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" - punk::args::update_definitions [list [namespace qualifiers $id]] - if {[punk::args::id_exists [list $id {*}$queryargs]]} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } + #check longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands + if {[llength $queryargs]} { + if {[punk::args::id_exists [list $id {*}$queryargs]]} { + switch -- [dict get $opts -return] { + string { + set estyle "basic" } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] - } else { - return $parseresult - } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + return $parseresult } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] } } - #while {[llength $argcopy]} { - # if {[punk::args::id_exists [list $id {*}$argcopy]]} { - # return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] - # } - # lpop argcopy - #} + } - #didn't find any exact matches - #traverse from other direction taking prefixes into account + #didn't find any exact matches + #traverse from other direction taking prefixes into account + set specid "" + if {[punk::args::id_exists $id]} { + set specid $id + } elseif {[punk::args::id_exists (autodef)$id]} { + set specid (autodef)$id + } - #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" - punk::args::update_definitions [list [namespace qualifiers $id]] - if {[punk::args::id_exists $id]} { - #cycle forward through leading values - set specid $id - set specargs $queryargs - if {[llength $queryargs]} { - #jjj - set spec [punk::args::get_spec $id] - #--------------------------------------------------------------------------- - set form_names [dict get $spec form_names] - if {[llength $form_names] == 1} { - set fid [lindex $form_names 0] + if {$specid ne "" && [punk::args::id_exists $specid]} { + #cycle forward through leading values + set specargs $queryargs + if {[llength $queryargs]} { + #jjj + set spec [punk::args::get_spec $specid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] } else { - #review - -form only applies to final command? - # -form must be a list if we have multiple levels of multi-form commands? - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid [lindex $form_names $opt_form] - } else { - if {$opt_form ni $form_names} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid $opt_form + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" } + set fid $opt_form } - #--------------------------------------------------------------------------- - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs - set queryargs_untested $queryargs - foreach q $queryargs { - if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { - #todo: fix - set subitems [dict get $spec FORMS $fid LEADER_NAMES] - if {[llength $subitems]} { - set next [lindex $subitems 0] - set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - - set allchoices [list] - set choices [punk::args::system::Dict_getdef $arginfo -choices {}] - set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] - #maintenance smell - similar/dup of some punk::args logic - review - #-choiceprefixdenylist ?? - set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices {*}$clist - } - set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] - if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { - break + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + #todo: fix + set subitems [dict get $spec FORMS $fid LEADER_NAMES] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + #maintenance smell - similar/dup of some punk::args logic - review + #-choiceprefixdenylist ?? + set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] + if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { + break + } + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + #ledit queryargs_untested 0 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] + #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" + if {!$scheme_received} { + dict unset opts -scheme } - lappend nextqueryargs $resolved_q - #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] - #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] - #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - if {!$scheme_received} { - dict unset opts -scheme - } - return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] - } - #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list {*}$specid {*}$nextqueryargs] - if {[punk::args::id_exists $currentid]} { - set spec [punk::args::get_spec $currentid] - #--------------------------------------------------------------------------- - set form_names [dict get $spec form_names] - if {[llength $form_names] == 1} { - set fid [lindex $form_names 0] + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] } else { - #review - -form only applies to final command? - # -form must be a list if we have multiple levels of multi-form commands? - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid [lindex $form_names $opt_form] - } else { - if {$opt_form ni $form_names} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid $opt_form + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" } + set fid $opt_form } - #--------------------------------------------------------------------------- - set specid $currentid - set specargs $queryargs_untested - set nextqueryargs [list] - } else { - #We can get no further with custom defs - #It is possible we have a documented lower level subcommand but missing the intermediate - #e.g if ::trace remove command was specified and is documented - it will be found above - #but if ::trace remove is not documented and the query is "::trace remove com" - #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. - #that's probably ok. - break } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + } else { + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break } - } else { - #review - break } + } else { + #review + break } - } else { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } + } + } else { + switch -- [dict get $opts -return] { + string { + set estyle "basic" } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] - } else { - return $parseresult - } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] } - #puts "--->origin $specid queryargs: $specargs" - set origin $specid - set queryargs $specargs } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } if {[string match "(autodef)*" $origin]} { @@ -3130,6 +4399,7 @@ tcl::namespace::eval punk::ns { set resolved $origin } + set autoid "" switch -- $cmdtype { object { #class is also an object @@ -3345,7 +4615,7 @@ tcl::namespace::eval punk::ns { set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -name "${$location} ${$c1}" -help\ - "(autogenerated) + "(autogenerated by arginfo) arglist:${$arglist}" @values }] @@ -3393,19 +4663,27 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - if {$location eq "object"} { + if {$location eq $origin} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" - dict set choiceinfodict $cmd {{doctype ooo}} + dict set choiceinfodict $cmd {{doctype objectmethod}} + } elseif {$location eq $class} { + set id "$class $cmd" + dict set choiceinfodict $cmd {{doctype classmethod}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" - dict set choiceinfodict $cmd {{doctype ooc}} + if {[string match "core method:*" $methodtype]} { + dict lappend choiceinfodict $cmd {doctype coremethod} + } else { + dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] + } } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" dict lappend choiceinfodict $cmd {doctype punkargs} + dict lappend choiceinfodict $cmd [list subhelp {*}$id] } } break @@ -3423,16 +4701,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" - set idauto "(autodef)$origin" + set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$autoid} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 }] append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $idauto] + } privateObject { return "Command is a privateObject - no info currently available" @@ -3443,172 +4721,151 @@ tcl::namespace::eval punk::ns { interp { #todo } - } + script { + #todo + } + ensemble { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? - #check ensemble before testing punk::arg::id_exists - #we want to recalculate ensemble usage info in case ensemble has been modified + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] - if {[namespace ensemble exists $origin]} { - #review - #todo - check -unknown - #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. - #presumably -choiceprefix should be zero in that case?? - - set ensembleinfo [namespace ensemble configure $origin] - set parameters [dict get $ensembleinfo -parameters] - set prefixes [dict get $ensembleinfo -prefixes] - set map [dict get $ensembleinfo -map] - set ns [dict get $ensembleinfo -namespace] - - #review - we can have a combination of commands from -map as well as those exported from -namespace - # if and only if -subcommands is specified - - set subcommand_dict [dict create] - set commands [list] - set nscommands [list] - if {[llength [dict get $ensembleinfo -subcommands]]} { - #set exportspecs [namespace eval $ns {namespace export}] - #foreach pat $exportspecs { - # lappend nscommands {*}[info commands ${ns}::$pat] - #} - #when using -subcommands, even unexported commands are available - set nscommands [info commands ${ns}::*] - foreach sub [dict get $ensembleinfo -subcommands] { - if {[dict exists $map $sub]} { - #-map takes precence over same name exported from -namespace - dict set subcommand_dict $sub [dict get $map $sub] - } elseif {"${ns}::$sub" in $nscommands} { - dict set subcommand_dict $sub ${ns}::$sub - } else { - #subcommand probably supplied via -unknown handler? - dict set subcommand_dict $sub "" + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } } - } - } else { - if {[dict size $map]} { - set subcommand_dict $map } else { - set exportspecs [namespace eval $ns {namespace export}] - foreach pat $exportspecs { - lappend nscommands {*}[info commands ${ns}::$pat] - } - foreach fqc $nscommands { - dict set subcommand_dict [namespace tail $fqc] $fqc + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } } } - } - set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $queryargs]} { - set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand - if {$posn_subcommand > 0} { - set params [lrange $queryargs 0 $posn_subcommand-1] - set remaining_queryargs [lrange $queryargs $posn_subcommand end] - } else { - set params [list] - set remaining_queryargs $queryargs - } - if {[llength $remaining_queryargs]} { - if {$prefixes} { - set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + set subcommands [lsort [dict keys $subcommand_dict]] + if {[llength $queryargs]} { + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] } else { - set match [lindex $remaining_queryargs 0] + set params [list] + set remaining_queryargs $queryargs } - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - if {!$scheme_received} { - dict unset opts -scheme + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } - #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] - #use tailcall so %caller% is reported properly in error msg - tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } - } - set have_usageinfo [list] - set is_ensemble [list] - set is_object [list] - set is_class [list] - set is_native [list] - set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set targetfirstword [lindex $subwhat 0] - set ns [::namespace which $targetfirstword] - set ns [nsprefix $ns] - set targettail [namespace tail $targetfirstword] - if {![dict exists $namespaces $ns]} { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] - dict set namespaces $ns $nsinfo - } else { - set nsinfo [dict get $namespaces $ns] - } - if {$targettail in [dict get $nsinfo usageinfo]} { - lappend have_usageinfo $sub - } - if {$targettail in [dict get $nsinfo ensembles]} { - lappend is_ensemble $sub - } - if {$targettail in [dict get $nsinfo ooobjects]} { - lappend is_object $sub - } - if {$targettail in [dict get $nsinfo ooclasses]} { - lappend is_class $sub - } - if {$targettail in [dict get $nsinfo native]} { - lappend is_native $sub - } - } + #todo - synopsis? + set choicelabeldict [dict create] - #todo - synopsis? - set choicelabeldict [dict create] + set choiceinfodict [dict create] - set choiceinfodict [dict create] - foreach sub $subcommands { + dict for {sub subwhat} $subcommand_dict { + if {[llength $subwhat] > 1} { + #TODO - resolve using cmdinfo? + puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" + } + set targetfirstword [lindex $subwhat 0] + set targetinfo [cmdwhich $targetfirstword] + set targetorigin [dict get $targetinfo origin] + set targetcmdtype [dict get $targetinfo origintype] + set nstarget [nsprefix $targetorigin] - if {$sub in $is_ensemble} { - dict lappend choiceinfodict $sub {doctype ensemble} - } + dict lappend choiceinfodict $sub [list doctype $targetcmdtype] - if {$sub in $is_object} { - if {$sub in $is_class} { - dict lappend choiceinfodict $sub {doctype ooc} + if {[punk::args::id_exists [list $origin $sub]]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] + } elseif {[punk::args::id_exists $targetorigin]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] } else { - dict lappend choiceinfodict $sub {doctype ooo} + #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" } - } - if {$sub in $is_native} { - dict lappend choiceinfodict $sub {doctype native} } - if {$sub in $have_usageinfo} { - #dict set choiceinfodict $sub [list {doctype punkargs}] - dict lappend choiceinfodict $sub {doctype punkargs} + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + puts "ENSEMBLE auto def $autoid (arginfo)" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated by arginfo) + ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } } + append argdef \n $vline + punk::args::define $argdef } + } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] - set autoid "(autodef)$origin" - set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} - @cmd -help\ - "(autogenerated) - ensemble: ${$origin}" - @leaders -min 1 - }] - if {[llength $parameters] == 0} { - append argdef \n "@leaders -min 1" - } else { - append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" - foreach p $parameters { - append argdef \n "$p -type string -help { (leading ensemble parameter)}" - } - } - append argdef \n $vline - punk::args::define $argdef + #if {$autoid ne ""} { + # return [punk::args::usage {*}$opts $autoid] + #} + + + #check ensemble before testing punk::arg::id_exists + #we want to recalculate ensemble usage info in case ensemble has been modified + + if {$autoid ne ""} { switch -- [dict get $opts -return] { string { set estyle "basic" @@ -3670,7 +4927,7 @@ tcl::namespace::eval punk::ns { } set origin_ns [nsprefix $origin] - set parts [nsparts $origin_ns] + set parts [nsparts_cached $origin_ns] set weird_ns 0 if {[lsearch $parts :*] >=0} { set weird_ns 1 @@ -3825,8 +5082,10 @@ tcl::namespace::eval punk::ns { set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] - #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! - if {$origin ni [info procs $origin]} { + #A renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! + #set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x + set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] + if {$origin ni $iproc} { #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. @@ -3861,17 +5120,32 @@ tcl::namespace::eval punk::ns { append body \n } if {![catch {package require textutil::tabify} errpkg]} { - set bodytext [info body $origin] + #set bodytext [info body $origin] + set bodytext [nseval $targetns [list ::info body $name]] #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { - append body [info body $origin] + #append body [info body $origin] + #relevant test test::punk::ns SUITE ns corp.test corp_leadingcolon_functionname + append body [nseval $targetns [list ::info body $name]] } set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set argnames [nseval $targetns [list ::info args $name]] + foreach a $argnames { + #if {[info default $origin $a defvar]} { + # lappend a $defvar + #} + set result [nseval $targetns [string map [list %n% $name %a% $a] { + #qualify all command names when running in arbitrary namespace + ::if {[::info default "%n%" "%a%" punk_ns_corp_defvar]} { + ::return [::list default $punk_ns_corp_defvar][::unset punk_ns_corp_defvar] ;#keep the targetns tidy + } else { + ::return [::list none] + } + }]] + if {[lindex $result 0] eq "default"} { + lappend a [lindex $result 1] } lappend argl $a } @@ -4165,13 +5439,13 @@ tcl::namespace::eval punk::ns { set ns_populated 0 set i 0 set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing - set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] + set ns_depth [llength [punk::ns::nsparts_cached [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base #e.g if we are loading ::x::y #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] - set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] + set k_depth [llength [punk::ns::nsparts_cached [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { set auto_source [set ::auto_index($k)] if {$auto_source ni $already_sourced} { @@ -4228,7 +5502,7 @@ tcl::namespace::eval punk::ns { } } return [dict create vars $capturevars arrs $capturearrs] - } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) + } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) (could use 'nsjoin [namespace current] *') } ] @@ -4282,7 +5556,7 @@ tcl::namespace::eval punk::ns { -targetnamespace -optional 1 -help\ "Namespace in which to import commands. If namespace is relative (no leading ::), - the namespace is relative to the caller'd namespace. + the namespace is relative to the caller's namespace. If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" @@ -4339,6 +5613,13 @@ tcl::namespace::eval punk::ns { if {[tcl::dict:::exists $received -prefix]} { #import via temporary/intermediate namespace set pfx [dict get $opts -prefix] + set import_via_temp 1 + } else { + set pfx "" + set import_via_temp 0 + } + set import_via_temp 1; #import to weirdns only works with tempns + if {$import_via_temp} { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp @@ -4350,7 +5631,11 @@ tcl::namespace::eval punk::ns { if {![catch {::tcl::namespace::eval $tmpns [list ::namespace import ${srcns}::$func]}]} { #renaming will fail if target already exists #renaming a command into another namespace still results in a command with 'info cmdtype' = 'import' - if {![catch {::tcl::namespace::eval $tmpns [list ::rename $func [::punk::ns::nsjoin $tgtns $pfx$func]]}]} { + #if {![catch {::tcl::namespace::eval $tmpns [list ::rename $func [::punk::ns::nsjoin $tgtns $pfx$func]]}]} { + # set cmd $pfx$func + #} + if {![catch {punk::ns::nseval $tgtns [list ::rename ${tmpns}::$func $pfx$func]}]} { + #renaming into a weirdns only works if run in the target ns. set cmd $pfx$func } } @@ -4367,7 +5652,15 @@ tcl::namespace::eval punk::ns { foreach e $a_exported_tails { set imported [apply {{tgtns func srcns} { set cmd "" - if {![catch {tcl::namespace::eval $tgtns [list namespace import ${srcns}::$func]}]} { + #if {![catch {tcl::namespace::eval $tgtns [list namespace import ${srcns}::$func]}]} { + # set cmd $func + #} + #namespace import doesn't seem to import into some weirdly named namespaces + #even if evaluated in that namespace + #e.g ns with leading colon. + #e.g ::jjj:::::aaa (jjj -> : -> aaa) + #will instead create new ns at ::jjj::aaa and import there. + if {![catch {punk::ns::nseval $tgtns [list namespace import ${srcns}::$func]}]} { set cmd $func } set cmd @@ -4397,6 +5690,10 @@ tcl::namespace::eval punk::ns { interp alias {} nslist {} punk::ns::nslist interp alias {} nslist_dict {} punk::ns::nslist_dict + interp alias {} cmdwhich {} punk::ns::cmdwhich + interp alias {} cmdinfo {} punk::ns::cmdinfo + interp alias {} cmdtype {} punk::ns::cmdtype + #extra slash implies more verbosity (ie display commands instead of just nschildren) interp alias {} n/ {} punk::ns::ns/ / interp alias {} n// {} punk::ns::ns/ // @@ -4415,7 +5712,8 @@ tcl::namespace::eval punk::ns { interp alias {} corp {} punk::ns::corp - interp alias {} i {} punk::ns::arginfo + interp alias {} i {} punk::ns::cmdhelp + interp alias {} j {} punk::ns::arginfo ;#todo - make obsolete #An example of using punk::args in a pipeline punk::args::define { diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index 8d6ebc75..22511824 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -328,7 +328,7 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::$dp + $COMMANDSTACKNEXT require punk::args::moduledoc::$dp } } #--------------------------------------------------------------- diff --git a/src/modules/punk/pcon-999999.0a1.0.tm b/src/modules/punk/pcon-999999.0a1.0.tm index 6e4d3119..0424f358 100644 --- a/src/modules/punk/pcon-999999.0a1.0.tm +++ b/src/modules/punk/pcon-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::pcon 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::pcon 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/pdf-999999.0a1.0.tm b/src/modules/punk/pdf-999999.0a1.0.tm index 73ece0a9..10df370b 100644 --- a/src/modules/punk/pdf-999999.0a1.0.tm +++ b/src/modules/punk/pdf-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::pdf 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::pdf 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -114,7 +114,7 @@ namespace eval ::punk::pdf { " @leaders -min 0 -max 0 @opts -min 0 -max 2 - -p|-page_indexes -parsekey -page_indexes -type string -default "0.." -help\ + -p|-page_indexes -parsekey -page_indexes -type indexset -default "0.." -help\ "Comma delimited list of indexes and/or ranges specifying which pages to output. The indexes are 0-based. Ranges must be specified with .. as the separator. @@ -127,8 +127,9 @@ namespace eval ::punk::pdf { 0..2,end output the first 3 pages, and the last page. end-1..0 - output the pages in reverse order from 2nd last page to first page." - -b|-block_indexes -parsekey -block_indexes -type string -default "0.." -help\ + output the pages in reverse order from 2nd last page to first page. + see also 'punk::lib::resolve_indexset'" + -b|-block_indexes -parsekey -block_indexes -type indexset -default "0.." -help\ "Comma delimited list of indexes and/or ranges specifying which blocks to output. Format is as per -page_indexes" -merge_yblocks -default false -help\ @@ -1390,6 +1391,8 @@ namespace eval ::punk::pdf { return } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::pdf ---}] } diff --git a/src/modules/punk/pipe-999999.0a1.0.tm b/src/modules/punk/pipe-999999.0a1.0.tm index 555a5996..d97f45f7 100644 --- a/src/modules/punk/pipe-999999.0a1.0.tm +++ b/src/modules/punk/pipe-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::pipe 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::pipe 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -61,48 +61,16 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::pipe::class { - #*** !doctools - #[subsection {Namespace punk::pipe::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::pipe { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools #[subsection {Namespace punk::pipe}] - #[para] Core API functions for punk::pipe + #[para] Core API functions for punk::pipe #[list_begin definitions] @@ -110,13 +78,13 @@ tcl::namespace::eval punk::pipe { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} #https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ @@ -735,16 +703,6 @@ tcl::namespace::eval punk::pipe::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::pipe::system { - #*** !doctools - #[subsection {Namespace punk::pipe::system}] - #[para] Internal functions that are not part of the API - - - -#} # == === === === === === === === === === === === === === === diff --git a/src/modules/punk/pluginmgr-0.5.1.tm b/src/modules/punk/pluginmgr-0.5.1.tm new file mode 100644 index 00000000..6bdf3fec --- /dev/null +++ b/src/modules/punk/pluginmgr-0.5.1.tm @@ -0,0 +1,441 @@ +# plugin.tcl -- +# +# Generic plugin management. +# +# Copyright (c) 2005 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ### ### ### ######### ######### ######### +## Description + +# Each instance of the plugin manager can be configured with data +# which specifies where to find plugins, and how to validate +# them. With that it can then be configured to load and provide access +# to a specific plugin, doing all required checks and +# initialization. Users for specific plugin types simply have to +# encapsulate the generic class, providing all the specifics, leaving +# their users only the task of naming the requested actual plugin. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 9 +package require snit +package require file::home ;# file home forward compatibility + +# ### ### ### ######### ######### ######### +## Implementation + +snit::type ::punk::pluginmgr { + + # ### ### ### ######### ######### ######### + ## Public API - Options + + # - Pattern to match package name. Exactly one '*'. No default. + # - List of commands the plugin has to provide. Empty list default. + # - Callback for additional checking after the API presence has + # been verified. Empty list default. + # - Dictionary of commands to put into the plugin interpreter. + # Key: cmds for plugin, value is cmds to invoke for them. + # - Interpreter to use for the -cmds (invoked commands). Default + # is current interp. + # - Callback for additional setup actions on the plugin + # interpreter after its creation, but before plugin is loaded into + # it. Empty list default. + + option -pattern {} + option -api {} + option -check {} + option -cmds {} + option -cmdip {} + option -setup {} + + # ### ### ### ######### ######### ######### + ## Public API - Methods + + method do {args} { + if {$plugin eq ""} { + return -code error "No plugin defined" + } + return [$sip eval $args] + } + + method interpreter {} { + return $sip + } + + method plugin {} { + return $plugin + } + + method load {name} { + if {$name eq $plugin} return + + if {$options(-pattern) eq ""} { + return -code error "Translation pattern is not configured" + } + + set save $sip + + $self SetupIp + if {![$self LoadPlugin $name]} { + set sip $save + return -code error "Unable to locate or load plugin \"$name\" ($myloaderror)" + } + + if {![$self CheckAPI missing]} { + set sip $save + return -code error \ + "Cannot use plugin \"$name\", API incomplete: \"$missing\" missing" + } + + set savedname $plugin + set plugin $name + if {![$self CheckExternal]} { + set sip $save + set plugin $savedname + return -code error \ + "Cannot use plugin \"$name\", API bad" + } + $self SetupExternalCmds + + if {$save ne ""} {interp delete $save} + return + } + + method unload {} { + if {$sip eq ""} return + interp delete $sip + set sip "" + set plugin "" + return + } + + method list {} { + if {$options(-pattern) eq ""} { + return -code error "Translation pattern is not configured" + } + + set save $sip + $self SetupIp + + set result {} + set pattern [string map [list \ + + \\+ ? \\? \ + \[ \\\[ \] \\\] \ + ( \\( ) \\) \ + . \\. \* {(.*)} \ + ] $options(-pattern)] + set bogus [string map {* bogus-package} $pattern] + # @mdgen NODEP: bogus-package + $sip eval [list catch [list package require $bogus]] + foreach p [$sip eval {package names}] { + if {![regexp $pattern $p -> plugintail]} continue + lappend result $plugintail + } + + interp delete $sip + set sip $save + return $result + } + + method path {path} { + set path [file join [pwd] $path] + if {[lsearch -exact $paths $path] < 0} { + lappend paths $path + } + return + } + + method paths {} { + return $paths + } + + method clone {} { + set o [$type create %AUTO% \ + -pattern $options(-pattern) \ + -api $options(-api) \ + -check $options(-check) \ + -cmds $options(-cmds) \ + -cmdip $options(-cmdip) \ + -setup $options(-setup)] + + $o __clone__ $paths $sip $plugin + + # Clone has become owner of the interp. + set sip {} + set plugin {} + + return $o + } + + method __clone__ {_paths _sip _plugin} { + set paths $_paths + set sip $_sip + set plugin $_plugin + return + } + + # ### ### ### ######### ######### ######### + ## Internal - Configuration and state + + variable paths {} ; # List of paths to provide the sip with. + variable sip {} ; # Safe interp used for plugin execution. + variable plugin {} ; # Name of currently loaded plugin. + variable myloaderror {} ; # Last error reported by the Safe base + + # ### ### ### ######### ######### ######### + ## Internal - Object construction and descruction. + + constructor {args} { + $self configurelist $args + return + } + + destructor { + if {$sip ne ""} {interp delete $sip} + return + } + + # ### ### ### ######### ######### ######### + ## Internal - Option management + + onconfigure -pattern {newvalue} { + set current $options(-pattern) + if {$newvalue eq $current} return + + set n [regexp -all "\\*" $newvalue] + if {$n < 1} { + return -code error "Invalid pattern, * missing" + } elseif {$n > 1} { + return -code error "Invalid pattern, too many *'s" + } + + set options(-pattern) $newvalue + return + } + + onconfigure -api {newvalue} { + set current $options(-api) + if {$newvalue eq $current} return + set options(-api) $newvalue + return + } + + onconfigure -cmds {newvalue} { + set current $options(-cmds) + if {$newvalue eq $current} return + set options(-cmds) $newvalue + return + } + + onconfigure -cmdip {newvalue} { + set current $options(-cmdip) + if {$newvalue eq $current} return + set options(-cmdip) $newvalue + return + } + + + # ### ### ### ######### ######### ######### + ## Internal - Helper commands + + method SetupIp {} { + set sip [::safe::interpCreate] + foreach p $paths { + ::safe::interpAddToAccessPath $sip $p + } + + if {![llength $options(-setup)]} return + uplevel \#0 [linsert $options(-setup) end $self $sip] + return + } + + method LoadPlugin {name} { + #if {[file exists $name]} { + # # Plugin files are loaded directly. + # $sip invokehidden source $name + # return 1 + #} + + #JN - diverging from tcllib - review + foreach p $paths { + set fp [file join $p $name] + #This won't load .tm files + if {[file exists $fp.tcl] && [file type $fp.tcl] eq "file"} { + # Plugin files can be loaded directly without pkgIndex.tcl + # This allows dropping of a single plugin.tcl file into a home or env based plugin path + # Such a file may override libs here or on auto_path, and may override modules already in tm path. + $sip invokehidden source $fp.tcl + return 1 + } + #if {[file exists [file join $p pkgIndex.tcl]]} { + # $sip invokehidden source [file join $p pkgIndex.tcl] + # #and pkgIndex.tcl one level deep - review + # set subdirs [glob -nocomplain -directory $p -types d -tails *] + # foreach s $subdirs { + # if {[file exists [file join $p $s pkgIndex.tcl]]} { + # $sip invokehidden source [file join $p $s pkgIndex.tcl] + # } + # } + # #continue below to load packages + #} + } + + # Otherwise the name is transformed into a package name + # and loaded thorugh the package management. + + set pluginpackage [string map \ + [list * $name] $options(-pattern)] + + ::safe::setLogCmd [mymethod PluginError] + if {[catch { + $sip eval [list package require $pluginpackage] + } res]} { + ::safe::setLogCmd {} + return 0 + } + ::safe::setLogCmd {} + return 1 + } + + method CheckAPI {mv} { + upvar 1 $mv missing + if {![llength $options(-api)]} {return 1} + + # Check the plugin for useability. + + foreach p $options(-api) { + if {[llength [$sip eval [list info commands $p]]] == 1} continue + interp delete $sip + set missing $p + return 0 + } + return 1 + } + + method CheckExternal {} { + if {![llength $options(-check)]} {return 1} + return [uplevel \#0 [linsert $options(-check) end $self]] + } + + + method SetupExternalCmds {} { + if {![llength $options(-cmds)]} return + + set cip $options(-cmdip) + foreach {pcmd ecmd} $options(-cmds) { + eval [linsert $ecmd 0 interp alias $sip $pcmd $cip] + #interp alias $sip $pcmd $cip {*}$ecmd + } + return + } + + method PluginError {message} { + if {[string match {*script error*} $message]} return + set myloaderror $message + return + } + + # ### ### ### ######### ######### ######### + + proc paths {pmgr args} { + if {[llength $args] == 0} { + return -code error "wrong#args: Expect \"[info level 0] object name...\"" + } + foreach name $args { + AddPaths $pmgr $name + } + return + } + + proc AddPaths {pmgr name} { + global env tcl_platform + + if {$tcl_platform(platform) eq "windows"} { + set sep \; + } else { + set sep : + } + + #puts "$pmgr += ($name) $sep" + + regsub -all {::+} [string trim $name :] \000 name + set name [split $name \000] + + # Environment variables + + set prefix {} + foreach part $name { + lappend prefix $part + set ev [string toupper [join $prefix _]]_PLUGINS + + #puts "+? env($ev)" + + if {[info exists env($ev)]} { + foreach path [split $env($ev) $sep] { + $pmgr path $path + } + } + } + + # Windows registry + + if { + ($tcl_platform(platform) eq "windows") && + ![catch {package require registry}] + } { + foreach root { + HKEY_LOCAL_MACHINE + HKEY_CURRENT_USER + } { + set prefix {} + foreach part $name { + lappend prefix $part + set rk $root\\SOFTWARE\\[join $prefix \\]PLUGINS + + #puts "+? registry($rk)" + + if {![catch {set data [registry get $rk {}]}]} { + foreach path [split $data $sep] { + $pmgr path $path + } + } + } + } + } + + # Home directory dot path + + set prefix {} + foreach part $name { + lappend prefix $part + set pd [file join [file home] .[join $prefix /] plugin] + #puts "+? path($pd)" + + if {[file exists $pd]} { + $pmgr path $pd + } + + # Cover for the goof in the example found in the docs. + # Note that supporting the directory name 'plugins' is + # also more consistent with the environment variables + # above, where we also use plugins, plural. + + set pd [file join [file home] .[join $prefix /] plugins] + #puts "+? path($pd)" + + if {[file exists $pd]} { + $pmgr path $pd + } + } + return + } +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide punk::pluginmgr 0.5.1 \ No newline at end of file diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 4722eba8..623422a8 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -3063,6 +3063,11 @@ namespace eval repl { return $stack } } + + #autodoc for ensemble, or a punk::args::define doc here + #will not alow discovery of the documentation from within an interp that has + #only alias access to this - as the docs (indeed even the namespace) won't + #exist in the calling interp. namespace eval ::repl::interphelpers::subshell_ensemble { namespace export {[a-z]*} namespace ensemble create @@ -3259,7 +3264,7 @@ namespace eval repl { debug\ punk::ns\ textblock\ - punk::args::tclcore\ + punk::args::moduledoc::tclcore\ punk::aliascore\ ] @@ -3333,8 +3338,8 @@ namespace eval repl { #review code alias ::shellfilter::stack ::shellfilter::stack #code alias ::punk::lib::set_clone ::punk::lib::set_clone - #code alias ::aliases ::punk::lib::aliases - code alias ::punk::lib::aliases ::punk::lib::aliases + #code alias ::aliases ::punk::ns::aliases + code alias ::punk::ns::aliases ::punk::ns::aliases namespace eval ::codeinterp {} code alias ::md5::md5 ::repl::interphelpers::md5 @@ -3443,7 +3448,7 @@ namespace eval repl { interp eval code { package require punk::lib package require punk::args - catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical + catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical package require textblock } @@ -3614,7 +3619,7 @@ namespace eval repl { }} [punk::config::configure running] package require textblock - catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical + catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical } errM]} { puts stderr "========================" puts stderr "code interp error:" @@ -3632,6 +3637,16 @@ namespace eval repl { } } code alias repl ::repl::interphelpers::repl_ensemble + code eval { + punk::args::define { + @id -id ::subshell + @cmd -name ::subshell\ + -summary "Launch in-process subshell"\ + -help "Launch a thread-based subshell" + shellname -type string -optional 0 -choices {punk punksafe safe safebase} + } + + } code alias subshell ::repl::interphelpers::subshell_ensemble code alias quit ::repl::interphelpers::quit code alias editbuf ::repl::interphelpers::editbuf diff --git a/src/modules/punk/ubl-999999.0a1.0.tm b/src/modules/punk/ubl-999999.0a1.0.tm index 685251fa..6acad4f0 100644 --- a/src/modules/punk/ubl-999999.0a1.0.tm +++ b/src/modules/punk/ubl-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::ubl 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::ubl 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/winshell-999999.0a1.0.tm b/src/modules/punk/winshell-999999.0a1.0.tm index 5131ba57..4b3ea3f9 100644 --- a/src/modules/punk/winshell-999999.0a1.0.tm +++ b/src/modules/punk/winshell-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::winshell 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::winshell 0 999999.0a1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/termscheme-999999.0a1.0.tm b/src/modules/termscheme-999999.0a1.0.tm index 4c623d9c..e5174f99 100644 --- a/src/modules/termscheme-999999.0a1.0.tm +++ b/src/modules/termscheme-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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,10 +18,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_termscheme 0 999999.0a1.0] +#[manpage_begin punkshell_module_termscheme 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require termscheme] #[keywords module] #[description] @@ -61,38 +61,6 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval termscheme::class { - #*** !doctools - #[subsection {Namespace termscheme::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 ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -103,7 +71,7 @@ tcl::namespace::eval termscheme { #*** !doctools #[subsection {Namespace termscheme}] - #[para] Core API functions for termscheme + #[para] Core API functions for termscheme #[list_begin definitions] @@ -111,13 +79,13 @@ tcl::namespace::eval termscheme { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -137,14 +105,14 @@ tcl::namespace::eval termscheme::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace termscheme::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -160,19 +128,20 @@ tcl::namespace::eval termscheme::lib { #*** !doctools #[section Internal] #tcl::namespace::eval termscheme::system { + #*** !doctools #[subsection {Namespace termscheme::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide termscheme [tcl::namespace::eval termscheme { variable pkg termscheme variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/alias.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/alias.test new file mode 100644 index 00000000..b7ee2cbd --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/alias.test @@ -0,0 +1,40 @@ +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test documented_alias {Test docs from documented alias take preference}\ + -setup $common -body { + proc underlying {args} {return underlying-$args} + interp alias "" ::testspace::doit "" ::testspace::underlying curriedarg1 + #punk::ns::cmdhelp = 'i doit' + set helpoutput [punk::ns::cmdhelp -return string doit] + lappend result [string match "*::testspace::underlying*" $helpoutput] + set synoutput [punk::ns::synopsis doit] + #check we see the curried argument in the synopsis + lappend result [string match "*curriedarg1*" $synoutput] + + #define an overiding doc on the alias + punk::args::define {@id -id ::testspace::doit} {@cmd -help "doit help"} @values {extra -multiple 1 -type any} + set helpoutput [punk::ns::cmdhelp -return string doit] + lappend result [string match "*doit help*" $helpoutput] + set synoutput [punk::ns::synopsis doit] + puts stderr ------------------- + puts stderr $synoutput + puts stderr ------------------- + lappend result [string match "*extra*" $synoutput] + + }\ + -cleanup { + interp alias "" ::testspace::doit "" + punk::args::undefine ::testspace::doit + }\ + -result [list\ + 1 1 1 1\ + ] + +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test index cfe00d9b..4a4ff768 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test @@ -11,10 +11,12 @@ namespace eval ::testspace { test parse_withdef_leaders_ordering_defaults {Test ordering of leaders when some have defaults}\ -setup $common -body { set argd [punk::args::parse {a b} withdef @leaders x {y -default 1}] + set docid [dict get $argd id] set vals [dict get $argd leaders] set result $vals }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ x a y b @@ -24,10 +26,12 @@ namespace eval ::testspace { -setup $common -body { #for consistency with leaders and values dicts - try to maintain definition order for options too set argd [punk::args::parse {-x a -y b} withdef @opts -x {-y -default 1}] + set docid [dict get $argd id] set vals [dict get $argd opts] set result $vals }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ -x a -y b @@ -37,10 +41,12 @@ namespace eval ::testspace { -setup $common -body { #for consistency with leaders and values dicts - try to maintain definition order for options too set argd [punk::args::parse {-blah etc -x a -y b -solo -z c} withdef {@opts -any 1} -x {-y -default 1} {-solo -type none} -z] + set docid [dict get $argd id] set vals [dict get $argd opts] set result $vals }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ -x a -y b -solo 1 -z c -blah etc @@ -49,10 +55,12 @@ namespace eval ::testspace { test parse_withdef_values_ordering_defaults {Test ordering of values when some have defaults}\ -setup $common -body { set argd [punk::args::parse {a b} withdef @values x {y -default 1}] + set docid [dict get $argd id] set vals [dict get $argd values] set result $vals }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ x a y b @@ -63,10 +71,12 @@ namespace eval ::testspace { #y was not received, and has no default, so should not appear in 'values' element #we don't want to see {x a y {} z b} set argd [punk::args::parse {a b} withdef @values x {y -optional 1} z] + set docid [dict get $argd id] set vals [dict get $argd values] set result $vals }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ x a z b @@ -74,10 +84,12 @@ namespace eval ::testspace { test parse_withdef_value_multiple1 {Test named value with -multiple true and required trailing value}\ -setup $common -body { set argd [punk::args::parse {a b c} withdef @values {arg -type string -multiple 1} endval] + set docid [dict get $argd id] lappend result [dict get $argd leaders] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {} {arg {a b} endval c} @@ -86,10 +98,12 @@ namespace eval ::testspace { test parse_withdef_value_multiple2 {Test named value followed by named value with -multiple true and a default}\ -setup $common -body { set argd [punk::args::parse {a b c} withdef @values A {arg -type string -multiple 1 -default X}] + set docid [dict get $argd id] lappend result [dict get $argd leaders] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {} {A a arg {b c}} @@ -98,10 +112,12 @@ namespace eval ::testspace { test parse_withdef_leader_multiple1 {Test named leader with -multiple true and 1 value required}\ -setup $common -body { set argd [punk::args::parse {a b c} withdef {@leaders -min 0} {L -multiple 1} {@values -min 1 -max 1} V] + set docid [dict get $argd id] lappend result [dict get $argd leaders] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {L {a b}} {V c} @@ -110,10 +126,12 @@ namespace eval ::testspace { test parse_withdef_leader_min_max1 {Test unnamed leaders with @leaders -min and -max}\ -setup $common -body { set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 3 -unnamed true} {@values -unnamed true} ] + set docid [dict get $argd id] lappend result [dict get $argd leaders] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {0 a 1 b 2 c} {3 d} @@ -122,10 +140,12 @@ namespace eval ::testspace { -setup $common -body { #should not error - should allocate d to values set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 4 -unnamed true} {@values -min 1 -max 1 -unnamed true}] + set docid [dict get $argd id] lappend result [dict get $argd leaders] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {0 a 1 b 2 c} {3 d} @@ -133,14 +153,21 @@ namespace eval ::testspace { test parse_withdef_leaderclause_trailing_optional_members_followed_by_value {Test that last leader clause with optional members works with following required value}\ -setup $common -body { - set argd [punk::args::parse {a z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + set docids [list] + set argd [punk::args::parse {a z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] - set argd [punk::args::parse {a 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + set argd [punk::args::parse {a 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] - set argd [punk::args::parse {a 1 2 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + set argd [punk::args::parse {a 1 2 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {ldr {a {} {}}}\ @@ -149,19 +176,27 @@ namespace eval ::testspace { ] test parse_withdef_leaderclause_trailing_optional_members_followed_by_optional_leader_and_value {Test that last leader clause with optional members works with following required value}\ -setup $common -body { - set argd [punk::args::parse {x y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + set docids [list] + set argd [punk::args::parse {x y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] - set argd [punk::args::parse {x 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + set argd [punk::args::parse {x 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] - set argd [punk::args::parse {x 1 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + set argd [punk::args::parse {x 1 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] set argd [punk::args::parse {x 1 2 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {ldr {x {} {}} ldr2 y}\ @@ -173,9 +208,11 @@ namespace eval ::testspace { test parse_withdef_value_clause_typedefaults {test clause with optional element and -typedefaults specified}\ -setup $common -body { set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" 12}}] + set docid [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {v {1 12}} @@ -184,9 +221,11 @@ namespace eval ::testspace { -setup $common -body { #-default has deliberate type violations - should still produce result as default is not meant to be subject to validation. set argd [punk::args::parse {} withdef @values {v -type {int ?int?} -typedefaults {"" 12} -default {x y} -optional 1}] + set docid [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {v {x y}} @@ -197,9 +236,11 @@ namespace eval ::testspace { #-typedefaults has deliberate type violations - should still produce result as defaulted value is not meant to be subject to validation. #(uses the ?defaulted-? typelist mechanism) set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" xxx}}] + set docid [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {v {1 xxx}} @@ -210,9 +251,11 @@ namespace eval ::testspace { #This empty string needs to be in the result, but not be subject to validation #(uses the ?ommitted-? typelist mechanism) set argd [punk::args::parse {1} withdef @values {v -type {int ?int?}}] + set docid [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {v {1 {}}} @@ -222,9 +265,11 @@ namespace eval ::testspace { -setup $common -body { #default for missing optional member ?literal(then)? should be empty string set argd [punk::args::parse {elseif 1 x} withdef {@values} {"elseifclause" -type {literal(elseif) expr ?literal(then)? any}}] + set docid [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + punk::args::undefine $docid 1 }\ -result [list\ {elseifclause {elseif 1 {} x}} @@ -236,26 +281,35 @@ namespace eval ::testspace { #e.g literal(elseif) expr ?literal(then)? script #the 'then' needs to be omitable arbitrarily in a list of elseif clauses + set docids [list] + #first test with all values supplied set argd [punk::args::parse {x 1 y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] #missing value in second instance only set argd [punk::args::parse {x 1 y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] #missing value in first instance only #this can trigger a problem whereby the missing value in the first instance (which is empty string) gets processed in validation against 'int' and fails. #(updating of required type to a validationless value such as ... ?omitted-int? ... needs to be tied to specific clause instances) set argd [punk::args::parse {x y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] #for completeness - no optional values supplid set argd [punk::args::parse {x y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {triple {{x 1 y} {x 2 y}}}\ @@ -266,10 +320,15 @@ namespace eval ::testspace { test parse_withdef_value_clause_arity2 {Test value clause result with missing optional member in optional clauses at tail}\ -setup $common -body { + set docids [list] set argd [punk::args::parse {1 2 x 1 y} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {arg {1 2} X {x 1} Y {y {}}} @@ -277,10 +336,15 @@ namespace eval ::testspace { test parse_withdef_value_clause_arity3 {Test value clause result with filled optional member in optional clauses at tail}\ -setup $common -body { + set docids [list] set argd [punk::args::parse {1 2 x 1 y 2} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {arg {1 2} X {x 1} Y {y 2}} @@ -298,11 +362,16 @@ namespace eval ::testspace { test parse_withdef_leader_clause {Test leader clause with multiple}\ -setup $common -body { + set docids [list] #see for example ::tcl::dict::create which has a clause length of 2 set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@leaders} {"key val etc" -type {any any any} -multiple 0} {"key val" -type {any any} -multiple 1} {@values -min 0 -max 0}] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}} @@ -310,11 +379,16 @@ namespace eval ::testspace { test parse_withdef_value_clause_multiple {Test value clause with multiple}\ -setup $common -body { + set docids [list] #see for example ::tcl::dict::create which has a clause length of 2 set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@values} {"key val etc" -type {any any any} -multiple 0} {"key val" -type {any any} -multiple 1}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}} @@ -322,6 +396,7 @@ namespace eval ::testspace { test parse_withdef_value_clause_error {Test value clause with error due to not enough args for clause}\ -setup $common -body { + set docids [list] #see for example ::tcl::dict::create which has a clause length of 2 if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -type {any any any} -multiple 0}} emsg eopts]} { set expected [dict get $eopts -errorcode] @@ -330,11 +405,19 @@ namespace eval ::testspace { } else { lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {missingrequiredvalue ...} ..." } + #REVIEW - when an error is raised in parsing the arguments, but this is the 1st time we used this def, an autoid is still generated - but + #we don't have the id available (unless we scraped the error msg) in order to delete it. + #perhaps no big deal ? + #we could provide facility in punk::args to undefine via the deflist. } else { + lappend docids [dict get $emsg id] lappend result "MISSING_REQUIRED_ERROR" } }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ "RECEIVED_EXPECTED_ERROR" @@ -343,11 +426,16 @@ namespace eval ::testspace { test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}\ -setup $common -body { + set docids [list] #It must always be possible to override earlier (non -multiple) options set argd [punk::args::parse {-incr -decr -incr} withdef {@opts -type none -parsekey -direction} {-incr -typedefaults u} {-decr -typedefaults u}] + lappend docids [dict get $argd id] lappend result [dict get $argd opts] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {-direction u} @@ -355,10 +443,15 @@ namespace eval ::testspace { test parse_withdef_leader_literalprefix_fullvalue {leaders - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\ -setup $common -body { + set docids [list] set argd [punk::args::parse {t} withdef @leaders {A -type literalprefix(test)}] + lappend docids [dict get $argd id] lappend result [dict get $argd leaders] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {A test} @@ -366,10 +459,15 @@ namespace eval ::testspace { test parse_withdef_value_literalprefix_fullvalue {values - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\ -setup $common -body { + set docids [list] set argd [punk::args::parse {t} withdef @values {A -type literalprefix(test)}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {A test} @@ -377,12 +475,18 @@ namespace eval ::testspace { test parse_withdef_value_literal_alternates_case {values - ensure literal alternates work and preserve case}\ -setup $common -body { + set docids [list] set argd [punk::args::parse {abc} withdef @values {A -type literal(abc)|literal(DeF)}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] set argd [punk::args::parse {DeF} withdef @values {A -type literal(abc)|literal(DeF)}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {A abc} {A DeF} @@ -390,12 +494,18 @@ namespace eval ::testspace { test parse_withdef_value_literalprefix_literal_combo {values - ensure literal/literalprefix prefix calculation works}\ -setup $common -body { - set argd [punk::args::parse {test} withdef @values {A -type literalprefix(testinfo)|literal(test)}] + set docids [list] + set argd [punk::args::parse {test} withdef @values {A -type literalprefix(testinfo)|literal(test)}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] - set argd [punk::args::parse {testin} withdef @values {A -type literalprefix(testinfo)|literal(test)}] + set argd [punk::args::parse {testin} withdef @values {A -type literalprefix(testinfo)|literal(test)}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {A test} {A testinfo} @@ -403,10 +513,13 @@ namespace eval ::testspace { test parse_withdef_value_alternatetypes {values - ensure alternate types (in simple-syntax) pass validation}\ -setup $common -body { + set docids [list] #both should pass validation set argd [punk::args::parse {a} withdef @values {A -type int|char}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] set argd [punk::args::parse {11} withdef @values {A -type char|int}] + lappend docids [dict get $argd id] lappend result [dict get $argd values] #todo RPN? @@ -414,11 +527,33 @@ namespace eval ::testspace { #set argd [punk::args::parse {11} withdef @values {A -type {char int stringstartswith | OR}}] }\ -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } }\ -result [list\ {A a} {A 11} ] + test parse_same_autoid {Test that repeat use of same def uses same autoid}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {a b c} withdef @values {arg -type string -multiple 1} endval] + lappend docids [dict get $argd id] + set argd [punk::args::parse {x y z} withdef @values {arg -type string -multiple 1} endval] + lappend docids [dict get $argd id] + lappend result [string equal [lindex $docids 0] [lindex $docids 1]] + }\ + -cleanup { + puts stderr "Expect output on stderr about punk::args::undefine unable to find id" + #second undefine warning is expected + foreach id $docids { + punk::args::undefine $id 0 ;#0 to ensure non-quiet -(msg on stderr) + } + }\ + -result [list\ + 1 + ] } \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test index 1ae2c5c6..e67cf14e 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test @@ -25,6 +25,7 @@ namespace eval ::testspace { }\ -cleanup { namespace delete ::testspace::whatever + punk::args::undefine ::testspace::test1 }\ -result [list\ +++XXX---YYY @@ -51,6 +52,7 @@ namespace eval ::testspace { }\ -cleanup { namespace delete ::testspace::whatever + punk::args::undefine ::testspace::test2 }\ -result [list\ +++XXX---YYY @@ -118,6 +120,7 @@ namespace eval ::testspace { }\ -cleanup { namespace delete ::testspace::whatever + punk::args::undefine ::testspace::test2 }\ -result [list\ +++XXX---YYY {A B C} +++XXX---YYY {X Y Z} OK_define_time_var_match OK_resolve_time_2_greater diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/alias.test#..+args+alias.test.fauxlink b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/alias.test#..+args+alias.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/choices.test#..+args+choices.test.fauxlink b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/choices.test#..+args+choices.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/ns/basic.test b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/ns/basic.test new file mode 100644 index 00000000..d63238f8 --- /dev/null +++ b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/ns/basic.test @@ -0,0 +1,45 @@ +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + test nsprefix {Test the basic cases of nsprefix that are different to 'namespace qualifiers'}\ + -setup $common -body { + lappend result [punk::ns::nsprefix ::tcl] ;# :: + lappend result [punk::ns::nsprefix ::::tcl] ;# parts {} tcl - the prefix is :: (because Tcl disallows further empty ns name after root - so we collapse it to ::) + + #the rightmost colon is *only sometimes* associated with the word tcl to be an *unwisely* named child namespace of ":tcl" + #(specifically when the number of colons is divisble by 3) + #see nsparts to understand the splitting mechanism. (colons processed 2 at a time from left, no empty ns aside from root allowed, no trailing colons in ns - except that single colon ns allowed) + + #Colons as part of an ns generally shouldn't exist - but punk::ns, punk::nav::ns are intended to be able to deal with oddly named namespaces as much as possible + #This still leaves ambiguities and impossibilities with another unwise namespace name - with trailing colon - such as "tcl:" + #A pathological case would be a tree of namespaces with mixed leading and trailing colons in each namespace name. + lappend result [punk::ns::nsprefix :::tcl] ; # parts {} :tcl - the prefix is :: + + lappend result [punk::ns::nsprefix ::tcl::x] + + lappend result [punk::ns::nsprefix :::tcl::x] + lappend result [punk::ns::nsprefix ::::tcl::x] + + lappend result [punk::ns::nsprefix :::::tcl::x] ;# parts {} : tcl x - the prefix is :::::tcl + + lappend result [punk::ns::nsprefix :::::tcl] ;# parts {} : tcl - the prefix is ::: - such that joining the prefix ::: to suffix x with 2 colons gives :::::tcl + + #this is somewhat counterintuitive + lappend result [punk::ns::nsprefix ::::::tcl] ;#parts {} : :tcl - the prefix is ::: + lappend result [punk::ns::nsprefix ::::::tcl::x] ;#parts {} : :tcl x - the prefix is ::::::tcl + + }\ + -cleanup { + }\ + -result [list\ + :: :: :: ::tcl :::tcl ::tcl :::::tcl ::: ::: ::::::tcl + ] + + + +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/ns/corp.test b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/ns/corp.test new file mode 100644 index 00000000..90e7c445 --- /dev/null +++ b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/ns/corp.test @@ -0,0 +1,90 @@ +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + test corp_basic {Test that punk::ns::corp can retrieve body of function}\ + -setup $common -body { + #namespace current is ::testspace + #ordinary function name + proc spud {} {return spud-token} + set body [punk::ns::corp -syntax none spud] + lappend result [string match "proc*spud-token*" $body] + + }\ + -cleanup { + rename spud "" + }\ + -result [list\ + 1 + ] + + test corp_defaultvar {Test that punk::ns::corp retrieves a defaultvar value}\ + -setup $common -body { + #namespace current is ::testspace + #function with a default variable - corp should see it + proc spud2 {{v1 v1-token}} {return spud2-token} + set body [punk::ns::corp -syntax none spud2] + lappend result [string match "proc*spud2-token*" $body] + lappend result [string match "proc*v1 v1-token*" $body] + + }\ + -cleanup { + rename spud2 "" + }\ + -result [list\ + 1 1 + ] + + + test corp_empty_functionname {Test that punk::ns::corp can retrieve body of function named as empty string}\ + -setup $common -body { + #namespace current is ::testspace + + proc "" {} {return emptyname-token} + set body [punk::ns::corp -syntax none ""] + lappend result [string match "proc*emptyname-token*" $body] + + }\ + -cleanup { + rename "" "" + }\ + -result [list\ + 1 + ] + + test corp_trailingcolon_functionname {Test that punk::ns::corp can retrieve body of perhaps unwisely named function ending with a colon}\ + -setup $common -body { + #namespace current is ::testspace + + proc x: {} {return xcolon-token} + set body [punk::ns::corp -syntax none x:] + lappend result [string match "proc*xcolon-token*" $body] + + }\ + -cleanup { + rename x: "" + }\ + -result [list\ + 1 + ] + + test corp_leadingcolon_functionname {Test that punk::ns::corp can retrieve body of perhaps unwisely named function starting with a colon}\ + -setup $common -body { + #namespace current is ::testspace + + proc :x {} {return colonx-token} + set body [punk::ns::corp -syntax none :x] + lappend result [string match "proc*colonx-token*" $body] + + }\ + -cleanup { + rename :x "" + }\ + -result [list\ + 1 + ] +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/tests/basic.test#..+ns+basic.test.fauxlink b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/tests/basic.test#..+ns+basic.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/tests/corp.test#..+ns+corp.test.fauxlink b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-0.1.0_testsuites/tests/corp.test#..+ns+corp.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm new file mode 100644 index 00000000..feca648e --- /dev/null +++ b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm @@ -0,0 +1,150 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application test::punk::ns 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval test::punk::ns { + variable PUNKARGS + + variable version + set version 999999.0a1.0 + + package require packageTest + packageTest::makeAPI test::punk::ns $version punk::ns; #will package provide test::punk::ns $version + + package forget punk::ns + package require punk::ns +} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval test::punk::ns { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)test::punk::ns" + @package -name "test::punk::ns" -help\ + "Test suites for punk::ns" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return test::punk::ns + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package test::punk::ns + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::test::punk::ns::version" + } + proc get_topic_Contributors {} { + set authors {"Julian Noble "} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::test::punk::ns::about" + dict set overrides @cmd -name "test::punk::ns::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + Test suites for punk::ns + }] \n] + dict set overrides topic -choices [list {*}[test::punk::ns::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [test::punk::ns::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::test::punk::ns::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::test::punk::ns::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::test::punk::ns +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide test::punk::ns [tcl::namespace::eval test::punk::ns { + variable pkg test::punk::ns + variable version + set version 999999.0a1.0 +}] +return + diff --git a/src/modules/test/punk/ns-buildversion.txt b/src/modules/test/punk/ns-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/test/punk/ns-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 30f7d92c..36f9219c 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -58,7 +58,6 @@ package require punk::args package require punk::char package require punk::ansi package require punk::lib -catch {package require patternpunk} package require overtype package require struct::set diff --git a/src/vendormodules/include_modules.config b/src/vendormodules/include_modules.config index 07acb288..f9303a39 100644 --- a/src/vendormodules/include_modules.config +++ b/src/vendormodules/include_modules.config @@ -15,7 +15,12 @@ set local_modules [list\ c:/repo/jn/tclmodules/dictn/modules dictn\ c:/repo/jn/tclmodules/dollarcent/modules dollarcent\ c:/repo/jn/tclmodules/pattern/modules pattern\ + c:/repo/jn/tclmodules/pattern/modules patterncmd\ + c:/repo/jn/tclmodules/pattern/modules patternlib\ + c:/repo/jn/tclmodules/pattern/modules patterncipher\ c:/repo/jn/tclmodules/pattern/modules metaface\ + c:/repo/jn/tclmodules/pattern/modules patternpredator2\ + c:/repo/jn/tarjar/modules tarjar\ ] set fossil_modules [dict create\ diff --git a/src/vendormodules/metaface-1.2.8.tm b/src/vendormodules/metaface-1.2.8.tm index 39a54c8c..c216b1df 100644 --- a/src/vendormodules/metaface-1.2.8.tm +++ b/src/vendormodules/metaface-1.2.8.tm @@ -1,44 +1,44 @@ package require dictutils package provide metaface [namespace eval metaface { variable version - set version 1.2.8 + set version 1.2.8 }] # 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+ -# 2023-07 - add .. MetaMethods +# 2023-07 - add .. MetaMethods #example datastructure: #$_ID_ #{ -#i -# { -# this -# { -# {16 ::p::16 item ::>x {}} -# } -# role2 -# { -# {17 ::p::17 item ::>y {}} -# {18 ::p::18 item ::>z {}} -# } -# } +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } #context {} #} #$MAP -#invocantdata {16 ::p::16 item ::>x {}} -#interfaces {level0 -# { -# api0 {stack {123 999}} -# api1 {stack {333}} -# } -# level0_default api0 -# level1 -# { -# } -# level1_default {} -# } +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } #patterndata {patterndefaultmethod {}} @@ -105,7 +105,7 @@ proc ::p::predator::getprop_template_immediate {_ID_ args} { set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] if {$rType eq "object"} { #return [$val . item {*}$args] - #don't assume defaultmethod named 'item'! + #don't assume defaultmethod named 'item'! return [$val {*}$args] } else { #treat as list? @@ -127,60 +127,60 @@ proc ::p::predator::getprop_template_immediate {_ID_ args} { proc ::p::predator::getprop_array {_ID_ prop args} { set OID [lindex [dict get $_ID_ i this] 0 0] - #upvar 0 ::p::${OID}::o_${prop} prop - #1st try: assume array - if {[catch {array get ::p::${OID}::o_${prop}} result]} { - #treat as list (why?) - #!review - if {[info exists ::p::${OID}::o_${prop}]} { - array set temp [::list] - set i 0 - foreach element ::p::${OID}::o_${prop} { - set temp($i) $element - incr i - } - set result [array get temp] - } else { - error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" - } - } - return $result + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result } proc ::p::predator::setprop_template {prop _ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args] == 1} { - #return [set ::p::${OID}::o_%prop% [lindex $args 0]] - return [set ${ns}::o_%prop% [lindex $args 0]] - - } else { - if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { - #treat attempt to perform indexed write to nonexistant var, same as indexed write to array - - #2 args - single index followed by a value - if {[llength $args] == 2} { - return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] - } else { - #multiple indices - #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] - return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] - } - } else { - #treat as list - return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] - } - } + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } } #-------------------------------------- @@ -189,7 +189,7 @@ proc ::p::predator::setprop_template {prop _ID_ args} { proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { - + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. @@ -210,7 +210,7 @@ proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtrace set $refname $newval } } - return + return } } @@ -218,80 +218,80 @@ proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtrace proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { - #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" - - - #derive the name of the write command from the ref var. - set indices [lassign [split [namespace tail $refname] +] prop] - - - #assert - we will never have both a list in indices and an idx value - if {[llength $indices] && ($idx ne "")} { - #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x - #review - are there any datastructures which would/should allow this? - #this assertion is really just here as a sanity check for now - error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" - } - - #upvar #0 ::p::${OID}::_meta::map MAP - #puts "-->propref_trace_write map: $MAP" - - #temporarily deactivate refsync trace - #puts stderr -->1>--removing_trace_o_${field} -### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - #we need to catch, and re-raise any error that we may receive when writing the property - # because we have to reinstate the propvar_write_TraceHandler after the call. - #(e.g there may be a propertywrite handler that deliberately raises an error) - - set excludesync_refs $refname - set cmd ::p::${OID}::(SET)$prop - - - set f_error 0 - if {[catch { - - if {![llength $indices]} { - if {[string length $idx]} { - $cmd $_ID_ $idx [set ${refname}($idx)] - #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] - - } else { - $cmd $_ID_ [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] - } - } else { - #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" - $cmd $_ID_ {*}$indices [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices - } - - } result]} { - set f_error 1 - } - - - - - #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write - #reactivate refsync trace - #puts stderr "****** reactivating refsync trace on o_$field" - #puts stderr -->2>--reactivating_trace_o_${field} + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - if {$f_error} { - #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. - # ? return -code error $errMsg ? -errorinfo + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo - #!quick n dirty - #error $errorMsg - return -code error -errorinfo $::errorInfo $result - } else { - return $result - } + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } } @@ -301,7 +301,7 @@ proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname id proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') - + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set #set updated_value [::p::predator::getprop_array $prop $_ID_] @@ -311,7 +311,7 @@ proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { array set $refname {} } - #return value ignored for + #return value ignored for } @@ -319,7 +319,7 @@ proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { # proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd + lassign [dict get $MAP invocantdata] OID alias itemCmd #don't rely on variable name passed by trace - may have been 'upvar'ed @@ -334,7 +334,7 @@ proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { #!todo - get propertylist from cache on object(?) foreach IFID [lreverse $iflist] { dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { - #lassign $pdef v + #lassign $pdef v if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { if {[array exists ::p::${OID}::o_${prop}]} { lappend plist $prop [array get ::p::${OID}::o_${prop}] @@ -346,419 +346,395 @@ proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { } } } - array set $refvar $plist + array set $refvar $plist } proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" - - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - if {[string length $IID]} { - #property - if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { - puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" - } - } else { - #method - error "property '$idx' not found" - } -} + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd - lassign [dict get $MAP invocantdata] OID alias itemCmd - - #!todo - ??? - - if {![llength [info commands ::p::${OID}::$idx]]} { - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set found 0 - foreach id [lreverse $iflist] { + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { set found 1 break } - } - - if {$found} { - unset ::p::${OID}::o_$idx - } else { - puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" - } - } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } } proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" - - - if {![llength [info commands ::p::${OID}::$idx]]} { - #!todo - create new property in interface upon attempt to write to non-existant? - # - or should we require some different kind of object-reference for that? - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { set IID $id break } - } + } - #$IID is now topmost interface in default iStack which has this property + #$IID is now topmost interface in default iStack which has this property - if {[string length $IID]} { - #write to defined property + if {[string length $IID]} { + #write to defined property - ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] - } else { - #!todo - allow write of method body back to underlying object? - #attempted write to 'method' ..undo(?) - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "cannot write to method '$idx'" - #for now - disallow - } - } + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } } proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { - #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - - set refindices [lassign [split [namespace tail $refname] +] prop] - #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop - #if there is no PropertyUnset command - we unset the underlying variable directly - - trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - - if {[catch { - - #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value - #i.e - if {[llength $refindices] && [string length $idx]} { - puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" - error "unexpected call to propref_trace_unset" - } - - - upvar #0 ::p::${OID}::_meta::map MAP - - set iflist [dict get $MAP interfaces level0] - #find topmost interface containing this $prop - set IID "" - foreach id [lreverse $iflist] { - if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - if {![string length $IID]} { - error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" - } - - - - - - - if {[string length $idx]} { - #eval "$_alias ${unset_}$field $idx" - #what happens to $refindices??? - - - #!todo varspace - - if {![llength $refindices]} { - #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop}($idx) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx - } - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx - } else { - #assert - won't get here - error 1a - - } - - } else { - if {[llength $refindices]} { - #error 2a - #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - #review - what about list-type property? - #if {[array exists ::p::${OID}::o_${prop}]} ??? - unset ::p::${OID}::o_${prop}($refindices) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices - } - - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices - - - } else { - #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - #ref is not of form prop+x etc and no idx in the trace - this is a plain unset - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop} - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" - } - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} - - } - } - - - - - } errM]} { - #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" - set ruler [string repeat - 80] - puts stderr "\t$ruler" - puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - puts stderr "\t$ruler" - puts stderr $errM - puts stderr "\t$ruler" - - } else { - #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - #puts stderr "*@*@*@*@ end propref_trace_unset - no error" - } - - trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + } proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + if {[array exists SYNCVARIABLE]} { + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - if {[string length $triggeringRef]} { - set idx [lsearch -exact $refvars $triggeringRef] - if {$idx >= 0} { - set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] - } - } - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" - return - } - - - #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset - # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" - if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { - #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" - puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" - } - - - puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " - - - - upvar $vtraced SYNCVARIABLE - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - - #set triggeringRefIdx $vidx - - if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { - set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] - } else { - set triggering_indices [list] - } - - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #check indices of triggering refvar match this refvars indices - - - if {$reftail eq [namespace tail $triggeringRef]} { - #!todo - add test - error "untested, possibly unused branch spuds2" - #puts "222222222222222222" - unset $refvar - } else { - - #error "untested - branch spuds2a" - - - } - - } else { - #!todo -add test - #reference is directly to property var - error "untested, possibly unused branch spuds3" - #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? - puts "\t33333333333333333333" - - if {[string length $triggeringRefIdx]} { - unset $refvar($triggeringRefIdx) - } - } - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - @@ -768,676 +744,653 @@ proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtrace proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { - upvar $vtraced SYNCVARIABLE - - set refvars [::list] - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - #short_circuit breaks unset traces for array elements (why?) - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - return - } else { - puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - } - - if {[catch { - - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - set triggeringRefIdx $vidx - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - unset $refvar - - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - } errM]} { - set ruler [string repeat * 80] - puts stderr "\t$ruler" - puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" - puts stderr "\t$ruler" - puts stderr $::errorInfo - puts stderr "\t$ruler" - - } - + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + } proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { - error hmmmmm - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " - set refvars [::list] - - #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - #assert triggeringRef is in the list - if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { - error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" - } - set refposn [lsearch -exact $refvars $triggeringRef] - #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 - set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" - return [list refs_updates [list]] - } - - #suppress the propref_trace_* traces on all refvars - array set traces [::list] - array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." - #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync - #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? - #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #all other traces are 'external' - lappend external_traces($rv) $tinfo - #trace remove variable $rv $ops $cmd - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - if {![info exists SYNCVARIABLE]} { - error "WARNING: REVIEW why does $vartraced not exist here?" - } - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set treat_vtraced_as_array 1 - } else { - set treat_vtraced_as_array 0 - } - - set refs_updated [list] - set refs_deleted [list] ;#unset due to index no longer being relevant - if {$treat_vtraced_as_array} { - foreach refvar $refvars { - #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - if {[llength $indices]} { - if {[llength $indices] == 1} { - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - #error "untested xxx-a" - set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] - lappend refs_updated $refvar - } else { - #test exists - #error "xxx-ok single index" - #updating a different part of the property - nothing to do - } - } else { - #nested index - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - if {[llength $ref_indices] == 1} { - #error "untested xxx-b1" - set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] - } else { - #assert llength $ref_indices > 1 - #NOTE - we cannot test index equivalence reliably/simply just by comparing indices - #compare by value - - if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { - #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" - if {[set $refvar] ne $possiblyNewVal} { - set $refvar $possiblyNewVal - } - } else { - #fail to retrieve underlying value corrsponding to these $indices - unset $refvar - } - } - } else { - #test exists - #error "untested xxx-ok deepindex" - #updating a different part of the property - nothing to do - } - } - } else { - error "untested xxx-c" - - } - - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - if {[llength $indices] == 1} { - set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] - } else { - lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] - } - lappend refs_updated $refvar - } else { - error "untested yyy" - set $refvar $SYNCVARIABLE - } - } - } - } else { - #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) - # - foreach refvar $refvars { - #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - - if {[llength $indices]} { - #see if this update would affect this curried ref - #1st see if we can short-circuit our comparison based on numeric-indices - if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { - #both sets of indices are purely numeric (no end end-1 etc) - set rlen [llength $ref_indices] - set ilen [llength $indices] - set minlen [expr {min($rlen,$ilen)}] - set matched_firstfew_indices 1 ;#assume the best - for {set i 0} {$i < $minlen} {incr i} { - if {[lindex $ref_indices $i] ne [lindex $indices $i]} { - break ;# - } - } - if {!$matched_firstfew_indices} { - #update of this refvar not required - #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" - break ;#break to next refvar in the foreach loop - } - } - #failed to short-circuit - - #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set $refvar] ne $newval} { - set $refvar $newval - lappend refs_updated $refvar - } - - } else { - #we must be updating the entire variable - so this curried ref will either need to be updated or unset - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set ${refvar}] ne $newval} { - set ${refvar} $newval - lappend refs_updated $refvar - } - } - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - #error "untested zzz-a" - set newval [lindex $SYNCVARIABLE $indices] - if {[lindex [set $refvar] $indices] ne $newval} { - lset ${refvar} $indices $newval - lappend refs_updated $refvar - } - } else { - if {[set ${refvar}] ne $SYNCVARIABLE} { - set ${refvar} $SYNCVARIABLE - lappend refs_updated $refvar - } - } - - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - - #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - } - foreach rv [array names external_traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - #trace add variable $rv $ops $cmd - } - } - } - - - return [list updated_refs $refs_updated] + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] } #purpose: update all relevant references when context variable changed directly proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { - #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. - #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler - - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" - set t_info [trace info variable $vtraced] - foreach t_spec $t_info { - set t_ops [lindex $t_spec 0] - if {$op in $t_ops} { - puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + #set t_info [trace info variable $vtraced] + #foreach t_spec $t_info { + # set t_ops [lindex $t_spec 0] + # if {$op in $t_ops} { + # puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + # } + #} + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + } else { + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + } + + } else { + #no vidx + + if {$vtracedIsArray} { + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + } + + } + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd } } - - #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- - #vtype = array | array-item | list | simple - - set refvars [::list] - - ############################ - #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! - #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) - #The alternative 'info vars' does not trigger traces - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - ############################ - - #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" - return - } - - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars - array set predator_traces [::list] - #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. - #ie for something like 'trace add variable someref {write read array} somefunc' - # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace - array set external_read_traces [::list] ;#pure read traces the library user may have added - array set external_readetc_traces [::list] ;#read + something else traces the library user may have added - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - #if {$ops in {read write unset array}} {} - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend predator_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #other traces - # puts "##trace $tinfo" - if {"read" in $ops} { - if {[llength $ops] == 1} { - #pure read - - lappend external_read_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - } else { - #mixed operation trace - remove and reinstall without the 'read' - lappend external_readetc_traces($rv) $tinfo - set other_ops [lsearch -all -inline -not $ops "read"] - trace remove variable $rv $ops $cmd - #reinstall trace for non-read operations only - trace add variable $rv $other_ops $cmd - } - } - } - } - } - - - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set vtracedIsArray 1 - } else { - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" - #puts "**write*********** refvars: $refvars" - - #!todo? unroll foreach into multiple foreaches within ifs? - #foreach refvar $refvars {} - - - #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" - if {[string length $vidx]} { - #indexable - if {$vtracedIsArray} { - - foreach refvar $refvars { - #puts stderr " - - a refvar $refvar vidx: $vidx" - set tail [namespace tail $refvar] - if {[string match "${prop}+*" $tail]} { - #refvar is curried - #only set if vidx matches curried index - #!todo -review - set idx [lrange [split $tail +] 1 end] - if {$idx eq $vidx} { - set newval [set SYNCVARIABLE($vidx)] - if {[set $refvar] ne $newval} { - set ${refvar} $newval - } - #puts stderr "=a.1=> updated $refvar" - } - } else { - #refvar is simple - set newval [set SYNCVARIABLE($vidx)] - if {![info exists ${refvar}($vidx)]} { - #new key for this array - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } else { - set oldval [set ${refvar}($vidx)] - if {$oldval ne $newval} { - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } - } - #puts stderr "=a.2=> updated ${refvar} $vidx" - } - } - - - - } else { - - - foreach refvar $refvars { - upvar $refvar internal_property_reference - #puts stderr " - - b vidx: $vidx" - - #!? could be object not list?? - #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? - #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) - #There would still be an edge case of an initial write of a list of objects of length 1. - if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { - error "untested review!" - #the o_prop is object-shaped - #assumes object has a defaultmethod which accepts indices - set newval [[set $SYNCVARIABLE] {*}$vidx] - - } else { - set newval [lindex $SYNCVARIABLE {*}$vidx] - #if {[set $refvar] ne $newval} { - # set $refvar $newval - #} - if {$internal_property_reference ne $newval} { - set internal_property_reference $newval - } - - } - #puts stderr "=b=> updated $refvar" - } - - - } - - - - } else { - #no vidx - - if {$vtracedIsArray} { - - - foreach refvar $refvars { - set targetref_tail [namespace tail $refvar] - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - - #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" - if {$targetref_is_indexed} { - #curried array item ref of the form ${prop}+x or ${prop}+x+y etc - - #unindexed write on a property that is acting as an array.. - - #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. - - #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). - # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. - puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" - } else { - #How do we know what to write to array ref? - puts stderr "\tc.2 WARNING: unimplemented/unused?" - #error no_tests_for_branch - - #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation - #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate - array unset ${refvar} - array set ${refvar} [array get SYNCVARIABLE] - } - } - - - - } else { - foreach refvar $refvars { - #puts stderr "\t\t_________________[namespace current]" - set targetref_tail [namespace tail $refvar] - upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - if {$targetref_is_indexed} { - #puts "XXXXXXXXX vtraced:$vtraced" - #reference curried with index(es) - #we only set indexed refs if value has changed - # - this not required to be consistent with standard list-containing variable traces, - # as normally list elements can't be traced seperately anyway. - # - - - #only bother checking a ref if no setVia index - # i.e some operation on entire variable so need to test synchronisation for each element-ref - set targetref_indices [lrange [split $targetref_tail +] 1 end] - set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] - #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal - #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" - } - - - } else { - #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! - - #puts stderr "- d2 set" - #puts "refvar: [set $refvar]" - #puts "SYNCVARIABLE: $SYNCVARIABLE" - - #if {[set $refvar] ne $SYNCVARIABLE} { - # set $refvar $SYNCVARIABLE - #} - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE - } - - } - } - - - } - - } - - - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names predator_traces] { - foreach tinfo $predator_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - foreach rv [array names external_traces] { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - - + + + } - + # end propvar_write_TraceHandler @@ -1457,9 +1410,9 @@ proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { # -#returns 0 if method implementation not present for interface +#returns 0 if method implementation not present for interface proc ::p::predator::method_chainhead {iid method} { - #Interface proc + #Interface proc # examine the existing command-chain set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) set cmdchain [list] @@ -1483,7 +1436,7 @@ proc ::p::predator::method_chainhead {iid method} { -#this returns a script that upvars vars for all interfaces on the calling object - +#this returns a script that upvars vars for all interfaces on the calling object - # - must be called at runtime from a method proc ::p::predator::upvar_all {_ID_} { #::set OID [lindex $_ID_ 0 0] @@ -1491,16 +1444,16 @@ proc ::p::predator::upvar_all {_ID_} { ::set decl {} #[set ::p::${OID}::_meta::map] #[dict get [lindex [dict get $_ID_ i this] 0 1] map] - - ::upvar #0 ::p::${OID}::_meta::map MAP - #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" - #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] - ::foreach ifid [dict get $MAP interfaces level0] { + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { ::array unset nsvars ::array set nsvars [::list] - ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { ::set varspace [::dict get $vinfo varspace] ::lappend nsvars($varspace) $vname } @@ -1511,33 +1464,33 @@ proc ::p::predator::upvar_all {_ID_} { ::set ns ::p::${OID} } else { if {[::string match "::*" $varspace]} { - ::set ns $varspace + ::set ns $varspace } else { ::set ns ::p::${OID}::$varspace } } - ::append decl "namespace upvar $ns " + ::append decl "namespace upvar $ns " ::foreach vname [::set nsvars($varspace)] { ::append decl "$vname $vname " } - ::append decl " ;\n" + ::append decl " ;\n" } ::array unset nsvars - } - } - ::return $decl + } + } + ::return $decl } #we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) proc ::p::predator::runtime_vardecls {} { - set result "::eval \[::p::predator::upvar_all \$_ID_\]" - #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" - - #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" - #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" - #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" - return $result + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result } @@ -1547,103 +1500,103 @@ proc ::p::predator::runtime_vardecls {} { #OBSOLETE!(?) - todo - move stuff out of here. proc ::p::predator::compile_interface {IFID caller_ID_} { - upvar 0 ::p::${IFID}:: IFACE - - #namespace eval ::p::${IFID} { - # namespace ensemble create - #} - - #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables - - namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - #set varDecls {} - #if {[llength $o_variables]} { - # #puts "*********!!!! $vlist" + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " - # foreach vdef $o_variables { + # foreach vdef $o_variables { # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " - # } - # append varDecls \n - #} + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} - #runtime gathering of vars from other interfaces. - #append varDecls [runtime_vardecls] - set varDecls [runtime_vardecls] + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - #implement methods - #!todo - avoid globs on iface array? maintain list of methods in another slot? - #foreach {n mname} [array get IFACE m-1,name,*] {} + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] - #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - - - #implement property getters/setters/unsetters - #'setter' overrides - #pw short for propertywrite - foreach {n property} [array get IFACE pw,name,*] { - if {[string length $property]} { - #set property [lindex [split $n ,] end] - - #!todo - next_script - #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 - set maxversion [::p::predator::method_chainhead $IFID (SET)$property] - set chainhead [expr {$maxversion + 1}] - set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - - set body $IFACE(pw,body,$property) - + set body $IFACE(pw,body,$property) - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" - } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - set maxversion [::p::predator::method_chainhead $IFID $property] - set headid [expr {$maxversion + 1}] + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides - proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + dict for {property handler_info} $o_propertyunset_handlers { - interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - - #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body - } - } - #'unset' overrides + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array - dict for {property handler_info} $o_propertyunset_handlers { - - set body [dict get $handler_info body] - set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] - set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? @@ -1660,31 +1613,31 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { } else { set body $varDecls\n[dict get $processed body] #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" - + } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #implement - #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern "_dontcare_" - } - proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body - - - #chainhead pointer - interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid - } + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } - - interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) - - #the usual case will have no destructor - so use info exists to check. + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { #!todo - chained destructors (support @next@). @@ -1694,7 +1647,7 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { set body [set ::p::${IFID}::_iface::o_destructor_body] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { @@ -1707,23 +1660,23 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" } #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] proc ::p::${IFID}::___system___destructor _ID_ $body - } + } - if {[info exists o_unknown]} { - #use 'apply' somehow? - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - } + } + - - return + return } @@ -1736,7 +1689,7 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { proc ::p::predator::command_info_args {cmd} { if {[llength [set next [interp alias {} $cmd]]]} { set curriedargs [lrange $next 1 end] - + if {[catch {set arglist [info args [lindex $next 0]]}]} { set arglist [command_info_args [lindex $next 0]] } @@ -1757,11 +1710,11 @@ proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { set i 0 foreach arg [lrange $nextArgs 1 end] { upvar 1 $arg $i - if {$arg eq "args"} { + if {$arg eq "args"} { #need to check if 'args' is actually available in caller if {[info exists $i]} { set argVals [concat $argVals [set $i]] - } + } } else { lappend argVals [set $i] } @@ -1779,11 +1732,11 @@ proc ::p::predator::next_script {IFID method caller caller_ID_} { if {$caller eq "(CONSTRUCTOR).1"} { return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] } elseif {$caller eq "$method.1"} { - #delegate to next interface lower down the stack which has a member named $method + #delegate to next interface lower down the stack which has a member named $method return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] } elseif {[string match "(GET)*.2" $caller]} { - # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. - + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + #jmn set prop [string trimright $caller 1234567890] set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . @@ -1799,8 +1752,8 @@ proc ::p::predator::next_script {IFID method caller caller_ID_} { } elseif {[string match "(SET)*.2" $caller]} { return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] } else { - #this branch will also handle (SET)*.x and (GET)*.x where x >2 - + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" set callerid [string range $caller [string length "$method."] end] set nextid [expr {$callerid - 1}] @@ -1837,8 +1790,8 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { foreach if_sub [lreverse $lower_interfaces] { if {[string match "(GET)*" $method]} { #do not test o_properties here! We need to call even if there is no underlying property on this interface - #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) - # relevant test: higher_order_propertyread_chaining + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] } elseif {[string match "(SET)*" $method]} { #must be called even if there is no matching $method in o_properties @@ -1848,17 +1801,17 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { #error "do_next_if (UNSET) untested" #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { if {[llength $args]} { #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" - + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args - + #!todo - handle case where llength $args is less than number of args for subinterface command #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) - + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) set head [interp alias {} ::p::${if_sub}::_iface::$method] set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc @@ -1866,33 +1819,33 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { foreach a $nextArgs { lappend argx "\$a" } - + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared - + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args } else { #todo - upvars required for tail end of arglist tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args } - + } else { #auto-set: upvar vars from calling scope - #!todo - robustify? alias not necessarily matching command name.. + #!todo - robustify? alias not necessarily matching command name.. set head [interp alias {} ::p::${if_sub}::_iface::$method] - + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc if {[llength $nextArgs] > 1} { set argVals [::list] set i 0 foreach arg [lrange $nextArgs 1 end] { upvar 1 $arg $i - if {$arg eq "args"} { + if {$arg eq "args"} { #need to check if 'args' is actually available in caller if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } + set argVals [concat $argVals [set $i]] + } } else { lappend argVals [set $i] } @@ -1911,7 +1864,7 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args } } - #no interfaces in the iStack contained a matching method. + #no interfaces in the iStack contained a matching method. return } else { #no further interfaces in this iStack @@ -1923,43 +1876,42 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { #only really makes sense for (CONSTRUCTOR) calls. #_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { - #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" #set invocants [dict get $_ID_ i] #set this_invocant [lindex [dict get $invocants this] 0] #lassign $this_invocant OID this_info - #set OID [lindex [dict get $invocants this] 0 0] + #set OID [lindex [dict get $invocants this] 0 0] #upvar #0 ::p::${OID}::_meta::map map - #lassign [lindex $map 0] OID alias itemCmd cmd - - - set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] - upvar #0 ::p::${caller_OID}::_meta::map callermap - - #set interfaces [lindex $map 1 0] - set patterninterfaces [dict get $callermap interfaces level1] - - set L0_posn [lsearch $patterninterfaces $IFID] - if {$L0_posn == -1} { - error "do_next_pattern_if called with interface not present at level1 for this object" - } elseif {$L0_posn > 0} { - - - set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } } @@ -1984,28 +1936,28 @@ proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { #!todo - can we just call new_object somehow to create this? - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + #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://mini.net/tcl/1030 'Dangers of creative writing') namespace eval ::p::-1 { #namespace ensemble create - - namespace eval _ref {} - namespace eval _meta {} + + namespace eval _ref {} + namespace eval _meta {} namespace eval _iface { variable o_usedby variable o_open variable o_constructor variable o_variables - variable o_properties - variable o_methods + variable o_properties + variable o_methods variable o_definition variable o_varspace variable o_varspaces - + array set o_usedby [list i0 1] ;#!todo - review - #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? set o_open 1 set o_constructor [list] @@ -2030,51 +1982,51 @@ upvar #0 ::p::-1::_iface::o_definition def #! concatenate -> compose ?? dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} -proc ::p::-1::Concatenate {_ID_ target args} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {![string match "::*" $target]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set target ::$target - } else { - set target ${ns}::$target - } - } - #add > character if not already present - set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] - set _target [string map {::> ::} $target] - - set ns [namespace qualifiers $target] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - if {![llength [info commands $target]]} { - #degenerate case - target does not exist + if {![llength [info commands $target]]} { + #degenerate case - target does not exist #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' #review - should be 'Copy' so it has object state from namespaces and variables? return [::p::-1::Clone $_ID_ $target {*}$args] - - #set TARGETMAP [::p::predator::new_object $target] - #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd - } else { - #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] - set TARGETMAP [$target --] + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - - #Merge lastmodified(?) level0 and level1 interfaces. - - } + #Merge lastmodified(?) level0 and level1 interfaces. + + } return $target } @@ -2087,70 +2039,67 @@ proc ::p::-1::Concatenate {_ID_ target args} { dict set ::p::-1::_iface::o_methods Define {arglist definitions} #define objects in one step proc ::p::-1::Define {_ID_ definitions} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern - lassign [dict get $MAP invocantdata] OID alias default_method cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - - #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack - #set IFID0 [lindex $interfaces 0] - #set IFID1 [lindex $patterns 0] ;#1st pattern - - #set IFID_TOP [lindex $interfaces end] - set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] - - #set ns ::p::${OID} - - #set script [string map [list %definitions% $definitions] { - # if {[lindex [namespace path] 0] ne "::p::-1"} { - # namespace path [list ::p::-1 {*}[namespace path]] - # } - # %definitions% - # namespace path [lrange [namespace path] 1 end] - # - #}] - - set script [string map [list %id% $_ID_ %definitions% $definitions] { - set ::p::-1::temp_unknown [namespace unknown] - - namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] - - - #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] - - - %definitions% - - - namespace unknown ${::p::-1::temp_unknown} - return - }] - - - - #uplevel 1 $script ;#this would run the script in the global namespace - #run script in the namespace of the open interface, this allows creating of private helper procs - #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack - #namespace inscope ::p::${OID} $script + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script namespace eval ::p::${OID} $script - #return $cmd + #return $cmd } proc ::p::predator::redirect {func args} { - - #todo - review tailcall - tests? - if {![llength [info commands ::p::-1::$func]]} { - #error "invalid command name \"$func\"" - tailcall uplevel 1 [list ::unknown $func {*}$args] - } else { - tailcall uplevel 1 [list ::p::-1::$func {*}$args] - } + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } } @@ -2159,44 +2108,44 @@ dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} proc ::p::-1::Construct {_ID_ argpairs body args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set ARGSETTER {} - foreach {argname argval} $argpairs { - append ARGSETTER "set $argname $argval\n" - } - #$_self (VIOLATE) $ARGSETTER$body - - set body $ARGSETTER\n$body - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - # puts stderr "\t runtime_vardecls in Construct $varDecls" - } + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } - set next "\[error {next not implemented}\]" - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #namespace eval ::p::${iid_top} $body + #namespace eval ::p::${iid_top} $body - #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] - #does this handle Varspace before constructor? - return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] } @@ -2206,64 +2155,64 @@ proc ::p::-1::Construct {_ID_ argpairs body args} { #hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects namespace eval ::p::3 {} proc ::p::3::_create {child {OID "-2"}} { - #puts stderr "::p::3::_create $child $OID" - set _child [string map {::> ::} $child] - if {$OID eq "-2"} { - #set childmapdata [::p::internals::new_object $child] - #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] - set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } else { - set child_ID $OID - #set _childmap [::p::internals::new_object $child "" $child_ID] - ::p::internals::new_object $child "" $child_ID - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } - - #-------------- + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- - set oldinterfaces [dict get $CHILDMAP interfaces] - dict set oldinterfaces level0 [list 2] - set modifiedinterfaces $oldinterfaces - dict set CHILDMAP interfaces $modifiedinterfaces - - #-------------- + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + #-------------- - #puts stderr ">>>> creating alias for ::p::$child_ID" - #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" - - #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! - #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] - #puts stderr ">>>[interp alias {} ::p::$child_ID]" - - + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] #--------------- - namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties - foreach method [dict keys $o_methods] { - #todo - change from interp alias to context proc - interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method - } - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop - - } - ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] - #--------------- - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - return $child + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child } -#configure -prop1 val1 -prop2 val2 ... +#configure -prop1 val1 -prop2 val2 ... dict set ::p::-1::_iface::o_methods Configure {arglist args} proc ::p::-1::Configure {_ID_ args} { @@ -2272,7 +2221,7 @@ proc ::p::-1::Configure {_ID_ args} { ::p::map $OID MAP lassign [dict get $MAP invocantdata] OID alias itemCmd this - + if {![expr {([llength $args] % 2) == 0}]} { error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" } @@ -2286,7 +2235,7 @@ proc ::p::-1::Configure {_ID_ args} { lappend properties_to_configure [string range $argprop 1 end] } - #gather all valid property names for all level0 interfaces in the relevant interface stack + #gather all valid property names for all level0 interfaces in the relevant interface stack set valid_property_names [list] set iflist [dict get $MAP interfaces level0] foreach id [lreverse $iflist] { @@ -2323,59 +2272,59 @@ proc ::p::-1::Configure {_ID_ args} { dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} -proc ::p::-1::AddPatternInterface {_ID_ iid} { - #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces - - - #it is theoretically possible to have the same interface present multiple times in an iStack. - # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? - lappend existing_ifaces $iid - #lset map {1 1} $existing_ifaces - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - - #lset invocant {1 1} $existing_ifaces + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict -} + #lset invocant {1 1} $existing_ifaces + +} #!todo - update usedby ?? dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} -proc ::p::-1::AddInterface {_ID_ iid} { - #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - - lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. - set this_invocant [lindex $list_of_invocants_for_role_this 0] - - lassign $this_invocant OID _etc +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level0] - lappend existing_ifaces $iid - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - return [dict get $extracted_sub_dict level0] + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] } @@ -2395,7 +2344,7 @@ proc ::p::-1::AddInterface {_ID_ iid} { #simple form with arguments to the constructor: # >somepattern .. Create >child arg1 arg2 etc #complex form - specify more info about the target (dict keyed on childobject name): -# >somepattern .. Create {>child {-id 1}} +# >somepattern .. Create {>child {-id 1}} #or # >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] #complex form - with arguments to the contructor: @@ -2409,12 +2358,12 @@ proc ::p::-1::Create {_ID_ target_spec args} { } else { set targets $target_spec } - + set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP set invocants [dict get $_ID_ i] set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) - + foreach {child target_spec_dict} $targets { #puts ">>>::p::-1::Create $_ID_ $child $args <<<" @@ -2422,9 +2371,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { #set invocant_alias [lindex [dict get $invocants this] 0] #set invocant [lindex [interp alias {} $invocant_alias] 1] - - - + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" @@ -2433,15 +2380,15 @@ proc ::p::-1::Create {_ID_ target_spec args} { #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces #puts "parent: $OID -> child:$child Patterns $patterns" #todo - change to dict of interface stacks - set IFID0 [lindex $interfaces 0] - set IFID1 [lindex $patterns 0] ;#1st pattern - + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + #upvar ::p::${OID}:: INFO if {![string match {::*} $child]} { @@ -2456,14 +2403,14 @@ proc ::p::-1::Create {_ID_ target_spec args} { #add > character if not already present set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] set _child [string map {::> ::} $child] - + set ns [namespace qualifiers $child] if {$ns eq ""} { set ns "::" } else { namespace eval $ns {} } - + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. set new_interfaces [list] @@ -2471,7 +2418,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {![llength $patterns]} { ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" #lappend patterns [::p::internals::new_interface $OID] - + #lset invocant {1 1} $patterns ##update our command because we changed the interface list. #set IFID1 [lindex $patterns 0] @@ -2487,20 +2434,20 @@ proc ::p::-1::Create {_ID_ target_spec args} { #--------- #set iface [::p::>interface .. Create ::p::ifaces::>$iid] #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid - + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] - + #--------- #puts "??> p::>interface .. Create ::p::ifaces::>$iid" #puts "??> [::p::ifaces::>$iid --]" #set [$iface . UsedBy .] } - set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] #if {![llength [info commands $child]]} {} - + if {[namespace which $child] eq ""} { #normal case - target/child does not exist set is_new_object 1 @@ -2512,40 +2459,38 @@ proc ::p::-1::Create {_ID_ target_spec args} { } lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - - + #child initially uses parent's level1 interface as it's level0 interface - # child has no level1 interface until PatternMethods or PatternProperties are added + # child has no level1 interface until PatternMethods or PatternProperties are added # (or applied via clone; or via create with a parent with level2 interface) #set child_IFID $IFID1 - + #lset CHILDMAP {1 0} [list $IFID1] #lset CHILDMAP {1 0} $patterns - + set extracted_sub_dict [dict get $CHILDMAP interfaces] dict set extracted_sub_dict level0 $patterns dict set CHILDMAP interfaces $extracted_sub_dict - + #why write back when upvared??? #review set ::p::${child_ID}::_meta::map $CHILDMAP - + #::p::predator::remap $CHILDMAP #interp alias {} $child {} ::p::internals::predator $CHILDMAP #set child_IFID $IFID1 - #upvar ::p::${child_ID}:: child_INFO + #upvar ::p::${child_ID}:: child_INFO #!todo review #set n ::p::${child_ID} #if {![info exists ${n}::-->PATTERN_ANCHOR]} { - # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" - # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack - # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" - # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] #} set ifaces_added $patterns @@ -2562,16 +2507,16 @@ proc ::p::-1::Create {_ID_ target_spec args} { #puts " **** CHILDMAP: $CHILDMAP" #puts " ****" - #puts stderr " ---> Properties: [$child .. Properties . names]" - #puts stderr " ---> Methods: [$child .. Properties . names]" - + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - #set child_IFID [lindex $CHILDMAP 1 0 end] + #set child_IFID [lindex $CHILDMAP 1 0 end] #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { - # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] - # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP #} ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces #::p::merge_interface $IFID1 $child_IFID @@ -2604,17 +2549,17 @@ proc ::p::-1::Create {_ID_ target_spec args} { #update the child's _ID_ interp alias {} $child_alias {} ;#first we must delete it interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] - + #! object_command was initially created as the renamed alias - so we have to do it again rename $child_alias $child - trace add command $child rename [list $child .. Rename] + trace add command $child rename [list $child .. Rename] } #!todo - review - dont we already have interp alias entries for every method/prop? #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. @@ -2683,7 +2628,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {![info exists o_usedby(i$child_ID)]} { set o_usedby(i$child_ID) $child_alias } - + #compile and close the interface only if it is shared if {$o_open} { ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ @@ -2691,8 +2636,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } - - + package require struct::set set propcmds [list] @@ -2707,8 +2651,8 @@ proc ::p::-1::Create {_ID_ target_spec args} { #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. foreach property $propcmds { #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" - interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces - interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property } set propcmds [list] @@ -2735,7 +2679,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { } else { set a $argspec } - + if {$a eq "args"} { append argvals " \{*\}\$args" } else { @@ -2743,29 +2687,27 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } set argvals [string trimleft $argvals] - + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method - - #this proc directly on the object is not *just* a forwarding proc + + #this proc directly on the object is not *just* a forwarding proc # - it provides a context in which the 'uplevel 1' from the running interface proc runs #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - - + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { ::p::${IFID}::_iface::$method \$_ID_ $argvals }] - + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { - # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ #}] - - + } #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - + #implement property even if interface already compiled because we need to create defaults for each new child obj. # also need to add alias on base interface #make sure we are only implementing properties from the current CREATOR @@ -2788,23 +2730,23 @@ proc ::p::-1::Create {_ID_ target_spec args} { } #! May be replaced by a method with the same name if {$prop ni [dict keys $o_methods]} { - interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop } - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop } #variables #foreach vdef $o_variables { - # if {[llength $vdef] == 2} { - # #there is a default value defined. - # lassign $vdef v default - # if {![info exists ::p::${child_ID}::$v]} { - # set ::p::${child_ID}::$v $default - # } - # } + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } #} dict for {vname vdef} $o_variables { if {[dict exists $vdef default]} { @@ -2822,16 +2764,15 @@ proc ::p::-1::Create {_ID_ target_spec args} { set ${ns}::$vname [dict get $vdef default] } } - - + #!todo - review. Write tests for cases of multiple constructors! - + #We don't want to the run constructor for each added interface with the same set of args! #run for last one - rely on constructor authors to use @next@ properly? if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { set highest_constructor_IFID $IFID } - + if {$idx == $idx_count} { #we are processing the last interface that was added - now run the latest constructor found if {$highest_constructor_IFID ne ""} { @@ -2846,13 +2787,12 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } } - + if {[info exists o_unknown]} { - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - - - #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] } @@ -2861,9 +2801,9 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {$constructor_failure} { if {$is_new_object} { #is Destroy enough to ensure that no new interfaces or objects were left dangling? - $child .. Destroy + $child .. Destroy } else { - #object needs to be returned to a sensible state.. + #object needs to be returned to a sensible state.. #attempt to rollback all interface additions and object state changes! puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" #remove variables from the object's namespace - which don't exist in the snapshot. @@ -2880,10 +2820,10 @@ proc ::p::-1::Create {_ID_ target_spec args} { #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) #values of vars may also have Changed #todo - consider traces? what is the correct behaviour? - # - some application traces may have fired before the constructor error occurred. - # Should the rollback now also trigger traces? - #probably yes. - + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value foreach vname $snap_vars { #puts stdout "@@@@@@@@@@@ restoring $vname" @@ -2895,7 +2835,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {$target in [info vars ::p::${child_ID}::*]} { set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' } else { - set present 0 + set present 0 } if {[array exists $vname]} { @@ -2904,7 +2844,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { array set $target [array get $vname] } else { if {[array exists $target]} { - #unset superfluous elements + #unset superfluous elements foreach key [array names $target] { if {$key ni [array names $vname]} { array unset $target $key @@ -2930,7 +2870,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {[array exists $target]} { #target has been changed to array - unset it and recreate the simple variable. unset $target - set $target [set $vname] + set $target [set $vname] } else { if {[set $target] ne [set $vname]} { set $target [set $vname] @@ -2950,12 +2890,10 @@ proc ::p::-1::Create {_ID_ target_spec args} { return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error } namespace delete $ns_snap - - } - - - return $child + } + + return $child } dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} @@ -2969,8 +2907,8 @@ proc ::p::-1::Clone {_ID_ clone args} { set invocants [dict get $_ID_ i] lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set _cmd [string map {::> ::} $cmd] - set tail [namespace tail $_cmd] + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] #obsolete? @@ -2989,17 +2927,17 @@ proc ::p::-1::Clone {_ID_ clone args} { } - set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] - set _clone [string map {::> ::} $clone] + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] - set cTail [namespace tail $_clone] + set cTail [namespace tail $_clone] set ns [namespace qualifiers $clone] if {$ns eq ""} { set ns "::" } - + namespace eval $ns {} @@ -3014,7 +2952,7 @@ proc ::p::-1::Clone {_ID_ clone args} { set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP - + #copy patterndata element of MAP straight across dict set CLONEMAP patterndata [dict get $MAP patterndata] @@ -3029,18 +2967,18 @@ proc ::p::-1::Clone {_ID_ clone args} { #! object_command was initially created as the renamed alias - so we have to do it again rename $clone_alias $clone - trace add command $clone rename [list $clone .. Rename] + trace add command $clone rename [list $clone .. Rename] #obsolete? - #upvar ::p::${clone_ID}:: clone_INFO - #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. - #upvar ::p::${OID}:: INFO + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO - array set clone_INFO [array get INFO] + array set clone_INFO [array get INFO] array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' @@ -3056,28 +2994,28 @@ proc ::p::-1::Clone {_ID_ clone args} { #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern - #clone's interface maps must be a superset of original's + #clone's interface maps must be a superset of original's foreach lev {0 1} { - #set parent_ifaces [lindex $map 1 $lev] + #set parent_ifaces [lindex $map 1 $lev] set parent_ifaces [dict get $MAP interfaces level$lev] - + #set existing_ifaces [lindex $CLONEMAP 1 $lev] set existing_ifaces [dict get $CLONEMAP interfaces level$lev] - + set added_ifaces_$lev [list] foreach ifid $parent_ifaces { if {$ifid ni $existing_ifaces} { - - #interface must not remain extensible after cloning. + + #interface must not remain extensible after cloning. if {[set ::p::${ifid}::_iface::o_open]} { ::p::predator::compile_interface $ifid $_ID_ set ::p::${ifid}::_iface::o_open 0 - } + } lappend added_ifaces_$lev $ifid - #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone } } @@ -3117,10 +3055,10 @@ proc ::p::-1::Clone {_ID_ clone args} { #! May be replaced by method of same name if {[namespace which ::p::${clone_ID}::$prop] eq ""} { - interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop } - interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop - interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop } #variables @@ -3144,18 +3082,18 @@ proc ::p::-1::Clone {_ID_ clone args} { #update the clone object's base interface to reflect the new methods. - #upvar 0 ::p::${ifid}:: IFACE + #upvar 0 ::p::${ifid}:: IFACE #set methods [list] #foreach {key mname} [array get IFACE m-1,name,*] { - # set method [lindex [split $key ,] end] - # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP - # lappend methods $method + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method #} #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] - + foreach method [dict keys $o_methods] { - + set arglist [dict get $o_methods $method arglist] set argvals "" foreach argspec $arglist { @@ -3164,7 +3102,7 @@ proc ::p::-1::Clone {_ID_ clone args} { } else { set a $argspec } - + if {$a eq "args"} { append argvals " \{*\}\$args" } else { @@ -3172,10 +3110,9 @@ proc ::p::-1::Clone {_ID_ clone args} { } } set argvals [string trimleft $argvals] - #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method - - - #this proc directly on the object is not *just* a forwarding proc + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc # - it provides a context in which the 'uplevel 1' from the running interface proc runs #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) @@ -3183,15 +3120,15 @@ proc ::p::-1::Clone {_ID_ clone args} { proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { ::p::${ifid}::_iface::$method \$_ID_ $argvals }] - + } #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] if {[info exists o_unknown]} { #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown - interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] @@ -3213,12 +3150,12 @@ proc ::p::-1::Clone {_ID_ clone args} { # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... - # when we now do >sibling .. Create >grandchild + # when we now do >sibling .. Create >grandchild # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) - # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild #(though other arguments can be manually passed) - # #!review - does this make sense? What if we add + # #!review - does this make sense? What if we add # #constructor for each interface called after properties initialised. #run each interface's constructor against child object, using the args passed into this clone method. @@ -3226,14 +3163,14 @@ proc ::p::-1::Clone {_ID_ clone args} { #error puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args - + } } return $clone - + } @@ -3241,77 +3178,77 @@ proc ::p::-1::Clone {_ID_ clone args} { interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} proc ::p::-1::Constructor {_ID_ arglist body} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - set iface ::p::ifaces::>$iid_top + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - #set iid_top [::p::get_new_object_id] - - #the >interface constructor takes a list of IDs for o_usedby - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] - #::p::predator::remap $invocant - } - set IID $iid_top + #::p::predator::remap $invocant + } + set IID $iid_top namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] - set headid [expr {$maxversion + 1}] - set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 - set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] #set varspaces [::pattern::varspace_list] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] - set body $varDecls\n[dict get $processed body] - #puts stderr "\t runtime_vardecls in Constructor $varDecls" - } + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #puts stderr ---- - #puts stderr $body - #puts stderr ---- + #puts stderr ---- + #puts stderr $body + #puts stderr ---- - proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body - interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid - set o_constructor [list $arglist $body] - set o_open 1 - - return + set o_constructor [list $arglist $body] + set o_open 1 + + return } @@ -3340,246 +3277,245 @@ proc ::p::-1::Destroy {_ID_ {force 1}} { set invocants [dict get $_ID_ i] set OID [lindex [dict get $invocants this] 0 0] - if {$OID eq "null"} { - puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" - return - } + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } - upvar #0 ::p::${OID}::_meta::map MAP + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout - - #explicit Destroy - remove traces - #puts ">>TRACES: [trace info variable $cmd]" - #foreach tinfo [trace info variable $cmd] { - # trace remove variable $cmd {*}$tinfo - #} - #foreach tinfo [trace info command $cmd] { - # trace remove command $cmd {*}$tinfo - #} - - - set _cmd [string map {::> ::} $cmd] - - #set ifaces [lindex $map 1] - set iface_stacks [dict get $MAP interfaces level0] - #set patterns [lindex $map 2] - set pattern_stacks [dict get $MAP interfaces level1] - - - - set ifaces $iface_stacks - - - set patterns $pattern_stacks - - - #set i 0 - #foreach iflist $ifaces { - # set IFID$i [lindex $iflist 0] - # incr i - #} - - - set IFTOP [lindex $ifaces end] - - set DESTRUCTOR ::p::${IFTOP}::___system___destructor - #may be a proc, or may be an alias + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias if {[namespace which $DESTRUCTOR] ne ""} { - set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] - - if {[catch {$DESTRUCTOR $temp_ID_} prob]} { - #!todo - ensure correct calling order of interfaces referencing the destructor proc - - - #!todo - emit destructor errors somewhere - logger? - #puts stderr "underlying proc already removed??? ---> $prob" - #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" - #puts stderr $::errorInfo - #puts stderr "---------------------" - } - } - - - #remove ourself from each interfaces list of referencers - #puts stderr "--- $ifaces" - - foreach var {ifaces patterns} { - - foreach i [set $var] { - - if {[string length $i]} { - if {$i == 2} { - #skip the >ifinfo interface which doesn't maintain a usedby list anyway. - continue - } - - if {[catch { - - upvar #0 ::p::${i}::_iface::o_usedby usedby - - array unset usedby i$OID - - - #puts "\n***>>***" - #puts "IFACE: $i usedby: $usedby" - #puts "***>>***\n" - - #remove interface if no more referencers - if {![array size usedby]} { - #puts " **************** DESTROYING unused interface $i *****" - #catch {namespace delete ::p::$i} - - #we happen to know where 'interface' object commands are kept: - - ::p::ifaces::>$i .. Destroy - - } - - } errMsg]} { - #warning - puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" - } - } - - } - - } - - set ns ::p::${OID} - #puts "-- destroying objects below namespace:'$ns'" - ::p::internals::DestroyObjectsBelowNamespace $ns - #puts "--.destroyed objects below '$ns'" - - - #set ns ::p::${OID}::_sub - #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace - #( ::p::OBJECT::$OID ) - #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" - #::p::internals::DestroyObjectsBelowNamespace $ns + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns #same for _meta objects (e.g Methods,Properties collections) #set ns ::p::${OID}::_meta - #::p::internals::DestroyObjectsBelowNamespace $ns - + #::p::internals::DestroyObjectsBelowNamespace $ns + - #foreach obj [info commands ${ns}::>*] { - # #Assume it's one of ours, and ask it to die. - # catch {::p::meta::Destroy $obj} - # #catch {$cmd .. Destroy} - #} - #just in case the user created subnamespaces.. kill objects there too. - #foreach sub [namespace children $ns] { - # ::p::internals::DestroyObjectsBelowNamespace $sub - #} + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! #use info commands ::p::${OID}::_ref::* to find all references - including variables never set #remove variable traces on REF vars #foreach rv [info vars ::p::${OID}::_ref::*] { - # foreach tinfo [trace info variable $rv] { + # foreach tinfo [trace info variable $rv] { # #puts "-->removing traces on $rv: $tinfo" # trace remove variable $rv {*}$tinfo # } #} #!todo - write tests - #refs create aliases and variables at the same place - #- but variable may not exist if it was never set e.g if it was only used with info exists + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists foreach rv [info commands ::p::${OID}::_ref::*] { - foreach tinfo [trace info variable $rv] { + foreach tinfo [trace info variable $rv] { #puts "-->removing traces on $rv: $tinfo" trace remove variable $rv {*}$tinfo } } - - - #if {[catch {namespace delete $nsMeta} msg]} { - # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " - #} else { - # #puts stderr "------ -- -- -- -- deleted $nsMeta " - #} - #!todo - remove - #temp - #catch {interp alias "" ::>$OID ""} + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} - if {$force} { - #rename $cmd {} + if {$force} { + #rename $cmd {} - #removing the alias will remove the command - even if it's been renamed - interp alias {} $alias {} + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} - #if {[catch {rename $_cmd {} } why]} { - # #!todo - work out why some objects don't have matching command. - # #puts stderr "\t rename $_cmd {} failed" - #} else { - # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" - #} + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } - } + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" - set refns ::p::${OID}::_ref - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- matching command: [llength [info commands ${refns}]]" - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} - #foreach v [info vars ${refns}::*] { - # unset $v - #} - #foreach p [info procs ${refns}::*] { - # rename $p {} - #} - #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { - # interp alias {} $a {} - #} + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" - #set ts1 [clock seconds] - #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- exact command: [info commands ${refns}]" + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" - #puts "--delete ::p::${OID}::_ref" - if {[namespace exists ::p::${OID}::_ref]} { - #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. - namespace delete ::p::${OID}::_ref:: - } - set ts2 [clock seconds] - #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID - #delete namespace where instance variables reside - #catch {namespace delete ::p::$OID} - namespace delete ::p::$OID - - #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout - return + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return } @@ -3593,44 +3529,44 @@ proc ::p::-1::Destructor {_ID_ args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - #lassign [lindex $map 0] OID alias itemCmd cmd - - set patterns [dict get $MAP interfaces level1] - - if {[llength $args] > 2} { - error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" - } - - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - error "NOT TESTED" - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - #::p::predator::remap $invocant - } - - - set ::p::${IID}::_iface::o_destructor_body [lindex $args end] - - if {[llength $args] > 1} { - #!todo - allow destructor args(?) - set arglist [lindex $args 0] - } else { - set arglist [list] - } - - set ::p::${IID}::_iface::o_destructor_args $arglist - - return + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return } @@ -3645,7 +3581,7 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - + set patterns [dict get $MAP interfaces level1] set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. set iface ::p::ifaces::>$iid_top @@ -3667,12 +3603,12 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { # examine the existing command-chain set maxversion [::p::predator::method_chainhead $IID $method] set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 + set THISNAME $method.$headid ;#first version will be $method.1 - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { @@ -3690,11 +3626,11 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] #puts "\t\t--------------------" #puts "\n" - #puts $body + #puts $body #puts "\n" #puts "\t\t--------------------" proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body @@ -3706,7 +3642,7 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { - if {$method in [dict keys $o_methods]} { + if {$method in [dict keys $o_methods]} { #error "patternmethod '$method' already present in interface $IID" set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" if {[string match "*@next@*" $body]} { @@ -3732,15 +3668,15 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { # for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. # (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) # !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) -# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? # - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? -# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? # (and how would we define the call order? - presumably as it appears in the conglomerate) # (or could that be done with a more general method-wrapping mechanism?) #...should multimethods use some sort of event mechanism, and/or message-passing system? # dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} -proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { set invocants [dict get $_ID_ i] error "not implemented" @@ -3750,45 +3686,45 @@ dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsu # we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) #we can create a method named "." by using the argprotect operator -- # e.g >x .. Method -- . {args} $body -#It can then be called like so: >x . . -#This is not guaranteed to work and is not in the test suite +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite #for now we'll just use a highly unlikely string to indicate no argument was supplied -proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - if {$methodname eq $non_argument_magicstring} { - return $default_method - } else { - set extracted_value [dict get $MAP invocantdata] - lset extracted_value 2 $methodname - dict set MAP invocantdata $extracted_value ;#write modified value back - #update the object's command alias to match - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] - - #! $object_command was initially created as the renamed alias - so we have to do it again - rename $alias $object_command - trace add command $object_command rename [list $object_command .. Rename] - return $methodname - } +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } } dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set extracted_patterndata [dict get $MAP patterndata] - set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] - if {$methodname eq $non_argument_magicstring} { - return $pattern_default_method - } else { - dict set extracted_patterndata patterndefaultmethod $methodname - dict set MAP patterndata $extracted_patterndata - return $methodname - } +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } } @@ -3801,7 +3737,7 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { set invocant_signature [list] ; - ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. foreach role [lsort [dict keys $invocants]] { lappend invocant_signature $role [llength [dict get $invocants $role]] } @@ -3816,11 +3752,11 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { ################################################################################# if 0 { - set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface set prev_open [set ::p::${iid_top}::_iface::o_open] set iface ::p::ifaces::>$iid_top - + set f_new 0 if {![string length $iid_top]} { set f_new 1 @@ -3837,25 +3773,25 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat $interfaces $iid_top] dict set MAP interfaces $extracted_sub_dict - + } set IID $iid_top } ################################################################################# - + set IID [::p::predator::get_possibly_new_open_interface $OID] - #upvar 0 ::p::${IID}:: IFACE + #upvar 0 ::p::${IID}:: IFACE namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - #Interface proc - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 if {$method ni [dict keys $o_methods]} { dict set o_methods $method [list arglist $arglist] @@ -3866,10 +3802,10 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" - #implement - #----------------------------------- - set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs @@ -3877,97 +3813,93 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { } set body [dict get $processed body] set varDecls "" - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - } + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] - - + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #if {[string length $varDecls]} { - # puts stdout "\t---------------------------------------------------------------" - # puts stdout "\t----- efficiency warning - implicit var declarations used -----" - # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" - # puts stdout "\t[string map [list \n \t\t\n] $body]" - # puts stdout "\t--------------------------" - #} + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role - # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. #(as specified by the @ operator during object conglomeration) - #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] #puts stdout "\t\t----------------------------" #puts stdout "$body" #puts stdout "\t\t----------------------------" - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - #----------------------------------- - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - #point to the interface command only. The dispatcher will supply the invocant data - #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IID}::_iface::$method \$_ID_ $argvals - }] - - - if 0 { - if {[llength $argvals]} { - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { - apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ - }] - } else { - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { - apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ - }] - - } - } - - - #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - # ::p::${IID}::_iface::$method \$_ID_ $argvals - #}] - - #todo - for o_varspaces - #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method - #- this should work correctly with the 'uplevel 1' procs in the interfaces - - + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + if {[string length $o_varspace]} { if {[string match "::*" $o_varspace]} { namespace eval $o_varspace {} @@ -3977,37 +3909,37 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { } - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. set colMethods ::p::${OID}::_meta::>colMethods - + if {[namespace which $colMethods] ne ""} { if {![$colMethods . hasKey $method]} { $colMethods . add [::p::internals::predator $_ID_ . $method .] $method } } - #::p::-1::update_invocant_aliases $_ID_ - return - #::>pattern .. Create [::>pattern .. Namespace]::>method_??? - #return $method_object + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object } dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} proc ::p::-1::V {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set vlist [list] + set vlist [list] foreach IID $ifaces { dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { if {[string match $glob $vname]} { @@ -4015,8 +3947,6 @@ proc ::p::-1::V {_ID_ {glob *}} { } } } - - return $vlist } @@ -4036,105 +3966,100 @@ proc p::predator::pipeline {args} { } proc ::p::predator::get_apply_arg_0_oid {} { - set apply_args [lrange [info level 0] 2 end] - puts stderr ">>>>> apply_args:'$apply_args'<<<<" - set invocant [lindex $apply_args 0] - return [lindex [dict get $invocant i this] 0 0] + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] } proc ::p::predator::get_oid {} { - #puts stderr "---->> [info level 1] <<-----" - set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 - tailcall lindex [dict get $_ID_ i this] 0 0 + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 } #todo - make sure this is called for all script installations - e.g propertyread etc etc -#Add tests to check code runs in correct namespace +#Add tests to check code runs in correct namespace #review - how does 'Varspace' command affect this? proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { - #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) - set arglist_apply "" - append arglist_apply "\$_ID_ " - foreach a $arglist { - if {$a eq "args"} { - append arglist_apply "{*}\$args" - } else { - append arglist_apply "\$[lindex $a 0] " - } - } - #!todo - allow fully qualified varspaces - if {[string length $varspace]} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { if {[string match ::* $varspace]} { return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" } else { #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" } - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" - #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" - - set script "tailcall apply \[list \{_ID_" - - if {[llength $arglist]} { - append script " $arglist" - } - append script "\} \{" - append script $body - append script "\} ::p::@OID@\] " - append script $arglist_apply - #puts stderr "\n88888888888888888888888888\n\t$script\n" - #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" - #return $script - - - #----------------------------------------------------------------------------- - # 2018 candidates - # - #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - - - #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) - #faster though. - #return "uplevel 1 \{$body\}" - return "uplevel 1 [list $body]" - #----------------------------------------------------------------------------- - - - - - #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" - #return "uplevel 1 \{$script\}" - - #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - - - - #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong - - #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns - - - #experiment with different dispatch mechanism (interp alias with 'namespace inscope') - #----------- - #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" - - - #return "uplevel 1 \{$body\}" ;#do nothing - - #---------- - - #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) - - #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body - - #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker - - #return "tailcall " - - - } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + } } @@ -4145,67 +4070,67 @@ proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist #concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces #WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! # e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. -#Think of var & varspace statments as a form of compile-time 'macro' +#Think of var & varspace statments as a form of compile-time 'macro' # #caters for 2-element lists as arguments to var statement to allow 'aliasing' #e.g var o_thing {o_data mydata} # this will upvar o_thing as o_thing & o_data as mydata # proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { - set body {} + set body {} - #keep count of any explicit var statments per varspace in 'numDeclared' array + #keep count of any explicit var statments per varspace in 'numDeclared' array # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. #default varspace is "" #varspace should only have leading :: if it is an absolute namespace path. - foreach ln [split $rawbody \n] { - set trimline [string trim $ln] + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] - if {$trimline eq "var"} { - #plain var statement alone indicates we don't have any explicit declarations in this branch - # and we don't want implicit declarations for the current varspace either. - #!todo - implement test + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test - incr numDeclared($varspace) + incr numDeclared($varspace) - #may be further var statements e.g - in other code branches - #return [list body $rawbody varspaces_with_explicit_vars 1] - } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { - #append body " upvar #0 " - #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " - #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " if {$varspace eq ""} { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " } else { if {[string match "::*" $varspace]} { append body " namespace upvar $varspace " - } else { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " } } - #any whitespace before or betw var names doesn't matter - about to use as list. - foreach varspec [string range $trimline 4 end] { - lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. - ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " - #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " - - append body "$var $alias " - - } - append body \n - - incr numDeclared($varspace) - } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { - #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? - #it is assumed there is a single word following the 'varspace' keyword. - set varspace [string trim [string range $trimline 9 end]] - + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + # 2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + if {$varspace in [list {{}} {""}]} { set varspace "" } @@ -4213,7 +4138,7 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { #set varspace ::${varspace}:: #no need to initialize numDeclared($varspace) incr will work anyway. #if {![info exists numDeclared($varspace)]} { - # set numDeclared($varspace) 0 + # set numDeclared($varspace) 0 #} if {[string match "::*" $varspace]} { @@ -4229,13 +4154,13 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" } #!review - why? why do we need the magic 'default' name instead of just using the empty string? - #if varspace argument was empty string - leave it alone - } else { - append body $ln\n - } - } + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + - set varspaces [array names numDeclared] return [list body $body varspaces_with_explicit_vars $varspaces] @@ -4244,7 +4169,7 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { -#Interface Variables +#Interface Variables dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} proc ::p::-1::IV {_ID_ {glob *}} { set invocants [dict get $_ID_ i] @@ -4258,16 +4183,16 @@ proc ::p::-1::IV {_ID_ {glob *}} { #!todo - test #return [dict keys ::p::${OID}::_iface::o_variables $glob] - set members [list] - foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { - if {[string match $glob $vname]} { - lappend members $vname - } - } - return $members + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members } -dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} +dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} proc ::p::-1::MetaMethods {_ID_ {glob *}} { upvar ::p::-1::_iface::o_methods metaface_methods set metamethod_names [lsort [dict keys $metaface_methods]] @@ -4286,7 +4211,7 @@ proc ::p::-1::Methods {_ID_ {idx ""}} { #set map [dict get $this_info map] set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces @@ -4305,11 +4230,11 @@ proc ::p::-1::Methods {_ID_ {idx ""}} { } } } - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } } dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}} @@ -4320,13 +4245,13 @@ proc ::p::-1::M {_ID_ {glob *}} { #set map [dict get $this_info map] set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] + set members [list] foreach IID $ifaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] } - return $members + return $members } #PatternMethods @@ -4337,13 +4262,13 @@ proc ::p::-1::PM {_ID_ {glob *}} { lassign $this_invocant OID _etc #set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set members [list] + set members [list] foreach IID $ifaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] } - return [lsort $members] + return [lsort $members] } @@ -4358,10 +4283,10 @@ proc ::p::-1::IM {_ID_ {glob *}} { set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] } @@ -4369,70 +4294,70 @@ proc ::p::-1::IM {_ID_ {glob *}} { dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} proc ::p::-1::InterfaceStacks {_ID_} { - upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP - return [dict get $MAP interfaces level0] + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] } dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} proc ::p::-1::PatternStacks {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - return [dict get $MAP interfaces level1] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] } -#!todo fix. need to account for references which were never set to a value +#!todo fix. need to account for references which were never set to a value dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} proc ::p::-1::DeletePropertyReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - set refvars [info vars ::p::${OID}::_ref::*] - #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. - foreach rv $refvars { - foreach tinfo [trace info variable $rv] { - set ops {}; set cmd {} - lassign $tinfo ops cmd - trace remove variable $rv $ops $cmd - } - unset $rv - lappend cleared_references $rv - } - - - return [list deleted_property_references $cleared_references] + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] } dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} proc ::p::-1::DeleteMethodReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - - set iflist [dict get $MAP interfaces level0] - set iflist_reverse [lreferse $iflist] - #set iflist [dict get $MAP interfaces level0] - - - set refcommands [info commands ::p::${OID}::_ref::*] - foreach c $refcommands { - set reftail [namespace tail $c] - set field [lindex [split $c +] 0] - set field_is_a_method 0 - foreach IFID $iflist_reverse { - if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - set field_is_a_method 1 - break - } - } - if {$field_is_a_method} { - #what if it's also a property? - interp alias {} $c {} - lappend cleared_references $c - } - } - - - return [list deleted_method_references $cleared_references] + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] } @@ -4441,18 +4366,18 @@ proc ::p::-1::DeleteReferences {_ID_} { set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias default_method this - - set result [dict create] - dict set result {*}[$this .. DeletePropertyReferences] - dict set result {*}[$this .. DeleteMethodReferences] - - return $result + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result } ## #Digest # -#!todo - review +#!todo - review # -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) # #!todo - write tests - check that digest changes when properties of contained objects change value @@ -4469,7 +4394,7 @@ proc ::p::-1::Digest {_ID_ args} { upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] _OID alias default_method this - + set interface_ids [dict get $MAP interfaces level0] set IFID0 [lindex $interface_ids end] @@ -4478,15 +4403,14 @@ proc ::p::-1::Digest {_ID_ args} { if {[dict exists $args -a] && ![dict exists $args -algorithm]} { dict set args -algorithm [dict get $args -a] } - + set opts [dict merge $defaults $args] foreach key [dict keys $opts] { if {$key ni $known_flags} { error "unknown option $key. Expected only: $known_flags" } } - - + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} if {[dict get $opts -algorithm] ni $known_algos} { error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" @@ -4494,9 +4418,9 @@ proc ::p::-1::Digest {_ID_ args} { set algo [string tolower [dict get $opts -algorithm]] # append comma for each var so that all changes in adjacent vars detectable. - # i.e set x 34; set y 5 + # i.e set x 34; set y 5 # must be distinguishable from: - # set x 3; set y 45 + # set x 3; set y 45 if {[dict get $opts -indent] ne ""} { set state "" @@ -4507,13 +4431,11 @@ proc ::p::-1::Digest {_ID_ args} { } append state "${indent}object_command: $this\n" set indent "${indent} " - + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. - - - + #!todo - recurse into 'varspaces' set varspaces_found [list] append state "${indent}interfaces:\n" @@ -4528,7 +4450,7 @@ proc ::p::-1::Digest {_ID_ args} { } } } - + append state "${indent}vars:\n" foreach var [info vars ::p::${OID}::*] { append state "${indent} - [namespace tail $var] : \"" @@ -4545,7 +4467,7 @@ proc ::p::-1::Digest {_ID_ args} { foreach obj [info commands ::p::${OID}::>*] { append state "[$obj .. Digest {*}$subargs]\n" } - + append state "${indent}sub-namespaces:\n" set subargs $args dict set subargs -indent "$indent " @@ -4556,8 +4478,7 @@ proc ::p::-1::Digest {_ID_ args} { } } } - - + if {$algo in {"" raw none}} { return $state } else { @@ -4574,13 +4495,13 @@ proc ::p::-1::Digest {_ID_ args} { >b1 . encrypt $state -final 1 set result [>b1 . ciphertext] >b1 .. Destroy - + } elseif {$algo eq "blowfish-binary"} { - + } else { error "can't get here" } - + } } @@ -4629,12 +4550,12 @@ proc ::p::-1::Variable {_ID_ varname args} { #!assume var not already present on interface - it is an error to define twice (?) #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - + #Implement if there is a default #!todo - correct behaviour when overlaying on existing object with existing var of this name? #if {[string length $varspace]} { - # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] #} else { set ::p::${OID}::$varname [lindex $args 0] #} @@ -4653,45 +4574,45 @@ proc ::p::-1::Variable {_ID_ varname args} { dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} proc ::p::-1::PatternVariable {_ID_ varname args} { - set invocants [dict get $_ID_ i] + set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - ##this interface itself is always a co-invocant - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - set iface ::p::ifaces::>$iid_top + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top - set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. - if {[llength $args]} { - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - } else { - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } - return + return } dict set ::p::-1::_iface::o_methods Varspaces {arglist args} @@ -4701,7 +4622,7 @@ proc ::p::-1::Varspaces {_ID_ args} { upvar #0 ::p::${OID}::_meta::map MAP if {![llength $args]} { - #query + #query set iid_top [lindex [dict get $MAP interfaces level0] end] set iface ::p::ifaces::>$iid_top if {![string length $iid_top]} { @@ -4717,7 +4638,7 @@ proc ::p::-1::Varspaces {_ID_ args} { set varspaces $args foreach vs $varspaces { if {[string length $vs] && ($vs ni $o_varspaces)} { - if {[string match ::* $vs} { + if {[string match ::* $vs]} { namespace eval $vs {} } else { namespace eval ::p::${OID}::$vs {} @@ -4725,7 +4646,7 @@ proc ::p::-1::Varspaces {_ID_ args} { lappend o_varspaces $vs } } - return $o_varspaces + return $o_varspaces } #set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface @@ -4737,7 +4658,7 @@ proc ::p::-1::Varspace {_ID_ args} { ::p::map $OID MAP if {![llength $args]} { - #query + #query set iid_top [lindex [dict get $MAP interfaces level0] end] set iface ::p::ifaces::>$iid_top if {![string length $iid_top]} { @@ -4775,7 +4696,7 @@ proc ::p::-1::Varspace {_ID_ args} { proc ::p::predator::get_possibly_new_open_interface {OID} { #we need to re-upvar MAP rather than using a parameter - as we need to write back to it - upvar #0 ::p::${OID}::_meta::map MAP + upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level0] set iid_top [lindex $interfaces end] @@ -4786,7 +4707,7 @@ proc ::p::predator::get_possibly_new_open_interface {OID} { set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id #puts stderr ">>>>creating new interface $iid_top" set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - + set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat $interfaces $iid_top] dict set MAP interfaces $extracted_sub_dict @@ -4811,73 +4732,72 @@ dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} # set the default varspace for the interface, so that new methods/properties refer to it. # varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. proc ::p::-1::PatternVarspace {_ID_ varspace args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - if {[string length $varspace]} { - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - #o_varspace is the currently active varspace - set o_varspace $varspace + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace } ################################################################################################################################################### #get varspace and default from highest interface - return all interface ids which define it dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - - array set propinfo {} - set found_property_names [list] - #start at the lowest and work up (normal storage order of $interfaces) - foreach iid $interfaces { - set propinfodict [set ::p::${iid}::_iface::o_properties] - set matching_propnames [dict keys $propinfodict $propnamepattern] - foreach propname $matching_propnames { - if {$propname ni $found_property_names} { - lappend found_property_names $propname - } - lappend propinfo($propname,interfaces) $iid - ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one - if {[dict exists $propinfodict $propname default]} { - set propinfo($propname,default) [dict get $propinfodict $propname default] - } - set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] - } - } - - set resultdict [dict create] - foreach propname $found_property_names { - set fields [list varspace $propinfo($propname,varspace)] - if {[array exists propinfo($propname,default)]} { - lappend fields default [set propinfo($propname,default)] - } - lappend fields interfaces $propinfo($propname,interfaces) - dict set resultdict $propname $fields - } - return $resultdict + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict } @@ -4885,7 +4805,7 @@ dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} proc ::p::-1::GetTopPattern {_ID_ args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - + set interfaces [dict get $MAP interfaces level1] set iid_top [lindex $interfaces end] if {![string length $iid_top]} { @@ -4913,7 +4833,7 @@ proc ::p::-1::GetTopInterface {_ID_ args} { dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} proc ::p::-1::GetExpandableInterface {_ID_ args} { - + } @@ -4946,7 +4866,7 @@ proc ::p::-1::Property {_ID_ property args} { #create a new interface set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - + set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat $interfaces $iid_top] dict set MAP interfaces $extracted_sub_dict @@ -4959,27 +4879,27 @@ proc ::p::-1::Property {_ID_ property args} { set maxversion [::p::predator::method_chainhead $IID (GET)$property] set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + - if {$headid == 1} { #implementation #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - + #if {$o_varspace eq ""} { - # set ns ::p::${OID} + # set ns ::p::${OID} #} else { - # if {[string match "::*" $o_varspace]} { - # set ns $o_varspace - # } else { - # set ns ::p::${OID}::$o_varspace - # } + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } #} #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] - - + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] @@ -4987,56 +4907,56 @@ proc ::p::-1::Property {_ID_ property args} { #chainhead pointers interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - + + } if {($property ni [dict keys $o_methods])} { interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } + } - #installation on object + #installation on object - #namespace eval ::p::${OID} [list namespace export $property] + #namespace eval ::p::${OID} [list namespace export $property] #obsolete? - #if {$property ni [P $_ID_]} { - #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces - #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant - #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant - #} + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} #link main (GET)/(SET) to this interface - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property - interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - #Only install property if no method of same name already installed here. - #(Method takes precedence over property because property always accessible via 'set' reference) - #convenience pointer to chainhead pointer. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } else { - #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - - - } + + } set varspace [set ::p::${IID}::_iface::o_varspace] - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} dict set o_variables o_$property [list varspace $varspace] @@ -5051,10 +4971,10 @@ proc ::p::-1::Property {_ID_ property args} { dict set o_properties $property [list default $default varspace $varspace] #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] #} else { - # lappend o_properties [list $property $default] - #} + # lappend o_properties [list $property $default] + #} if {$varspace eq ""} { set ns ::p::${OID} @@ -5065,16 +4985,16 @@ proc ::p::-1::Property {_ID_ property args} { set ns ::p::${OID}::$o_varspace } } - + set ${ns}::o_$property $default #set ::p::${OID}::o_$property $default } else { - + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property]] + # set o_properties [lreplace $o_properties $posn $posn [list $property]] #} else { - # lappend o_properties [list $property] - #} + # lappend o_properties [list $property] + #} dict set o_properties $property [list varspace $varspace] @@ -5085,18 +5005,18 @@ proc ::p::-1::Property {_ID_ property args} { - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) - #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} - + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + set colProperties ::p::${OID}::_meta::>colProperties if {[namespace which $colProperties] ne ""} { if {![$colProperties . hasKey $property]} { $colProperties . add [::p::internals::predator $_ID_ . $property .] $property } } - - return + + return } ################################################################################################################################################### @@ -5131,7 +5051,7 @@ proc ::p::-1::PatternProperty {_ID_ property args} { set maxversion [::p::predator::method_chainhead $IID (GET)$property] set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 @@ -5141,12 +5061,12 @@ proc ::p::-1::PatternProperty {_ID_ property args} { proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - + #chainhead pointers interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - + } if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { @@ -5158,15 +5078,15 @@ proc ::p::-1::PatternProperty {_ID_ property args} { #Install the matching Variable #!todo - which should take preference if Variable also given a default? #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] + # set o_variables [lreplace $o_variables $posn $posn o_$property] #} else { - # lappend o_variables [list o_$property] + # lappend o_variables [list o_$property] #} dict set o_variables o_$property [list varspace $varspace] set argc [llength $args] - if {$argc} { + if {$argc} { if {$argc == 1} { set default [lindex $args 0] dict set o_properties $property [list default $default varspace $varspace] @@ -5210,93 +5130,93 @@ proc ::p::-1::PatternProperty {_ID_ property args} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} proc ::p::-1::PatternPropertyRead {_ID_ property args} { - set invocants [dict get $_ID_ i] - - set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' - set OID [lindex $this_invocant 0] - #set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } + set posn [lsearch $patterns $existing_IID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] if {$headid == 1} { - set headid 2 ;#reserve 1 for the getprop of the underlying property + set headid 2 ;#reserve 1 for the getprop of the underlying property } - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ - + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #implementation - if {![llength $idxlist]} { - proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body - } else { - #what are we trying to achieve here? .. - proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body - } + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } - #----------------------------------- + #----------------------------------- - #adjust chain-head pointer to point to new head. - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - return + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return } ################################################################################################################################################### @@ -5318,7 +5238,7 @@ dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} proc ::p::-1::PropertyRead {_ID_ property args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) lassign [dict get $MAP invocantdata] OID alias default_command cmd @@ -5351,7 +5271,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { } else { set prev_open [set ::p::${existing_IID}::_iface::o_open] set ::p::${IID}::_iface::o_open $prev_open - } + } namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] @@ -5367,7 +5287,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] #implement - #----------------------------------- + #----------------------------------- set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] if {[llength [dict get $processed varspaces_with_explicit_vars]]} { @@ -5381,12 +5301,12 @@ proc ::p::-1::PropertyRead {_ID_ property args} { set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. set body $varDecls[dict get $processed body] } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body - #----------------------------------- + #----------------------------------- @@ -5396,7 +5316,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property } } ################################################################################################################################################### @@ -5424,69 +5344,69 @@ proc ::p::-1::PropertyWrite {_ID_ property argname body} { upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias default_command cmd - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. - + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set posn [lsearch $interfaces $existing_IID] - set posn [lsearch $interfaces $existing_IID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #pw short for propertywrite - #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] - set maxversion [::p::predator::method_chainhead $IID (SET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (SET)$property.$headid - set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body - #----------------------------------- + #----------------------------------- - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid } ################################################################################################################################################### @@ -5508,40 +5428,38 @@ proc ::p::-1::PropertyWrite {_ID_ property argname body} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set existing_ifaces [lindex $map 1 1] - set posn [lsearch $existing_ifaces $existing_IID] + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] - #set ::p::${IID}::_iface::o_open 0 - } else { - } + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] - #pw short for propertywrite - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + #set ::p::${IID}::_iface::o_open 0 + } else { + } + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - - return + return } ################################################################################################################################################### @@ -5557,69 +5475,69 @@ proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set posn [lsearch $interfaces $existing_IID] - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] - set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid + set THISNAME (UNSET)$property.$headid - set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #note $arraykeypattern actually contains the name of the argument - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern _dontcare_ ;# - } - proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body - #----------------------------------- +#----------------------------------- - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid +#pointer from method-name to head of override-chain +interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid } ################################################################################################################################################### @@ -5636,34 +5554,34 @@ proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set posn [lsearch $patterns $existing_IID] - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #set ::p::${IID}::_iface::o_open 0 - } - - upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - return + return } ################################################################################################################################################### @@ -5680,31 +5598,30 @@ proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { #implementation reuse - sugar for >object .. Clone >target dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} proc ::p::-1::Extends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'Extends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Clone $object_command + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + tailcall $pattern .. Clone $object_command } #implementation reuse - sugar for >pattern .. Create >target dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} proc ::p::-1::PatternExtends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'PatternExtends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Create $object_command + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command } @@ -5714,7 +5631,7 @@ proc ::p::-1::Extend {_ID_ {idx ""}} { tailcall ::p::-1::Expand $_ID_ $idx } -#set the topmost interface on the iStack to be 'open' +#set the topmost interface on the iStack to be 'open' dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} proc ::p::-1::Expand {_ID_ {idx ""}} { set invocants [dict get $_ID_ i] @@ -5723,7 +5640,7 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces set iid_top [lindex $interfaces end] set iface ::p::ifaces::>$iid_top - + if {![string length $iid_top]} { #no existing interface - create a new one set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id @@ -5735,7 +5652,7 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { return $iid_top } else { if {[$iface . isOpen]} { - #already open.. + #already open.. #assume ready to expand.. shared or not! return $iid_top } @@ -5744,21 +5661,21 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { if {[$iface . refCount] > 1} { if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { #!warning! not exercised by test suites! - + #remove ourself from the usedby list of the previous interface array unset ::p::${iid_top}::_iface::o_usedby i$OID set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - #remove existing interface & add - set posn [lsearch $interfaces $iid_top] + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] dict set MAP interfaces $extracted_sub_dict #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - + set iid_top $IID - set iface ::p::ifaces::>$iid_top + set iface ::p::ifaces::>$iid_top } } } @@ -5783,7 +5700,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { ::p::map $OID MAP #puts stderr "no tests written for PatternExpand " lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces set iid_top [lindex $ifaces end] set iface ::p::ifaces::>$iid_top @@ -5800,7 +5717,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { return $iid_top } else { if {[$iface . isOpen]} { - #already open.. + #already open.. #assume ready to expand.. shared or not! return $iid_top } @@ -5811,7 +5728,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { #remove ourself from the usedby list of the previous interface array unset ::p::${iid_top}::_iface::o_usedby i$OID set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - + set posn [lsearch $ifaces $iid_top] set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] @@ -5820,7 +5737,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { set iid_top $IID set iface ::p::ifaces::>$iid_top - } + } } } @@ -5834,7 +5751,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} proc ::p::-1::Properties {_ID_ {idx ""}} { - set OID [lindex [dict get $_ID_ i this] 0 0] + set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces @@ -5867,11 +5784,11 @@ proc ::p::-1::P {_ID_ {glob *}} { upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] + set members [list] foreach IID $interfaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] } - return [lsort $members] + return [lsort $members] } #PatternProperties @@ -5884,11 +5801,11 @@ proc ::p::-1::PP {_ID_ {glob *}} { upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set members [list] + set members [list] foreach IID $interfaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] } - return [lsort $members] + return [lsort $members] } @@ -5896,71 +5813,71 @@ proc ::p::-1::PP {_ID_ {glob *}} { #Interface Properties dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} proc ::p::-1::IP {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] - - foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { - if {[string match $glob [lindex $m 0]]} { - lappend members [lindex $m 0] - } - } - return $members + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members } #used by rename.test - theoretically should be on a separate interface! dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} proc ::p::-1::CheckInvocants {_ID_ args} { - #check all invocants in the _ID_ are consistent with data stored in their MAP variable - set status "ok" ;#default to optimistic assumption - set problems [list] - - set invocant_dict [dict get $_ID_ i] - set invocant_roles [dict keys $invocant_dict] - - foreach role $invocant_roles { - set invocant_list [dict get $invocant_dict $role] - foreach aliased_invocantdata $invocant_list { - set OID [lindex $aliased_invocantdata 0] - set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] - #we use lrange to make sure the lists are in canonical form - if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { - set status "not-ok" - lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] - } - } - - } - - - set result [dict create] - dict set result status $status - dict set result problems $problems - - return $result + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result } #get or set t dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} proc ::p::-1::Namespace {_ID_ args} { - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set IID [lindex [dict get $MAP interfaces level0] end] - - namespace upvar ::p::${IID}::_iface o_varspace active_varspace - - if {[string length $active_varspace]} { - set ns ::p::${OID}::$active_varspace - } else { - set ns ::p::${OID} - } + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? # - should .. Namespace be usable at all from outside the object? @@ -6003,33 +5920,33 @@ proc ::p::-1::PatternUnknown {_ID_ args} { set invocants [dict get $_ID_ i] set OID [lindex [dict get $invocants this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - #::p::predator::remap $invocant - } - - set handlermethod [lindex $args 0] - - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } } @@ -6041,58 +5958,58 @@ proc ::p::-1::Unknown {_ID_ args} { set OID [lindex [dict get $invocants this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - set prev_open [set ::p::${existing_IID}::_iface::o_open] + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set posn [lsearch $interfaces $existing_IID] + set posn [lsearch $interfaces $existing_IID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_open - } + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } - set handlermethod [lindex $args 0] + set handlermethod [lindex $args 0] - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - #set ::p::${IID}::(unknown) $handlermethod + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod - interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] #namespace eval ::p::${OID} [list namespace unknown $handlermethod] - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } } #useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' -# should also work for non-object results +# should also work for non-object results dict set ::p::-1::_iface::o_methods As {arglist {varname}} proc ::p::-1::As {_ID_ varname} { set invocants [dict get $_ID_ i] #puts stdout "invocants: $invocants" #!todo - handle multiple invocants with other roles, not just 'this' - + set OID [lindex [dict get $_ID_ i this] 0 0] if {$OID ne "null"} { upvar #0 ::p::${OID}::_meta::map MAP @@ -6143,8 +6060,8 @@ proc ::p::-1::AsFile {_ID_ filename args} { } } set fd [open $filename w] - fconfigure $fd -translation binary - + fconfigure $fd -translation binary + set invocants [dict get $_ID_ i] set OID [lindex [dict get $_ID_ i this] 0 0] if {$OID ne "null"} { @@ -6178,7 +6095,7 @@ proc ::p::-1::AsFile {_ID_ filename args} { #tailcall set $varname $resultlist } } - + } @@ -6190,58 +6107,58 @@ proc ::p::-1::Object {_ID_} { upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set result [string map [list ::> ::] $cmd] - if {![catch {info level -1} prev_level]} { - set called_by "(called by: $prev_level)" - } else { - set called_by "(called by: interp?)" + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } - } - - puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" - puts stdout " (returning $result)" + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" - return $result + return $result } #todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname -dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} proc ::p::-1::MakeAlias {_ID_cmdname } { set OID [::p::obj_get_this_oid $_ID_] upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " } dict set ::p::-1::_iface::o_methods ID {arglist {}} proc ::p::-1::ID {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - return $OID + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID } dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} proc ::p::-1::IFINFO {_ID_} { - puts stderr "--_ID_: $_ID_--" - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - - puts stderr "-- MAP: $MAP--" - - set interfaces [dict get $MAP interfaces level0] - set IFID [lindex $interfaces 0] - - if {![llength $interfaces]} { - puts stderr "No interfaces present at level 0" - } else { - foreach IFID $interfaces { - set iface ::p::ifaces::>$IFID - puts stderr "$iface : [$iface --]" - puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" - set variables [set ::p::${IFID}::_iface::o_variables] - puts stderr "\tvariables: $variables" - } - } - + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + } @@ -6249,81 +6166,81 @@ proc ::p::-1::IFINFO {_ID_} { dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} proc ::p::-1::INVOCANTDATA {_ID_} { - #same as a call to: >object .. - return $_ID_ + #same as a call to: >object .. + return $_ID_ } #obsolete? dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { - set updated_ID_ $_ID_ - array set updated_roles [list] - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - foreach role $invocant_roles { - - set role_members [dict get $invocants $role] - foreach member [dict get $invocants $role] { - #each member is a 2-element list consisting of the OID and a dictionary - #each member is a 5-element list - #set OID [lindex $member 0] - #set object_dict [lindex $member 1] - lassign $member OID alias itemcmd cmd wrapped - - set MAP [set ::p::${OID}::_meta::map] - #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} - - if {[dict get $MAP invocantdata] eq $member} - #same - nothing to do - - } else { - package require overtype - puts stderr "---------------------------------------------------------" - puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" - set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] - puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" - puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" - puts stderr "---------------------------------------------------------" - #take _meta::map version - lappend updated_roles($role) [dict get $MAP invocantdata] - } - - } - - #overwrite changed roles only - foreach role [array names updated_roles] { - dict set updated_ID_ i $role [set updated_roles($role)] - } - - return $updated_ID_ + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ } - + dict set ::p::-1::_iface::o_methods INFO {arglist {}} proc ::p::-1::INFO {_ID_} { - set result "" - append result "_ID_: $_ID_\n" - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - append result "invocant roles: $invocant_roles\n" - set total_invocants 0 - foreach key $invocant_roles { - incr total_invocants [llength [dict get $invocants $key]] - } - - append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" - foreach key $invocant_roles { - append result "\t-------------------------------\n" - append result "\trole: $key\n" - set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants - append result "\t Raw data for this role: $role_members\n" - append result "\t Number of invocants in this role: [llength $role_members]\n" - foreach member $role_members { - #set OID [lindex [dict get $invocants $key] 0 0] - set OID [lindex $member 0] + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] append result "\t\tOID: $OID\n" if {$OID ne "null"} { upvar #0 ::p::${OID}::_meta::map MAP @@ -6344,16 +6261,16 @@ proc ::p::-1::INFO {_ID_} { lassign $member _OID namespace default_method stackvalue _wrapped append result "\t\t last item on the predator stack is a value not an object" append result "\t\t Value is: $stackvalue" - + } - } - append result "\n" - append result "\t-------------------------------\n" - } - - - - return $result + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result } @@ -6371,52 +6288,52 @@ proc ::p::-1::Rename {_ID_ args} { - #puts ">>.>> Rename. _ID_: $_ID_" + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" - if {[catch { + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata - if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { - - #appears to be a 'trace command rename' firing - #puts "\t>>>> rename trace fired $MAP $args <<<" - lassign $args oldcmd newcmd - set extracted_invocantdata [dict get $MAP invocantdata] - lset extracted_invocantdata 3 $newcmd - dict set MAP invocantdata $extracted_invocantdata + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped - - lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - #Write the same info into the _ID_ value of the alias - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - - - - #! $object_command was initially created as the renamed alias - so we have to do it again - uplevel 1 [list rename $alias $object_command] - trace add command $object_command rename [list $object_command .. Rename] - } elseif {[llength $args] == 1} { - #let the rename trace fire and we will be called again to do the remap! - uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] - } else { - error "Rename expected \$newname argument ." - } - } errM]} { - puts stderr "\t@@@@@@ rename error" - set ruler "\t[string repeat - 80]" - puts stderr $ruler - puts stderr $errM - puts stderr $ruler - - } + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return - return - } proc ::p::obj_get_invocants {_ID_} { diff --git a/src/vendormodules/patterncipher-0.1.1.tm b/src/vendormodules/patterncipher-0.1.1.tm new file mode 100644 index 00000000..62b03cbc --- /dev/null +++ b/src/vendormodules/patterncipher-0.1.1.tm @@ -0,0 +1,1459 @@ +#JMN 2021 +#public domain + + +#--------------------------------------------------------- +#todo - see if we can include twofish https://wiki.tcl-lang.org/page/Twofish+in+Tcl +# - that twofish implementation relies on Itcl. todo - create .tm package for it. (change oo system?) +#--------------------------------------------------------- +# +# encryption decryption howto + +# patternciper::>AES .. Create >obj +# set [>obj . cipherkey .] $16bytes +# >obj . encrypt $arbitray_data_of_any_length +# (returns number of bytes stored) +# +# >obj . encrypt $any_size_string -last 1 +# (the -last flag will make the encryption system pad the last chunk) +# >obj . ciphertext .. As my_encrypted_data_variable +# set checkplaintext [>obj . decrypt] +# (this can be used to verify decryption and resets the cbc encryption ready for another round) +# +# + + +package provide patterncipher [namespace eval patterncipher { + variable version + set version 0.1.1 +}] + + + +#Change History +#------------------------------------------------------------------------------- +# 2021 - start out with blowfish as although it's outdated, it's easily available in tcllib. Todo - add twofish, AES +#------------------------------------------------------------------------------- + +package require ascii85 ;#tcllib +package require pattern +::pattern::init ;# initialises (if not already) + +namespace eval ::patterncipher { + namespace eval algo::txt { + set tokenid 0 + set tokendata [dict create] + set data_block_bytes 0 ;#means don't care + set iv_bytes 16 + set key_byte_sizes [list 8 16] + + + proc Init {mode keydata iv} { + variable tokenid + variable tokendata + if {[string length $iv] != 16} { + error "[namespace::current] Init IV must be 16 bytes long" + } + + dict set tokendata $tokenid [list mode $mode key $keydata iv $iv lastblock "" ] + return [lindex [list [namespace current]::$tokenid [incr tokenid]] 0] ;#post increment via inline K combinator + } + proc Encrypt {token data} { + variable tokendata + variable data_block_bytes + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Encrypt) invalid tokenid $tokenid token:$token" + } + if {$data_block_bytes != 0} { + if {([string length $data] % $data_block_bytes) != 0} { + error "([namespace current]::Encrypt) invalid block size for data. Must be $data_block_bytes bytes." + } + set idx [expr {$data_block_bytes - 1}] + dict set tokendata $tokenid lastblock [string range $data end-$idx end] + } + set client_mode [dict get $tokendata $tokenid mode] + set iv_as_mode [string trim [dict get $tokendata $tokenid iv] _] + + + + if {$iv_as_mode ne $client_mode} { + set enc [encoding convertto $iv_as_mode [encoding convertfrom $client_mode $data]] + } else { + set enc [encoding convertfrom $client_mode $data] + } + + return $enc + } + proc Decrypt {token data} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Decrypt) invalid tokenid $tokenid token:$token" + } + set client_mode [dict get $tokendata $tokenid mode] + set iv_mode [string trim [dict get $tokendata $tokenid iv] _] + + if {$iv_mode ne $client_mode} { + set dec [encoding convertfrom $iv_mode $data] + } else { + set dec $data + } + set dec [encoding convertto $client_mode $dec] + + return $dec + } + proc Reset {token iv} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Reset) invalid tokenid $tokenid token:$token" + } + dict set tokendata $tokenid lastblock "" + + } + proc Final {token} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Final) invalid tokenid $tokenid token:$token" + } + dict unset tokendata $tokenid + } + } + +} + +namespace eval ::patterncipher { + #namespace export {[a-z]*} + #namespace export {[>]*} + proc help {} { + set cipherlib ::patterncipher::libs::>lib_standard + set definitions [$cipherlib . cipher_definitions] + set m "" + append m "\n" + append m "Create cipher-specific objects with name of your choosing for encryption and decryption:\n" + + foreach cn [$cipherlib . ciphernames] { + append m "patterncipher::>$cn .. Create >my-[dict get $definitions $cn cipherid]-encryptor\n" + } + + append m "\n" + append m "--------------------------------------------------------------------------------------------------\n" + append m "Get cipher specific help e.g patterncipher::>blowfish, patterncipher::>AES etc :\n" + append m "patterncipher::>AES . help ;#patterncipher::>AES is the prototype from which we create objects.\n" + append m " ;# The prototype itself has a help method which is not inherited by objects created from it\n" + } + + + + namespace eval libs {} ;#namespace for >lib instances + + + patternlib::>collection .. Create >libs + + >pattern .. Create >lib + >lib .. Method help {} { + set help { + To create a custom library: +::patterncipher::>lib .. Create ::patterncipher::libs::>my-lib -name "mylib" .. As mylib + or +set mylib [::patterncipher::>lib .. Create ::patterncipher::libs::>my-lib -name "mylib"] + + The object will automatically be added to the collection ::patterncipher::>libs + The latest element added to this collection will be the one used by new cipher instances. + To create a cipher using a specific >lib instance, use -patterncipherlib when constructing instances + + } + return $help + } + + >lib .. PatternProperty name + >lib .. PatternPropertyWrite name {newname} { + var o_name + if {$o_name eq "standard"} { + #!todo - allow -force option in case caller knows what they're doing? + error "(>lib-instance . name (write)) ERROR: cannot rename 'standard' library." + } + ::patterncipher::>libs . reKey $o_name $newname + set o_name $newname + } + + >lib .. Constructor {args} { + var this o_name o_padding_schemes o_bucketsize_by_hex1 o_ascii85_wraplen + var o_frame_boundaries o_hex1_by_bucketsize o_bucketsize_by_hex4 o_hex4_by_bucketsize + var o_cipher_definitions o_cipherids + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -name] + dict set default -name "" + if {([llength $args] % 2) != 0} { + error "(>lib-instance .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((>lib-instance .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_name [dict get $opts -name] + #---------------------------------------------------------------------------- + if {![string length $o_name]} { + error "((>lib-instance .. Constructor) ERROR: -name value is required." + } + + if {[::patterncipher::>libs . hasKey $o_name]} { + error "((>lib-instance .. Constructor) ERROR: -name value is already in the ::patterncipher::>libs collection - choose another name." + } + + ::patterncipher::>libs . add ::patterncipher::libs::>lib_standard $o_name ;# now avail as '::patterncipher::>libs $o_name' + + #Once the standard lib is in the collection, overlay a >keayvalprotector on >libs to stop the standard lib being removed too easily + if {$o_name eq "standard"} { + ::patternlib::>keyvalprotector .. Create ::patterncipher::>libs -keys [list standard] -vals [list $this] + } + + #----------------------------------------------------------------------------------------------------- + #set up stream chunk boundaries + #64 bytes selected as the smallest chunk size. Obfuscates lengths for small pieces of data - plus 5Byte header overhead not too bad. + ## starting data - redistributed + ##set block1 [list 512 512 512 512 512 512 512 512] + ##set block2 [list 1024 1024 1024 1024] + ##set block3 [list 2048 2048] + set block1 [list 64 192 320 448 576 704 832 960 ] ; #128 spacing + set block2 [list 976 1008 1040 1072] ;# 32 spacing + set block3 [list 1984 2112] ;#128 spacing + set block4 [list 4096] + # 4096 4096 4096 ... repeated until final chunk detected. + #This gives 15 values. Hex 1 to F, leaving 0 for the final arbitrary length rest-of-stream. + # ie 64 = 1 192 = 2 ... 1040 = B 4096 = F + + #If the blocks above are played with - streaming incompatibilities/inefficiences will occur with previous/other versions of patterncipher. + set code_check 1 + if $code_check { + set o_frame_boundaries [concat $block1 $block2 $block3 $block4] + foreach l [list $block1 $block2 $block3 ] { + if {[expr [join $l +]] != 4096} { + error "frame_boundaries list is not configured as a 4096 multiple" + } + } + if {![expr [join $o_frame_boundaries +]] == 16384} { + #This boundary sequence that should be a multiple of 4K. + error "frame_boundaries list is not configured as a 4096 multiple" + } + foreach len $o_frame_boundaries { + if {($len % 8) != 0} { + error "stream boundary '$len' is not a multiple of 8 bytes" + } + } + } + #set up bucketids + set bucket_hex4 [list] + foreach len $o_frame_boundaries { + lappend bucket_hex4 [format %04x $len] ;# e.g 192 = 00c0 4096 = 1000 + } + + set o_bucketsize_by_hex1 [concat {*}[lmap c {1 2 3 4 5 6 7 8 9 A B C D E F} s $o_frame_boundaries {list $c $s}]] ;#dict + set o_bucketsize_by_hex4 [concat {*}[lmap h $bucket_hex4 s $o_frame_boundaries {list $h $s}]] ;#dict + + set o_hex1_by_bucketsize [concat {*}[lmap s $o_frame_boundaries c {1 2 3 4 5 6 7 8 9 A B C D E F} {list $s $c}]] ;#dict + set o_hex4_by_bucketsize [concat {*}[lmap s $o_frame_boundaries h $bucket_hex4 {list $s $h}]] ;#dict + + + set o_padding_schemes [list 0 text-minpad 1 text-buckets 2 binary-minpad 3 binary-buckets] + #whichever padding_scheme is used, the frame_boundaries will still be used to determine where to split the data + set o_ascii85_wraplen 120 + + + #------------------ + #For cipherid "TXT" + #pull out desired default encoding and put it at the front of the list + set encnames [encoding names] + set default "utf-8" ;#must be one that's in the list + set idx [lsearch $encnames $default] + set encnames [lreplace $encnames $idx $idx] + set encnames [concat $default $encnames] + #------------------ + + #---------------------------------------------------- + #iv_static should only be 1 for testing, or for specific definitions such as 'TXT' which use IV to carry the text encoding hint. + # + #notes: + #- always list the default mode first in modes + #- iv_method is a method with arguments of the patterncipher library. + # New methods can be grafted onto the lib as necessary. + # The argument %ivb will be substituted with iv_bytes value + # The argument %cn will be substituted with the key used in o_cipher_definitions + # (this could then be used in a method to retrieve any of the other defined values) + # The iv_method must be able to handle -userdata user-supplied IV data (or empty string if none). + # Can be verified/ignored etc. + #- cipherid must be 3 bytes long and is used in the default header building mechanism + # !todo - add a member such as 'hdr_method' to allow the lib to define a totally different header system. + #- pkgrequire & algocommand together define the underlying encryption library command. + # This must provide the API as used by various tcllib encryption functions such as AES & blowfish + # A custom algocommand e.g some commands placed in '::patterncipher::algo::' may be able to wrap other + # libraries/functionalities if the semantics are not too dissimilar. + # The API used by the tcllib encryption functions has commands: Init,Encrypt,Decrypt,Reset,Final. + # + set o_cipher_definitions [dict create] + dict set o_cipher_definitions "text" [list \ + enabled 1\ + cipherid "TXT" \ + pkgrequire patterncipher\ + algocommand ::patterncipher::algo::txt\ + data_block_bytes 0\ + iv_bytes 16\ + iv_static 1\ + iv_method [list get_iv_for_ciphername %cn]\ + key_byte_sizes [list 8]\ + modes $encnames\ + ] + + dict set o_cipher_definitions "blowfish" [list \ + enabled 1\ + cipherid "BFS" \ + pkgrequire blowfish\ + algocommand ::blowfish\ + data_block_bytes 8\ + iv_bytes 8\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic ]\ + key_byte_sizes [list 8]\ + modes [list cbc ecb]\ + ] + + dict set o_cipher_definitions "AES" [list \ + enabled 1\ + cipherid "AES"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 16 24 32]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-128" [list \ + enabled 1\ + cipherid "A16"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 16]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-192" [list \ + enabled 1\ + cipherid "A24"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 24]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-256" [list \ + enabled 1\ + cipherid "A32"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 32]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "DES" [list \ + enabled 1\ + cipherid "DES"\ + pkgrequire des\ + algocommand ::DES\ + data_block_bytes 8\ + iv_bytes 8\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 8 32]\ + modes [list cbc ecb cfb ofb]\ + ] + + $this . rebuild_cipher_ids_and_names + + puts stdout "padding_buckets hex1code: $o_bucketsize_by_hex1" + puts stdout "padding_buckets hex4code: $o_bucketsize_by_hex4" + #----------------------------------------------------------------------------------------------------- + } + + >lib .. PatternMethod cipher_disable {ciphername} { + var this o_cipher_definitions + if {$ciphername ni [dict keys $o_cipher_definitions]} { + error "(>lib . cipher_disable) ciphername $ciphername not in list of defined ciphers: [dict keys $o_cipher_definitions]" + } + dict set o_cipher_definitions $ciphername enabled 0 + $this . rebuild_cipher_ids_and_names + return 1 + } + + >lib .. PatternMethod cipher_enable {ciphername} { + var o_cipher_definitions + if {$ciphername ni [dict keys $o_cipher_definitions]} { + error "(>lib . cipher_enable) ciphername $ciphername not in list of defined ciphers: [dict keys $o_cipher_definitions]" + } + dict set o_cipher_definitions $ciphername enabled 1 + $this . rebuild_cipher_ids_and_names + return 1 + } + >lib .. PatternMethod rebuild_cipher_ids_and_names {} { + var o_cipherids o_ciphernames o_cipher_definitions + set o_cipherids [list] + set o_ciphernames [list] + foreach k [dict keys $o_cipher_definitions] { + if {[dict get $o_cipher_definitions $k enabled]} { + lappend o_cipherids [dict get $o_cipher_definitions $k cipherid] + lappend o_ciphernames $k + } + } + return $o_cipherids + } + + >lib .. PatternProperty cipher_definitions [dict create] + + #the cipherids must be 3 bytes - to form part of the ciphertexts 8byte header. e.g BFS = blowfish has headers like 1BFSC42E + >lib .. PatternProperty cipherids [list] + >lib .. PatternProperty ciphernames [list] + + >lib .. PatternProperty padding_schemes + >lib .. PatternProperty ascii85_wraplen + + >lib .. PatternProperty frame_boundaries + >lib .. PatternPropertyWrite frame_boundaries {boundarylist} { + var o_name o_frame_boundaries + if {$o_name eq "standard"} { + error "(>lib-instance . frame_boundaries (write)) ERROR: frame_boundaries is read-only. Create a new patterncipher::>lib object for different behaviour" + } + set o_frame_boundaries $boundarylist + } + >lib .. PatternProperty hex1_by_bucketsize + >lib .. PatternPropertyWrite hex1_by_bucketsize {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . hex1_by_bucketsize (write)) ERROR: hex1_by_bucketsize is read-only." + } + >lib .. PatternProperty bucketsize_by_hex1 + >lib .. PatternPropertyWrite bucketsize_by_hex1 {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . bucketsize_by_hex1 (write)) ERROR: hex1_by_bucketsize is read-only." + } + + >lib .. PatternProperty hex4_by_bucketsize + >lib .. PatternPropertyWrite hex4_by_bucketsize {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . hex4_by_bucketsize (write)) ERROR: hex4_by_bucketsize is read-only." + } + >lib .. PatternProperty bucketsize_by_hex4 + >lib .. PatternPropertyWrite bucketsize_by_hex4 {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . bucketsize_by_hex4 (write)) ERROR: hex4_by_bucketsize is read-only." + } + + #K can be used by some cipher_definitions to set the iv to a string - alternatively - lindex [list "value" _dontcare] 0 + #also it is known as the K combinator + >lib .. PatternMethod K {a args} {set a} + + + >lib .. PatternMethod get_iv_for_ciphername {cname args} { + #any specific customizations we need to get an IV for a specific cipher + var this o_cipher_definitions + #---------------------------------------------------------------------------- + set known_args [list -userdata] + if {([llength $args] % 2) != 0} { + error "(get_iv_for_ciphername) ERROR: odd number of options supplied. Usage: '. get_iv_for_ciphername \$ciphername \[-option val\]*' where -option one of '$known_args' " + } + if {[llength $args]} { + foreach {a b} $args { + if {$a ni $known_args} { + error "(get_random_bytes) ERROR: unknown option '$a'. Usage: '. get_iv_for_ciphername \$ciphername \[-option val\]*' where -option one of '$known_args' " + } + } + } + dict set default -userdata "" + set opts [dict merge $default $args] + set userdata [dict get $opts -userdata] + #---------------------------------------------------------------------------- + + + set ivb [dict get $o_cipher_definitions $cname iv_bytes] + switch $cname { + "text" { + if {![string length $userdata]} { + set m [lindex [dict get $o_cipher_definitions $cname modes] 0] + if {![string length $m]} { + error "($this get_iv_for_ciphername) Error: can't calculate IV" + } + set iv "$m[string repeat _ $ivb]" + set iv [string range $iv 0 $ivb-1] + # e.g "utf-8___________" + return $iv + } else { + if {[string length $userdata] == $ivb} { + #assume they know what they're doing if length exactly right and pass through as is + return $userdata + } else { + #It's valid to supply an encoding name such as utf-8 or unicode - check that the system knows it first though + if {$userdata in [dict get $o_cipher_definitions $cname modes]} { + set iv "$userdata[string repeat _ $ivb]" + return [string range $iv 0 $ivb-1] + } else { + error "($this get_iv_for_ciphername) Error: can't calculate IV from user supplied data '$userdata'" + } + } + } + } + default { + return [$this . get_random_bytes $ivb -userdata $userdata] + } + } + } + + >lib .. PatternVariable o_get_random_bytes_calls 0 ;#additional data for random seed values - ensure no two calls have same seed even if called in quick succession. + >lib .. PatternMethod get_random_bytes {len args} { + var o_get_random_bytes_calls + incr o_get_random_bytes_calls + #puts stdout "get_random_bytes call:$o_get_random_bytes_calls" + + #---------------------------------------------------------------------------- + set known_args [list -method -ascii85 -userdata] + if {([llength $args] % 2) != 0} { + error "(get_random_bytes) ERROR: odd number of options supplied. Usage: '. get_random_bytes \$numbytes \[-option val\]*' where -option one of '$known_args' " + } + if {[llength $args]} { + foreach {a b} $args { + if {$a ni $known_args} { + error "(get_random_bytes) ERROR: unknown option '$a'. Usage: '. get_random_bytes \$numbytes \[-option val\]*' where -option one of '$known_args' " + } + } + } + dict set default -method basic + dict set default -ascii85 0 + dict set default -userdata "" + set opts [dict merge $default $args] + set method [dict get $opts -method] + set ascii85 [dict get $opts -ascii85] + set userdata [dict get $opts -userdata] + #---------------------------------------------------------------------------- + + + set known_methods [list basic] + switch [string tolower $method] { + "basic" { + #considered cryptographically insecure. + #pick $len numbers 0 to 255 + set seed [clock seconds] + append seed [clock clicks] $o_get_random_bytes_calls [pid] + #!todo - add some unpredictable things to the seed. + expr {srand($seed)} ;#srand seems to be able to handle artibrarily large numbers + set bytelist [list] + for {set i 0} {$i < $len} {incr i} { + lappend bytelist [expr {int(rand()*256)}] ;# 0 to 255 + } + #puts stdout ">>bytelist $bytelist" + if {$ascii85} { + #Note. Do not wrap here. (e.g do not use o_ascii85_wraplen). Manually do it later so linebreaks in final result are consistent. + # - also, ascii85::encode uses regular expressions where maxlen can't be > 256 + set random_binstr [binary format c$len $bytelist] + #always truncate to proper length before encoding.. + set combined [string range $userdata$random_binstr 0 $len-1] + + set text [ascii85::encode -maxlen 0 $combined] + return [string range $text 0 $len-1] ;#truncate again in case it grew + } else { + + set random_binstr [binary format c${len} $bytelist] + + return [string range $userdata$random_binstr 0 $len-1] + } + } + default { + error "(get_random_bytes) ERROR: Unknown randomisation method '$method'. Expected one of '$known_methods'" + } + } + } + >lib .. PatternMethod get_bucket_info {size_of_ascii85} { + var o_frame_boundaries o_hex1_by_bucketsize o_hex4_by_bucketsize + set hex1 F ;#default if no other code matched - means 'Final' and payload limit of 4080 + set hex4 00 ;#Final - and payload limit of 65535 + set size 0 ;#indicates unspecified/unlimited + foreach bucketsize $o_frame_boundaries { + if {$size_of_ascii85 < $bucketsize} { + set hex1 [dict get $o_hex1_by_bucketsize $bucketsize] + set hex4 [dict get $o_hex4_by_bucketsize $bucketsize] + set size $bucketsize + break + } + } + puts stdout "... get_bucket_info [list hex1 $hex1 hex4 $hex4 size $size]" + return [list hex1 $hex1 hex4 $hex4 size $size] + } + >lib .. Create ::patterncipher::libs::>lib_standard -name "standard" + +} + + +namespace eval ::patterncipher { + +#--------------------------------------------------------------------------- + #overlay/mixin - (created in constructor) these also become properties on the >blowfish/>aes instances + # - + # - These are cipher-specific settings not intended to be user configurable. + >pattern .. Create >cipher_bytesizes + >cipher_bytesizes .. Constructor {args} { + var this o_data_block_bytes o_iv_bytes o_key_byte_sizes o_spud + set this @this@ + puts stdout "---->cipher_bytesizes Constructor running with args $args creating $this" + #---------------------------------------------------------------------------- + set known_opts [list] + set required_opts [list] + set default [dict create] + #dict set default -something etc + if {([llength $args] % 2) != 0} { + error "($this . Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(($this . Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + foreach o $required_opts { + if {$o ni $args} { + error "(($this . Constructor) ERROR: the following options are not actually optional: '$required_opts'" + } + } + set opts [dict merge $default $args] + #---------------------------------------------------------------------------- + + } + #Hidden - variables with PropertyRead and/or PropertyWrite become a hidden property + # readonly & hidden + >cipher_bytesizes .. PatternVariable o_data_block_bytes + >cipher_bytesizes .. PatternPropertyRead data_block_bytes {} { + var o_data_block_bytes + return $o_data_block_bytes + } + + #readonly & hidden + >cipher_bytesizes .. PatternVariable o_iv_bytes + >cipher_bytesizes .. PatternPropertyRead iv_bytes {} { + var o_iv_bytes + return $o_iv_bytes + } + + #readonly and visible + >cipher_bytesizes .. PatternProperty key_byte_sizes + >cipher_bytesizes .. PatternPropertyWrite key_byte_sizes {not_writable} { + var this + error "($this . key_byte_sizes (write)) ERROR: property key_byte_sizes is read only." + } + + #--------------------------------------------------------------------------- + + + +} + + +namespace eval ::patterncipher { + + + #mixin via Clone mechanism to the >cipher prototype + ::patterncipher::>cipher_bytesizes .. Clone [namespace current]::>ciphermaster + + + >ciphermaster .. Construct {} { + var this + set this @this@ + } + >ciphermaster .. Method help {} { + var this o_ciphername + set this @this@ + #o_data_block_bytes o_iv_bytes o_key_byte_sizes + set cipherlib ::patterncipher::libs::>lib_standard + set cipherdefs [$cipherlib . cipher_definitions] + set key_byte_sizes [dict get $cipherdefs $o_ciphername key_byte_sizes] + set data_block_bytes [dict get $cipherdefs $o_ciphername data_block_bytes] + + #a sample key of correct length for first key size in $key_byte_sizes + set longkey "8BYTES1\]8BYTES2\]8BYTES3\]8BYTES4\]8BYTES5\]8BYTES6\]8BYTES7\]8BYTES8\]" + set keysample [string range $longkey 0 [lindex $key_byte_sizes 0]-1] + + set help { + + patterncipher::>object .. Create >b1 + set [>b1 . key .] %kb1 ;#encipherment key. Allowed number of bytes: '%kbs%' + >b1 . encrypt \$something ;#chunks added don't have to be multiple of %dbs% bytes + >b1 . encrypt \"some-data-123\" ;# - they will be buffered,concatenated and finally padded. + >b1 . encrypt "\[command yielding data\]" -last 1 ;# '. encrypt -last 1' can take empty string if needed + ;# - alternatively you can call '. encryptlast' or '. encryptlast $lastchunk' instead + set encrypted_data [>b1 . ciphertext] ;# defaults to hex encoded + set raw_encrypted_data [>b1 . ciphertext -raw 1] ;# binary output + set verify [>b1 . decrypt_and_reset] ;# Only after calling this ( or '. reset' ) + ;# - can we start a new encrypting/decrypting cycle + + -------------------------------------------------------------------------------------------------------- + #To decrypt: + set [>b1 . ciphertext .] $encrypted_data ;# expects hex encoded, with 8-char header e.g '0BFS0FFF' + set plaintext [>b1 . decrypt_and_reset] + + } + set help [string map [list ">object" >$o_ciphername ">b1" >${o_ciphername}-instance %kb1 $keysample %kbs% $key_byte_sizes %dbs% $data_block_bytes] $help] + } + + + >ciphermaster .. Constructor {args} { + var this o_patterncipherlib o_ciphername + set this @this@ + puts stdout "(>cipher $this .. Constructor) running with args $args creating $this vars:[info vars]" + #---------------------------------------------------------------------------- + set known_opts [list -patterncipherlib] + dict set default -patterncipherlib [::patterncipher::>libs -1 ] ;#last item added to the >libs collection + if {([llength $args] % 2) != 0} { + error "(>cipher $this .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((>cipher $this .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_patterncipherlib [dict get $opts -patterncipherlib] + #---------------------------------------------------------------------------- + + $this . _init_cipher_from_definitions $o_ciphername + #set [$this . ciphername .] $o_ciphername + + + #run the next constructor (from object cloned onto this one) + #var o_data_block_bytes o_iv_bytes o_key_byte_sizes + puts stderr ">>>>>> here <<<" + #@next@ -data_block_bytes $o_data_block_bytes -iv_bytes $o_iv_bytes -key_byte_sizes $o_key_byte_sizes + #mixin + #$this .. PatternExpand + #::patterncipher::>cipher_bytesizes .. Create $this -data_block_bytes 8 -iv_bytes 8 -key_byte_sizes [list 8] + } + + + #We won't have private methods until the interface mechanism of patternpunk is settled. :/ + >ciphermaster .. PatternMethod _init_cipher_from_definitions {name} { + #don't declare any vars - so we get them all (?) + set definitions [$o_patterncipherlib . cipher_definitions] + set pkgname [dict get $definitions $name pkgrequire] + #! todo - add option to require exact version? + if {[catch {package require $pkgname} errMsg]} { + error "($this . ciphername (prop write)) unable to load package '$pkgname' for ciphername '$name' err: $errMsg" + } + set o_algocommand [dict get $definitions $name algocommand] + set o_cipherid [dict get $definitions $name cipherid] + set o_data_block_bytes [dict get $definitions $name data_block_bytes] + set o_iv_bytes [dict get $definitions $name iv_bytes] + set o_iv_static [dict get $definitions $name iv_static] + set o_iv_method [string map [list %ivb $o_iv_bytes %cn $name] [dict get $definitions $name iv_method]] + set o_key_byte_sizes [dict get $definitions $name key_byte_sizes] + set o_ciphermodes [dict get $definitions $name modes] + set o_mode [lindex $o_ciphermodes 0] + set o_ciphername $name + puts stdout "init_cipher_from_definitions running in [namespace current]" + } + + + >ciphermaster .. PatternProperty ciphername + >ciphermaster .. PatternPropertyWrite ciphername {name} { + var this o_patterncipherlib o_ciphername o_cipherid o_mode o_ciphertoken o_cipherbin + var o_data_block_bytes o_iv_bytes o_iv_static o_iv_method o_key_byte_sizes o_algocommand o_ciphermodes + + set definitions [$o_patterncipherlib . cipher_definitions] + + if {$name ni [dict keys $definitions]} { + puts stdout "known ciphernames: [dict keys $definitions]" + error "($this . ciphername (prop write)) cipher '$name' not known in this patterncipherlib: $o_patterncipherlib" + } + + if {[string length $o_cipherbin]} { + $this . ciphertext_header_info [string range $o_cipherbin 0 9] .. As header_info + if {[dict get $header_info status] != 1} { + error "($this . reset) Cannot reset IV while there is unfinalised ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + } + + + if {[string length $o_ciphername]} { + if {$name ne $o_ciphername} { + #changing from one cipher to another + + + if {[string length $o_ciphertoken]} { + $this . abandon + + #if {[catch {${o_algocommand}::Final $o_ciphertoken} errMsg]} { + # puts stderr "($this . ciphername (prop write)) changing ciphername $o_ciphername to $name . err calling Final with previous token $o_ciphertoken. Err: $errMsg" + #} + } + + } else { + #same name as before - warning because this is the wrong way to reset - if that's what was intended. + #puts stderr "($this . ciphername (prop write)) WARNING ciphername is already '$name'" + # constructor legitimately does this though - and in that case we need to run the reset operations below + + } + } + + #loads packages and sets vars + $this . _init_cipher_from_definitions $name + + + set o_ciphername $name + + #$this . reset + return $name + } + + #vars need to be declared as a PatternVariable or PatternProperty if we ever want them auto-declared + >ciphermaster .. PatternVariable o_algocommand + >ciphermaster .. PatternVariable o_iv_method + >ciphermaster .. PatternVariable o_ciphermodes + >ciphermaster .. PatternVariable o_iv_manually_set 0;#bool indicates was set via '. iv'. Resets each round unless o_iv_static is true. + >ciphermaster .. PatternVariable o_tailbuffer "" ;#remaining 1 to ($data_block_bytes -1) characters from when encrypt called with data not a multiple of $data_block_bytes bytes + >ciphermaster .. PatternVariable o_cipherpadding_numbytes 0 + + + + #NOTE - other properties are overlayed/mixed in during object construction in the Constructor + # e.g from >cipher_bytesizes + >ciphermaster .. PatternProperty patterncipherlib + >ciphermaster .. PatternProperty key "" ;# encryption key of size in $key_byte_sizes + >ciphermaster .. PatternProperty iv "" ;#$iv_bytes initialisation vector. Will be randomly created each round unless explicitly set. + >ciphermaster .. PatternProperty mode + >ciphermaster .. PatternProperty padschemeid 0;#1 = text based, ascii85 encoded, with paddingsize buckets + >ciphermaster .. PatternProperty padschemename ;# + >ciphermaster .. PatternProperty iv_static ;#whether or not random IV used each reset/init + + + >ciphermaster .. PatternProperty cipherid BFS ;#default - will only be used if cipherkey is not empty string + >ciphermaster .. PatternPropertyWrite cipherid {id} { + var o_cipherid o_patterncipherlib + if {$id ni [$o_patterncipherlib . cipherids]} { + error "($this . cipherid (property write)) cipherid '$id' not in list of known ciphers '[$o_patterncipherlib . cipherids]'" + } + error "not safe" + set o_cipherid $id + } + + >ciphermaster .. PatternVariable o_ciphertoken "" + >ciphermaster .. PatternPropertyRead ciphertoken "" { + var o_ciphertoken + return $o_ciphertoken + } + >ciphermaster .. PatternProperty cipherbin "" + + >ciphermaster .. PatternVariable o_chunknum 0 ;# + >ciphermaster .. PatternPropertyRead chunknum {} { + var o_chunknum + return o_chunknum + } + >ciphermaster .. PatternVariable o_chunklist [list] ;#no need for chunknum? + + >ciphermaster .. PatternProperty ciphertext ;#leave unset - underlying variable should never have a value. ciphertext is a dynamic property based on cipherbin + + + >ciphermaster .. PatternMethod padschemeinfo {{schemeid ""}} { + switch $schemeid { + "0" { + return [list scheme "text-minpad" notes "ascii85 encoded, minimum padding - at least 1 at most $o_data_block_bytes"] + } + "1" { + return [list scheme "text-buckets" notes "ascii85 encoded"] + } + "2" { + return [list scheme "binary-minpad" notes ""] + } + "3" { + return [list scheme "binary-buckets" notes ""] + } + default { + return [list scheme "unknown" notes "implemented padding schemes are [$o_patterncipherlib . padding_schemes]"] + } + } + } + + >ciphermaster .. PatternPropertyRead token {} { + var o_ciphertoken + return $o_ciphertoken + } + >ciphermaster .. PatternPropertyWrite mode {m} { + var this o_mode o_ciphermodes + if {$m ni $o_ciphermodes} { + error "($this . mode (write)) ERROR: supported modes are $o_ciphermodes" + } + set o_mode $m + } + >ciphermaster .. PatternPropertyRead ciphertext {args} { + var this o_cipherbin o_cipherpadding_numbytes o_cipherid o_patterncipherlib + if {$args eq [list -interim 1]} { + #allow bypassing header check for debug/test + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] $o_cipherbin] + return "INTERIM.$ascii85_payload" + } + + $this . ciphertext_header_info $o_cipherbin .. As header_info + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(cipherbin) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(cipherbin) Not yet retrievable - call '. encrypt -last 1' first." + } + } else { + set header [string range $o_cipherbin 0 7] + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] [string range $o_cipherbin 8 end]] + return $header$ascii85_payload ;#cyphertext with header + } + } + >ciphermaster .. PatternPropertyWrite ciphertext {frame_of_encrypted_data} { + var this o_patterncipherlib o_cipherbin o_cipherpadding_numbytes o_cipherid o_ciphertoken + if {[string length $o_cipherbin]} { + error "(cipherbin property write) There already seems to be an encryption operation underway - call decrypt to retrieve it." + } + #check header + $this . ciphertext_header_info $frame_of_encrypted_data .. As header_info + if {[dict get $header_info status] == 1} { + if {[dict get $header_info hdr_cipherid] ne $o_cipherid } { + error "(cipherbin property write) cipher in ciphertext [dict get $header_info hdr_cipherid] doesn't match currently configured cipher $o_cipherid" + } + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + set schemeid [dict get $header_info hdr_schemeid] + set bucketid [dict get $header_info hdr_bucketid] + set paybytes [dict get $header_info hdr_paybytes] + set paylen [dict get $header_info paylen] + set padlen [dict get $header_info padlen] + set o_cipherpadding_numbytes $padlen + if {$schemeid in {0 1}} { + #text based ascii85 + set head [string range $frame_of_encrypted_data 0 7] + set binary [::ascii85::decode [string range $frame_of_encrypted_data 8 end]] + set o_cipherbin $head$binary + } else { + #already binary + set o_cipherbin $frame_of_encrypted_data + } + + } else { + error "(ciphertext property write) ciphertext doesn't have proper header e.g 0BFS0FFF" + } + + } + >ciphermaster .. PatternPropertyRead cipherbin {args} { + var this o_cipherbin o_cipherpadding_numbytes o_cipherid + if {$args eq [list -interim 1]} { + #allow bypassing header check for debug/test + return $o_cipherbin + } + + + #check for #AAA0XXX header where # is a number from 1 to 8 and AAA is a cipher hint such as BFS or AES - this indicates --last has been called on encrypt and the ciphertext is ready to retrieve. + $this . ciphertext_header_info $o_cipherbin .. As header_info + + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(cipherbin) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(cipherbin) Not yet retrievable - call '. encrypt -last 1' first." + } + } else { + return $o_cipherbin ;#cyphertext with header + } + } + >ciphermaster .. PatternPropertyWrite cipherbin {encrypted_data} { + var this o_patterncipherlib o_cipherbin o_cipherpadding_numbytes o_cipherid o_ciphertoken + if {[string length $o_cipherbin]} { + error "(cipherbin property write) There already seems to be an encryption operation underway - call decrypt to retrieve it." + } + + #check header + $this . ciphertext_header_info $encrypted_data .. As header_info + if {[dict get $header_info status] == 1} { + if {[dict get $header_info hdr_cipherid] ne $o_cipherid } { + error "(cipherbin property write) cipher in ciphertext [dict get $header_info hdr_cipher] doesn't match currently configured cipher $o_cipherid" + } + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + set schemeid [dict get $header_info hdr_schemeid] + set bucketid [dict get $header_info hdr_bucketid] + set paybytes [dict get $header_info hdr_paybytes] + set paylen [dict get $header_info paylen] + set padlen [dict get $header_info padlen] + set o_cipherpadding_numbytes $padlen + + + set o_cipherbin $encrypted_data + } else { + error "(cipherbin property write) ciphertext doesn't have proper header e.g 0BFS0FFF" + } + } + >ciphermaster .. PatternPropertyUnset cipherbin {keypattern} { + var o_cipherbin + if {[string length $o_cipherbin]} { + error "($this . cipherbin (unset)) ERROR: cannot unset cipherbin - currently contains [string length $o_cipherbin] bytes." + } + } + >ciphermaster .. PatternPropertyWrite key {key_or_emptystring} { + var this o_data_block_bytes o_key o_ciphername o_key_byte_sizes + set datalen [string length $key_or_emptystring] + if {$datalen} { + if {($datalen ni $o_key_byte_sizes)} { + error "($this . key (write)) ERROR: bad key. $o_ciphername valid keylengths: '$o_key_byte_sizes'. Received $datalen bytes." + } + set newkey $key_or_emptystring + set oldkey $o_key + if {[string length $oldkey]} { + if {$newkey ne $oldkey} { + puts stderr "($this . key (write)) WARNING: changing $o_ciphername encipherment key '$oldkey' -> $newkey" + } + } + + } + set o_key $key_or_emptystring + } + + >ciphermaster .. PatternPropertyWrite iv {new_iv} { + var this o_ciphertoken o_iv o_iv_bytes o_iv_manually_set o_cipherbin o_algocommand + var o_iv_method o_patterncipherlib + + #puts "----> o_iv_method: $o_iv_method" + if {[string length $o_cipherbin]} { + error "($this . iv (write)) Cannot set IV while there is active cipher ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + + set library_passed_iv [{*}[concat $o_patterncipherlib . $o_iv_method -userdata $new_iv]] + + if {[string length $library_passed_iv] != $o_iv_bytes} { + error "($this . iv (write))IV returned by '[concat $o_patterncipherlib . $o_iv_method -userdata $new_iv]' was not $o_iv_bytes bytes long. Cipher configuration/library error?" + } + set o_iv $library_passed_iv + set o_iv_manually_set 1 + if {[string length $o_ciphertoken]} { + ${o_algocommand}::Reset $o_ciphertoken $o_iv + } + } + + + >ciphermaster .. PatternMethod reset {} { + var this o_ciphertoken o_iv o_iv_static o_iv_manually_set o_iv_bytes o_iv_method o_cipherbin + var o_tailbuffer o_cipherpadding_numbytes o_patterncipherlib o_algocommand + if {[string length $o_cipherbin]} { + $this . ciphertext_header_info [string range $o_cipherbin 0 9] .. As header_info + if {[dict get $header_info status] != 1} { + error "($this . reset) Cannot reset IV while there is unfinalised ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + } + if {$o_iv_static} { + #leave state of o_iv and o_iv_manually set as is + } else { + set o_iv_manually_set 0 + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + set o_cipherbin "" + set o_tailbuffer "" + set o_cipherpadding_numbytes 0 + if {[string length $o_ciphertoken]} { + ${o_algocommand}::Reset $o_ciphertoken $o_iv + } + } + >ciphermaster .. PatternMethod initcipher {} { + var this o_key o_key_byte_sizes o_iv o_iv_bytes o_iv_static o_iv_method o_iv_manually_set o_iv_previous + var o_ciphertoken o_mode o_cipherbin o_patterncipherlib o_algocommand + if {[string length $o_cipherbin]} { + error "($this . init) Cannot init while there is active cipher ciphertext. call 'decrypt_and_reset' or 'abandon' first or 'reset' if ciphertext has been finalised" + } + + + if {!$o_iv_manually_set} { + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + + } else { + if {$o_iv_static} { + #leave state of o_iv because it was manually configured and static + } else { + if {$o_iv eq $o_iv_previous} { + #change because not meant to be static + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + } + } + set o_iv_previous $o_iv + + if {[string length $o_key] ni $o_key_byte_sizes} { + error "(initcipher) '$this . key' current keylength:[string length $o_key] is wrong. Allowed lengths in bytes: '$o_key_byte_sizes'" + } + + set o_ciphertoken [${o_algocommand}::Init $o_mode $o_key $o_iv] + } + + >ciphermaster .. PatternMethod encryptlast {{newdata ""}} { + tailcall encrypt $_ID_ $newdata -last 1 + } + >ciphermaster .. PatternMethod encrypt {newdata args} { + var this o_ciphertoken o_cipherbin o_data_block_bytes o_key o_iv o_iv_bytes o_cipherpadding_numbytes o_tailbuffer o_patterncipherlib o_padschemeid o_cipherid o_algocommand + + #---------------------------------------------------------------------------- + set known_opts [list -last -show -key -iv] + dict set default -last 0 ;#when -last 1 do padding + dict set default -show 0 ;#echo $o_cipherbin to stdout + dict set default -reopen 0 ;#todo add -reopen by adding another bucket? + if {([llength $args] % 2) != 0} { + error "($this . encrypt) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(($this . encrypt) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set option_last [dict get $opts -last] + set option_show [dict get $opts -show] + set option_reopen [dict get $opts -reopen] + #---------------------------------------------------------------------------- + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + if {$o_cipherpadding_numbytes > 0} { + #once there is padding in the ciphertext data - we know this encrypt round is at an end. + error "($this . encrypt) Ciphertext is already finalised. Retrieve with '. ciphertext' and verify with '. decrypt_and_reset' before retrying." + } + + set newdata "$o_tailbuffer$newdata" ;#data we're adding in this method call + set o_tailbuffer "" + + if {$o_data_block_bytes > 0} { + set last_data_block_size [expr {[string length $newdata] % $o_data_block_bytes}] ;#if 0, newdata was a multiple of $o_data_block_bytes bytes + set blocksize $o_data_block_bytes + } else { + #non 'block-based' data - we'll never need padding + set blocksize [string length $newdata] + set last_data_block_size [string length $newdata] + } + set padding "" + + + if {![string length $o_cipherbin]} { + #first chunk to store in ciphertext. ciphertext requires 8 byte iv prepended + set o_cipherbin $o_iv ;# IV required for decryption + } + #o_cipherbin always has iv data at start now. + set iv_plus_content_size [expr {[string length $o_cipherbin ] + [string length $newdata]}] ;#iv + data is the payload the encrypter operates on + + if {$option_last} { + #treat as full bucket + set end_of_bucket 1 + } else { + #detect if we've filled a bucket + set end_of_bucket 0 + } + + + if {$end_of_bucket} { + #if we're already at a multiple of data_block_bytes bytes, still add padding so we can use o_cipherpadding_numbytes = 0 as a flag + + #New header of form #BFSHXLl where # is padding scheme X, BFSH is cipher, X is bucket code and Ll is the payload size (not including header) + #calculate size of the bucket needed for ascii85 encoded version of the payload + 8byte header + $blocksize bytes of minpadding + + #!todo - lookup text/vs binary from schemeinfo + if {$o_padschemeid in {0 1}} { + #text schemes + set hex_pay_len [format %04x $iv_plus_content_size] + set possible_newlines [expr {entier($iv_plus_content_size / [$o_patterncipherlib . ascii85_wraplen])}] + #review - guess vs redundant ascii85 encoding work? + set ascii85_content_size_guess [expr {entier(ceil(($iv_plus_content_size/4.0)*5)) + $possible_newlines}] ;#why guess? + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] $o_cipherbin$newdata] + + if {$ascii85_content_size_guess != [string length $ascii85_payload]} { + puts stdout "(encrypt) WARNING: ascii85 guess: '$ascii85_content_size_guess' vs ascii85 actual: '[string length $ascii85_payload]'" + } + + set bucket_info [$o_patterncipherlib . get_bucket_info $ascii85_content_size_guess] + set bucket_hex1 [dict get $bucket_info hex1] ; #1 byte hex + set bucket_size [dict get $bucket_info size] + + if {$o_padschemeid eq "0"} { + #text-minpad + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1 to $o_data_block_bytes + set needed_bytes $data_needed_bytes + set padding [string repeat * $needed_bytes] ;#primitive padding - #!todo review. + + set header "0${o_cipherid}0[string range ${hex_pay_len} 1 end]" + } elseif {$o_padschemeid eq "1"} { + #text-buckets + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] + puts stdout ">> data_needed_bytes: $data_needed_bytes" + set needed_bytes [expr {$bucket_size - 8 - $iv_plus_content_size}] + if {(8 + $iv_plus_content_size + $needed_bytes) != $bucket_size} { + error "(encrypt) ERROR: sanity_check 8 + iv&content ($iv_plus_content_size) + padding ($needed_bytes) != bucket_size ($bucket_size) - programming bug!" + } + + puts stdout ">> needed_bytes: $needed_bytes" + puts stdout ">>bucket_size: $bucket_size iv_plus_content_size: $iv_plus_content_size" + set padding [string repeat * $needed_bytes] + set header "1${o_cipherid}${bucket_hex1}[string range ${hex_pay_len} 1 end]" + } + + } elseif {$o_padschemeid in {2 3}} { + set hex_pay_len [format %04x $iv_plus_content_size] + + set bucket_info [$o_patterncipherlib . get_bucket_info $iv_plus_content_size] + set bucket_hex1 [dict get $bucket_info hex1] + set bucket_size [dict get $bucket_info size] + + set msb [string range $hex_pay_len 0 1] + set lsb [string range $hex_pay_len 2 3] + set bin_pay_len [binary format c2 [list "0x$msb" "0x$lsb"] + if {$o_padschemeid eq "2"} { + #binary-minpad + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1-$o_data_block_bytes + set needed_bytes $data_needed_bytes + set padding [$o_patterncipherlib . get_random_bytes $needed_bytes] + + set header "2${o_cipherid}${bucket_hex1}$bin_pay_len" + } elseif {$o_padschemeid eq "3"} { + #binary-buckets + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1-$o_data_block_bytes + set needed_bytes [expr {$bucket_size - 8 - $iv_plus_content_size}] + if {(8 + $iv_plus_content_size + $needed_bytes) != $bucket_size} { + error "(encrypt) ERROR: sanity_check 8 + iv&content ($iv_plus_content_size) + padding ($needed_bytes) != bucket_size ($bucket_size) - programming bug!" + } + set padding [$o_patterncipherlib . get_random_bytes $needed_bytes] + set header "3${o_cipherid}${bucket_hex1}$bin_pay_len" + } + } + + set o_cipherpadding_numbytes [string length $padding] ;#assertion: always non zero here + + set padded_data "$newdata$padding" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $padded_data] + + set o_cipherbin ${header}$o_cipherbin ;#header will make the '. ciphertext' property readable + + puts stdout "ciphertext final: >>> $o_cipherbin <<<" + #puts stderr ">>$padded_data<< [string length $padded_data] bytes" + set payload_bytes [expr [string length $o_cipherbin] - 8 - [string length $padding] - $o_iv_bytes] ;#account for IV and padding bytes to give caller an indication of + if {($payload_bytes + $o_iv_bytes) != $iv_plus_content_size} { + puts stderr "(encrypt) WARNING payloadbytes $payload_bytes != iv_plus_content_size $iv_plus_content_size" + } + + return [list payload_bytes $payload_bytes padding_bytes [string length $padding] header $header buffer_bytes [string length $o_tailbuffer] final 1] + } else { + if {$blocksize > 0} { + if {([string length $newdata] % $blocksize) != 0} { + #error "($this . encrypt) data chunk must be a multiple of $data_block_bytes bytes - call decrypt after one or more calls to encrypt, and/or call '. encrypt data_or_empty_string -last 1" + if {$last_data_block_size != 0} { + set o_tailbuffer [string range $newdata end-[expr {$last_data_block_size -1}] end] + set newdata [string range $newdata 0 end-$last_data_block_size] + } + + if {[string length $newdata]} { + puts stdout "1encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + } else { + puts stdout "2encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + } else { + puts stdout "3encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + set payload_bytes [expr [string length $o_cipherbin] - $o_iv_bytes] ;#account for IV to give caller an indication of payload bytes + + puts stdout "ciphertext: >>> $o_cipherbin padding:$padding should still be 0<<<" + return [list payload_bytes $payload_bytes padding_bytes [string length $padding] buffer_bytes [string length $o_tailbuffer] final 0] + } + + } + + + #abandon any currently-building ciphertext - drop the token + >ciphermaster .. PatternMethod abandon {} { + var this o_ciphertoken o_cipherbin o_cipherpadding_numbytes o_algocommand o_tailbuffer o_iv o_iv_manually_set + puts stdout "($this . abandon) Abandoning any active ciphertext. Encipherment key unchanged. Key-schedule will be regenerated (previous token Finalised)" + + catch {${o_algocommand}::Final $o_ciphertoken} + + set o_ciphertoken "" + set o_cipherbin "" + set o_tailbuffer "" + set o_iv "" + set o_iv_manually_set 0 + set o_cipherpadding_numbytes 0 + } + + #for some schemes - the info returned by ciphertext_header_info is only accurate if the full ciphertext is supplied - not just the header + # hdr_ fields can be trusted if an appropriately truncated ciphertext is supplied, but fields such as padlen may require the complete bucket. + >ciphermaster .. PatternMethod ciphertext_header_info {ciphertext} { + set schemeid [string range $ciphertext 0 0] ;#e.g 0, 1, 2 + set cipherid [string range $ciphertext 1 3] ;#e.g BFS, AES + set bucketid [string range $ciphertext 4 4] ;#hexchar 0-F + set paybytes [string range $ciphertext 5 7] ;#3bytes hex or binary payload length + set endiv [expr {(8 + $o_iv_bytes) -1}] + set cipheriv [string range $ciphertext 8 $endiv] ;# Initialisation vector + set errors [list] + #8 byte header for all schemeids for now + + if {(![string is integer -strict $schemeid]) || ($cipherid ni [$o_patterncipherlib . cipherids]) || (![string is xdigit -strict $bucketid]) || ([string length $paybytes] != 3)} { + lappend errors [expr {(![string is integer -strict $schemeid]) ? "bad schemeid" : ""}] + lappend errors [expr {($cipherid ni [$o_patterncipherlib . cipherids]) ? "cipherid '$cipherid' unknown" : ""}] + lappend errors [expr {(![string is xdigit -strict $bucketid]) ? "non-hex bucketid" : ""}] + lappend errors [expr {([string length $paybytes] != 3) ? "paybytes len != 3" : ""}] + set errors [lsearch -all -inline -not -exact $errors ""] ;#strip empty strings from error list + return [list status 0 hdr_schemeid $schemeid hdr_cipherid $cipherid hdr_bucketid $bucketid hdr_paybytes $paybytes iv $cipheriv errors $errors] + } + + #calculate payload length from paybytes + #for now - hard code the schemes here + set paylen_is_hex 0 + set paylen_is_binary 0 + if {$schemeid in {0 1}} { + set paylen_is_hex 1 + } elseif {$schemeid in {2 3}} { + set paylen_is_binary 1 + } else { + error "schemeid $schemeid unimplemented" + } + + if {$paylen_is_hex} { + set paylen [scan $paybytes %x] + } elseif {$paylen_is_binary} { + #test create a paylen with something like: set bin [binary format c3 {0x00 0x01 0x0A} + #H bigendian h smallendian + binary scan $paylen H3 v ;# turn to hex such as 00010a + set paylen [scan $v %x] ;# back to decimal + } + + if {$bucketid != 0} { + set bucketsize [dict get [$o_patterncipherlib . bucketsize_by_hex1] $bucketid] + set padlen [expr {$bucketsize - 8 - $paylen}] + } else { + set bucketsize 0 + set padlen [expr {[string length $ciphertext] - 8 - $paylen}] + } + + return [list status 1 hdr_schemeid $schemeid hdr_cipherid $cipherid hdr_bucketid $bucketid hdr_paybytes $paybytes iv $cipheriv bucketsize $bucketsize paylen $paylen padlen $padlen errors [list]] ;#always return errors member even if empty + + } + + #todo - detect if ciphertext hasn't been retrieved + >ciphermaster .. PatternMethod decrypt {} { + error "(decrypt) Call decrypt_and_reset to verify after retrieving encrypted data with '. ciphertext'" + } + + >ciphermaster .. PatternMethod decrypt_and_reset {} { + var this o_ciphertoken o_cipherbin o_tailbuffer o_cipherpadding_numbytes + var o_iv o_iv_bytes o_iv_static o_iv_method o_patterncipherlib o_cipherid o_algocommand + + if {![string length $o_cipherbin]} { + error "No data to decrypt - call encrypt first. After one or more calls to encrypt ending with '. encrypt -last', retrieve '. ciphertext' and call decrypt_and_reset to retrieve/verify plaintext chunk." + } + $this . ciphertext_header_info $o_cipherbin .. As header_info + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(decrypt_and_reset) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(decrypt_and_reset) Not yet retrievable - call '. encrypt -last 1' first." + } + } + + set bucketid [dict get $header_info hdr_bucketid] + set bucketsize [dict get $header_info bucketsize] + + set padlen [dict get $header_info padlen] + set paylen [dict get $header_info paylen] + #sanity checks + if {$o_cipherpadding_numbytes != $padlen} { + puts stderr "WARNING!! stored o_cipherpadding_numbytes '$o_cipherpadding_numbytes' != '. ciphertext_header_info' padlen '$padlen'" + } + if {([string length $o_cipherbin] -8 -$padlen) != $paylen} { + puts stderr "WARNING!! length of stored o_cipherbin - 8 '[expr {[string length $o_cipherbin] -8}]' != '.ciphertext_header_info' paylen '$paylen'" + } + + puts stdout "------------------------------------------------------" + puts stdout "About to decrypt: IV+encdata '[string range $o_cipherbin 8 80]...' with token $o_ciphertoken" + puts stdout "------------------------------------------------------" + set plaintext [${o_algocommand}::Decrypt $o_ciphertoken [string range $o_cipherbin 8 end]] ;#don't pass our #BFSXXXX- header to the ${o_algocommand} library + puts stdout "full decrypted plaintext [string length $plaintext] bytes including iv and padding (padlen:$padlen paylen $paylen bucketsize: $bucketsize) :" + puts stdout "------------------------------------------------------" + puts stdout "$plaintext" + puts stdout "------------------------------------------------------" + + #set padlength $o_cipherpadding_numbytes + #reset + + #${o_algocommand}::Final $o_ciphertoken + #set o_ciphertoken "" + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + if {!$o_iv_static} { + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + + ${o_algocommand}::Reset $o_ciphertoken $o_iv + + set o_cipherbin "" + set o_tailbuffer "" + set o_cipherpadding_numbytes 0 ;#important to reset this + #strip iv and padding to recover original data + return [string range $plaintext $o_iv_bytes end-$padlen] + } + + >ciphermaster .. Destructor {} { + var o_ciphertoken o_algocommand + ${o_algocommand}::Final $o_ciphertoken + } + +} + + +namespace eval ::patterncipher { + + set created_cipherpatterns [list] + foreach ciphername [::patterncipher::libs::>lib_standard . ciphernames] { + >pattern .. Create >cipher1 + >cipher1 .. Variable o_ciphername $ciphername ;#for help method on the prototype object + >cipher1 .. PatternVariable o_ciphername $ciphername + >cipher1 .. Clone >$ciphername ;#clone brings along its default values + >cipher1 .. Destroy + + >ciphermaster .. Clone >$ciphername + lappend created_cipherpatterns [namespace current]::>$ciphername + } + puts stdout "Created patterncipher cipherpattern objects: $created_cipherpatterns" + +} + + + + + + + + + diff --git a/src/vendormodules/patterncmd-0.1.tm b/src/vendormodules/patterncmd-0.1.tm new file mode 100644 index 00000000..8008673a --- /dev/null +++ b/src/vendormodules/patterncmd-0.1.tm @@ -0,0 +1,639 @@ +package provide patterncmd [namespace eval patterncmd { + variable version + set version 0.1 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } +} + +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} + +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + error "PatternCompile ????" + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + +} \ No newline at end of file diff --git a/src/vendormodules/patterncmd-1.2.8.tm b/src/vendormodules/patterncmd-1.2.8.tm new file mode 100644 index 00000000..76ade79f --- /dev/null +++ b/src/vendormodules/patterncmd-1.2.8.tm @@ -0,0 +1,639 @@ +package provide patterncmd [namespace eval patterncmd { + variable version + set version 1.2.8 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } +} + +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} + +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + error "PatternCompile ????" + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + +} \ No newline at end of file diff --git a/src/vendormodules/patternlib-1.2.8.tm b/src/vendormodules/patternlib-1.2.8.tm new file mode 100644 index 00000000..67a7cba9 --- /dev/null +++ b/src/vendormodules/patternlib-1.2.8.tm @@ -0,0 +1,2588 @@ +#JMN 2004 +#public domain + + +package provide patternlib [namespace eval patternlib { + variable version + set version 1.2.8 +}] + + + +#Change History +#------------------------------------------------------------------------------- +# 2022-05 +# added . search and . itemKeys methods to >collection to enable lookups by value +# 2021-09 +# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. +# +# 2006-05 +# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. +# +# 2005-04 +# remove 'name' method - incorporate indexed retrieval into 'names' method +# !todo? - adjust key/keys methods for consistency? +# +# 2004-10 +# initial key aliases support +# fix negative index support on some methods e.g remove +# 2004-08 +# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection +# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value +# +# 2004-06-05 +# added 'sort' method to sort on values. +# fixed 'keySort' method to accept multiple sort options +# added predicate methods 'all' 'allKeys' 'collectAll' +# 2004-06-01 +# '>collection . names' method now accepts optional 'glob' parameter to filter result +# 2004-05-19 +#fix '>collection . clear' method so consecutive calls don't raise an error +#------------------------------------------------------------------------------- + +namespace eval ::patternlib::util { + 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" + } + } + + #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter + # k-hashes + # m-bits + # n-elements + # optimal value of k: (m/n)ln(2) + #proc bloom_optimalNumHashes {capacity_n bitsize_m} { + # expr { round((double($bitsize_m) / $capacity_n) * log(2))} + #} + #proc bloom_optimalNumBits {capacity fpp} { + # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} + #} + +} +::patternlib::util::package_require_min pattern 1.2.4 +#package require pattern +::pattern::init ;# initialises (if not already) + + +namespace eval ::patternlib {namespace export {[a-z]*} + namespace export {[>]*} + + variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified + proc uniqueKey {} { + return [incr ::patternlib::keyCounter] + } + +#!todo - multidimensional collection +# - o_list as nested list +# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? +# - perhaps a key is always a list length n where n is the number of dimensions? +# - therefore we'll need an extra level of nesting for the current base case n=1 +# +# - how about a nested dict for each key-structure (o_list & o_array) ? + +#COLLECTION +# +#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names +# - consider array-style access using traced var named same as collection. +# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? +#!todo - add boolean property to force unique values as well as keys + + +#::pattern::create >collection + + + + +::>pattern .. Create >collection +set COL >collection +#process_pattern_aliases [namespace origin >collection] +#process_pattern_aliases ::patternlib::>collection +$COL .. Property version 1.0 +$COL .. PatternDefaultMethod item + +set PV [$COL .. PatternVariable .] + +$PV o_data +#$PV o_array +#$PV o_list +$PV o_alias +$PV this + +#for invert method +$PV o_dupes 0 + + +$COL .. PatternProperty bgEnum + + +#PV o_ns + +$PV m_i_filteredCollection + +#set ID [lindex [set >collection] 0 0] ;#context ID +#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID + +$COL .. Constructor {args} { + var o_data m_i_filteredCollection o_count o_bgEnum + + var this + set this @this@ + + set m_i_filteredCollection 0 + if {![llength $args]} { + set o_data [dict create] + #array set o_array [list] + #set o_list [list] + set o_count 0 + } elseif {[llength $args] == 1} { + set o_data [dict create] + set pairs [lindex $args 0] + if {[llength $pairs] % 2} { + error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" + } + set keys_seen [list] + foreach key [dict keys $pairs] { + if {[string is integer -strict $key] } { + error ">collection key must be non-integer. Bad key: $key. No items added." + } + if {$key in $keys_seen} { + error "key '$key' already exists in this collection. No items added." + } + lappend keys_seen $key + } + unset keys_seen + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $pairs] + set o_count [dict size $o_data] + } else { + error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." + } + array set o_alias [list] + + array set o_bgEnum [list] + @next@ +} +#comment block snipped from collection Constructor + #--------------------------------------------- + #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway + # + #### OBSOLETE - left as example of an approach + #make count property traceable (e.g so property ref can be bound to Tk widgets) + #!todo - manually update o_count in relevant methods faster?? + # should avoid trace calls for addList methods, shuffle etc + # + #set handler ::p::${_ID_}::___count_TraceHandler + #proc $handler {_ID_ vname vidx op} { + # #foreach {vname vidx op} [lrange $args end-2 end] {break} + # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name + # + # #this is only a 'write' handler + # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] + # return + #} + #trace add variable o_list {write} [list $handler $_ID_] + #### + # + # + #puts "--->collection constructor id: $_ID_" + + + + +set PM [$COL .. PatternMethod .] + + +#!review - why do we need the count method as well as the property? +#if needed - document why. +# read traces on count property can be bypassed by method call... shouldn't we avoid that? +# 2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. +# +$COL .. PatternMethod count {} { + #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. + #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. + var o_data + dict size $o_data +} + +$COL .. PatternProperty count +$COL .. PatternPropertyWrite count {_val} { + var + error "count property is read-only" +} + +$COL .. PatternPropertyUnset count {} { + var +} ;#cannot raise error's in unset trace handlers - simply fail to unset silently + +$COL .. PatternMethod isEmpty {} { + #var o_list + #return [expr {[llength $o_list] == 0}] + var o_data + expr {[dict size $o_data] == 0} +} + +$COL .. PatternProperty inverted 0 + + + +###### +# item +###### +#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? +# i.e [>obj . item] returns the 1st element in the list +#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) +#[>obj . item -2] returns 2nd last element (equiv to "end-1") + + +$COL .. PatternMethod item {{idx 0}} { + #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) + # (still at least 20 times slower than a plain array... at <5us) + var o_data o_alias + + #!todo - review 'string is digit' vs 'string is integer' ?? + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set keys [dict keys $o_data] + if {[catch {dict get $o_data [lindex $keys $idx]} result]} { + var this + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {dict get $o_data $idx} result]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + var this + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + #tailcall? + #item $_ID_ $nextIdx + #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" + tailcall item $_ID_ $nextIdx + } + } else { + return $result + } + } +} + + + +if {0} { +#leave this here for comparison. +$COL .. PatternMethod item2 {{idx 0}} { + var o_array o_list o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + item $_ID_ $nextIdx + } + } else { + return $result + } + } + +} +} + +#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) +$COL .. PatternMethod itemNamed {idx} { + var o_data + dict get $o_data $idx +} +$COL .. PatternMethod in {idx} { + var o_data + dict get $o_data $idx +} + +$COL .. PatternMethod itemAt {idx} { + var o_data + dict get $o_data [lindex [dict keys $o_data] $idx] +} + +$COL .. PatternMethod replace {idx val} { + var o_data o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { + error "no such index: '$idx' in collection: $this" + } else { + return $val + } + } else { + if {[catch {dict set o_data $idx $val}]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + tailcall replace $_ID_ $nextIdx $val + } + + } else { + return $val + } + } +} + +#if the supplied index is an alias, return the underlying key; else return the index supplied. +$COL .. PatternMethod realKey {idx} { + var o_alias + + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } +} + +#note alias feature is possibly ill-considered. +#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. +$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { + var o_alias + + #set existingKey [realKey $_ID_ $existingKeyOrAlias] + #alias to the supplied KeyOrAlias - not the underlying key + + if {[string is integer -strict $newAlias]} { + error "collection key alias cannot be integer" + } + + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } +} +$COL .. PatternMethod aliases {{key ""}} { + var o_alias + + if {[string length $key]} { + set result [list] + #lsearch -stride? + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + + return $result + } else { + return [array get o_alias] + } +} + +#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied + +#default to removing item from the end, otherwise from supplied index (position or key) +#!todo - accept alias indices +#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) +#!todo - review.. for performance.. shouldn't pop NOT accept an index? +#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? +$COL .. PatternMethod pop {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} +$COL .. PatternMethod poppair {} { + var o_data o_count + set key [lindex [dict keys $o_data] end] + set val [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return [list $key $val] +} + + + +#!todo - add 'push' method... (basically specialized versions of 'add') +#push - add at end (effectively an alias for add) +#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. +#add - add at end + +#ordered +$COL .. PatternMethod items {} { + var o_data + + dict values $o_data +} + + + + +#### +#pair +#### +#fifo-style accesss when no idx supplied (likewise with 'add' method) +$COL .. PatternMethod pair {{idx 0}} { + var o_data + + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + + if {[catch {dict get $o_data $key} val]} { + error "no such index: '$idx'" + } else { + return [list $key $val] + } +} +$COL .. PatternMethod pairs {} { + var o_data + set o_data +} + +$COL .. PatternMethod get {} { + var o_data + set o_data +} +#todo - fix >pattern so that methods don't collide with builtins +#may require change to use oo - or copy 'my' mechanism to call own methods +$COL .. PatternMethod Info {} { + var o_data + return [dict info $o_data] +} +#2006-05-21.. args to add really should be in key, value order? +# - this the natural order in array-like lists +# - however.. key should be optional. + +$COL .. PatternMethod add {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? +#what then of methods like 'count' which apply equally well to collections and stacks? + +#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? +$COL .. PatternMethod push {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#shift/unshift - roughly analogous to those found in Perl & PHP +#unshift adds 1 or more values to the beginning of the collection. +$COL .. PatternMethod unshift {values {keys ""}} { + var o_data o_count + + if {![llength $keys]} { + for {set i 0} {$i < [llength $values]} {incr i} { + lappend keys "_[::patternlib::uniqueKey]_" + } + } else { + #check keys before we insert any of them. + foreach newkey $keys { + if {[string is integer -strict $newkey]} { + error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + } + if {[llength $values] != [llength $keys]} { + error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" + } + + #separate loop through keys because we want to fail the whole operation if any are invalid. + + set existing_keys [dict keys $o_data] + foreach newkey $keys { + if {$newkey in $exisint_keys} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$newkey' already exists in this collection" + } + } + + + #ok - looks like entire set can be inserted. + set newpairs [list] + foreach val $values key $keys { + lappend newpairs $key $val + } + set o_data [concat $newpairs $o_data[set o_data {}]] + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#default to removing item from the beginning, otherwise from supplied index (position or key) +#!todo - accept alias indices +$COL .. PatternMethod shift {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] 0] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} + + +$COL .. PatternMethod peek {} { + var o_data + + #set o_array([lindex $o_list end]) + + #dict get $o_data [lindex [dict keys $o_data] end] + lindex $o_data end +} + +$COL .. PatternMethod peekKey {} { + var o_data + #lindex $o_list end + lindex $o_data end-1 +} + + +$COL .. PatternMethod insert {val args} { + var o_data o_count + + set idx 0 + set key "" + + if {[llength $args] <= 2} { + #standard arg (ordered) style: + #>obj . insert $value $position $key + + lassign $args idx key + } else { + #allow for literate programming style: + #e.g + # >obj . insert $value at $listPosition as $key + + if {[catch {array set iargs $args}]} { + error "insert did not understand argument list. +usage: +>obj . insert \$val \$position \$key +>obj . insert \$val at \$position as \$key" + } + if {[info exists iargs(at)]} { + set idx $iargs(at) + } + if {[info exists iargs(as)]} { + set key $iargs(as) + } + } + + if {![string length $key]} { + set key "_[::patternlib::uniqueKey]_" + } + + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + + + if {[dict exists $o_data $key]} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$key' already exists in this collection" + } + + if {$idx eq "end"} { + #lappend o_list $key + #standard dict set will add it to the end anyway + dict set o_data $key $val + + } else { + #set o_list [linsert $o_list $idx $key] + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] + } + + + #set o_array($key) $val + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#!todo - deprecate and give it a better name! addDict addPairs ? +$COL .. PatternMethod addArray {list} { + var + puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" + tailcall addPairs $_ID_ $list +} +$COL .. PatternMethod addPairs {list} { + var o_data o_alias o_count + if {[llength $list] % 2} { + error "must supply an even number of elements" + } + + set aliaslist [array names o_alias] + #set keylist [dict keys $o_data] + foreach newkey [dict keys $list] { + if {[string is integer -strict $newkey] } { + error ">collection key must be non-integer. Bad key: $newkey. No items added." + } + + #if {$newkey in $keylist} {} + #for small to medium collections - testing for newkey in $keylist is probably faster, + # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. + if {[dict exists $o_data $newkey]} { + error "key '$newkey' already exists in this collection. No items added." + } + #The assumption is that there are in general relatively few aliases - so a list test is appropriate + if {$newkey in $aliaslist} { + if {[dict exists $o_data $o_alias($newkey)]} { + error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " + } + } + #! check if $list contains dups? + #- slows method down - for little benefit? + } + #!todo - test? (but we need a loop to test for integer keys.. so what's the point?) + #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] + #if {[llength $intersection]} { + # error "keys '$intersection' already present in this collection. No items added." + #} + + + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $list] + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} +$COL .. PatternMethod addList {list} { + var o_data o_count + + foreach val $list { + dict set o_data "_[::patternlib::uniqueKey]_" $val + #!todo - test. Presumably lappend faster because we don't need to check existing keys.. + #..but.. is there shimmering involved in treating o_data as a list? + #lappend o_data _[::patternlib::uniqueKey]_ $val + + #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] + } + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#'del' is not a very good name... as we're not really 'deleting' anything. +# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. +#!todo - handle 'endRange' parameter for removing ranges of items. +$COL .. PatternMethod del {idx {endRange ""}} { + var + #!todo - emit a deprecation warning for 'del' + tailcall remove $_ID_ $idx $endRange +} + +$COL .. PatternMethod remove {idx {endRange ""}} { + var o_data o_count o_alias this + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#ordered +$COL .. PatternMethod names {{globOrIdx {}}} { + var o_data + + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + #Idx + set idx $globOrIdx + + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + + + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "no such index : '$idx'" + } else { + return $result + } + + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } +} + +#ordered +$COL .. PatternMethod keys {} { + #like 'names' but without globbing + var o_data + dict keys $o_data +} + +#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects +# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? +# - some sort of resolution order/interface-selection is clearly required anyway +# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. +# In the mean time however... we'll at least avoid 'name'! +# +#$PM name {{posn 0}} { +# var o_array o_list +# +# if {$posn < 0} { +# set posn "end-[expr {abs($posn + 1)}]" +# } +# +# if {[catch {lindex $o_list $posn} result]} { +# error "no such index : '$posn'" +# } else { +# return $result +# } +#} + +$COL .. PatternMethod key {{posn 0}} { + var o_data + + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "no such index : '$posn'" + } else { + return $result + } +} + + +#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. +$COL .. PatternMethod setPosn {idx to} { + var o_data + + if {![string is integer -strict $to]} { + error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" + } + + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set to [expr {$to % [dict size $o_data]}] + + + set val [dict get $o_data $key] + dict unset o_data $key + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] + + #set o_list [lreplace $o_list $posn $posn] + #set o_list [linsert $o_list $to $key] + + return $to +} +#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? +#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. +$COL .. PatternMethod incrPosn {idx {by 1}} { + var o_data + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set newPosn [expr {($posn + $by) % [dict size $o_data]}] + + setPosn $_ID_ $posn $newPosn + return $newPosn +} +$COL .. PatternMethod decrPosn {idx {by 1}} { + var + return [incrPosn $_ID_ $idx [expr {- $by}]] +} +$COL .. PatternMethod move {idx to} { + var + return [setPosn $_ID_ $idx $to] +} +$COL .. PatternMethod posn {key} { + var o_data + return [lsearch -exact [dict keys $o_data] $key] +} + +#!todo? - disallow numeric values for newKey so as to be consistent with add +#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything +# - this is ok. +$COL .. PatternMethod reKey {idx newKey} { + var o_data o_alias + + + if {[dict exists $o_data $newKey]} { + #puts stderr "==============> reKey collision, key $newKey already exists in this collection" + error "reKey collision, key '$newKey' already exists in this collection" + } + if {[info exists o_alias($newKey)]} { + if {[dict exists $o_data $o_alias($newKey)]} { + error "reKey collision, key '$newKey' already present as an alias in this collection" + } else { + set newKey $o_alias($newKey) + } + } + + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx'" + } else { + #try with next key in alias chain... + #return [reKey $_ID_ $nextKey $newKey] + tailcall reKey $_ID_ $nextKey $newKey + } + } + } + + #set o_list [lreplace $o_list $posn $posn $newKey] + ##atomic? (traces on array?) + #set o_array($newKey) $o_array($key) + #unset o_array($key) + + dict set o_data $newKey [dict get $o_data $key] + dict unset o_data $key + + return +} +$COL .. PatternMethod hasKey {key} { + var o_data + dict exists $o_data $key +} +$COL .. PatternMethod hasAlias {key} { + var o_alias + info exists o_alias($key) +} + +#either key or alias +$COL .. PatternMethod hasIndex {key} { + var o_data o_alias + if {[dict exists $o_data $key]} { + return 1 + } else { + return [info exists o_alias($key)] + } +} + + +#Shuffle methods from http://mini.net/tcl/941 +$COL .. PatternMethod shuffleFast {} { + #shuffle6 - fast, but some orders more likely than others. + + var o_data + + set keys [dict keys $o_data] + + set n [llength $keys] + for { set i 1 } { $i < $n } { incr i } { + set j [expr { int( rand() * $n ) }] + set temp [lindex $keys $i] + lset keys $i [lindex $keys $j] + lset keys $j $temp + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} +$COL .. PatternMethod shuffle {} { + #shuffle5a + + var o_data + + set n 1 + set keys [list] ;#sorted list of keys + foreach k [dict keys $o_data] { + #set index [expr {int(rand()*$n)}] + + #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] + + #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] + set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] + incr n + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} + + +#search is a somewhat specialised form of 'itemKeys' +$COL .. PatternMethod search {value args} { + var o_data + #only search on values as it's possible for keys to match - especially with options such as -glob + set matches [lsearch {*}$args [dict values $o_data] $value] + + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } +} + +#inverse lookup +$COL .. PatternMethod itemKeys {value} { + var o_data + #only search on values as it's possible for keys to match + set value_indices [lsearch -all [dict values $o_data] $value] + + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist +} + +#invert: +#change collection to be indexed by its values with the old keys as new values. +# - keys of duplicate values become a list keyed on the value. +#e.g the array equivalent is: +# arr(a) 1 +# arr(b) 2 +# arr(c) 2 +#becomes +# inv(1) a +# inv(2) {b c} +#where the order of duplicate-value keys is not defined. +# +#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. +# + + +#!todo - try just [lreverse $o_data] ?? + + +$COL .. PatternMethod invert {{splitvalues ""}} { + + var o_data o_count o_dupes o_inverted + + + if {$splitvalues eq ""} { + #not overridden - use o_dupes from last call to determine if values are actually keylists. + if {$o_dupes > 0} { + set splitvalues 1 + } else { + set splitvalues 0 + } + } + + + #set data [array get o_array] + set data $o_data + + if {$o_count > 500} { + #an arbitrary optimisation for 'larger' collections. + #- should theoretically keep the data size and save some reallocations. + #!todo - test & review + # + foreach nm [dict keys $o_data] { + dict unset o_data $nm + } + } else { + set o_data [dict create] + } + + if {!$splitvalues} { + dict for {k v} $data { + dict set o_data $v $k + } + } else { + dict for {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + dict set o_data $sub $k + #} + } + } + } + + + if {[dict size $o_data] != $o_count} { + #must have been some dupes + + set o_dupes [expr {$o_count - [dict size $o_data]}] + #update count to match inverted collection + set o_count [dict size $o_data] + } else { + set o_dupes 0 + } + + set o_inverted [expr {!$o_inverted}] + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $o_dupes +} + + + + + + +#NOTE: values are treated as lists and split into separate keys for inversion only if requested! +# To treat values as keylists - set splitvalues 1 +# To treat each value atomically - set splitvalues 0 +# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! +# +# +#Initially call invert with splitvalues = 0 +#To keep calling invert and get back where you started.. +# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. +# +$COL .. PatternMethod invert_manual {{splitvalues 0}} { + #NOTE - the list nesting here is *tricky* - It probably isn't broken. + + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + lappend o_array($v) $k + } + } else { + foreach {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + set o_array($sub) $k + #} + } + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + if {$splitvalues} { + #values are lists of length one. Take lindex 0 so list values aren't overnested. + foreach oldkey $o_list { + lset o_list [incr i] [lindex $prev($oldkey) 0] + } + } else { + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + } + + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + + + +#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys +# (keys that are lists) +$COL .. PatternMethod invert_lossy {{splitvalues 1}} { + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + #note! we must check for existence and use 'set' for first case. + #using 'lappend' only will result in deeper nestings on each invert! + #If you don't understand this - don't change it! + if {[info exists o_array($v)]} { + lappend o_array($v) $k + } else { + set o_array($v) $k + } + } + } else { + foreach {k v} $data { + #length test necessary to avoid incorrect 'un-nesting' + #if {[llength $v] > 1} { + foreach sub $v { + if {[info exists o_array($sub)]} { + lappend o_array($sub) $k + } else { + set o_array($sub) $k + } + } + #} else { + # if {[info exists o_array($v)]} { + # lappend o_array($v) $k + # } else { + # set o_array($v) $k + # } + #} + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + +$COL .. PatternMethod reverse {} { + var o_data + + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return +} + +$COL .. PatternMethod keySort {{options -ascii}} { + var o_data + + set keys [lsort {*}$options [dict keys $o_data]] + + set dictnew [dict create] + foreach k $keys { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + + return +} + +#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. +$COL .. PatternMethod sort {args} { + var o_data + + #defaults + set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. + + set options_simple [list] + + + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + switch -- $a { + -indices - + -ascii - + -dictionary - + -integer - + -real - + -increasing - + -decreasing { + #dict set options $a 1 + lappend options_simple $a + } + -unique { + #not a valid option + #this would stuff up the data... + #!todo? - remove dups from collection if this option used? - alias the keys? + } + -object { + #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing + #may be slow - but handy. Consider -indexed property to store/cache these values on first run + } + -command { + dict set options $a [lindex $args [incr i]] + } + -index { + #allow sorting on subindices of the value. + dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] + } + default { + #unrecognised option - print usage? + } + } + } + + + + if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { + + var o_array + + set slist [list] + foreach k [dict keys $o_data] { + lappend slist [list $k [dict get $o_data $k]] + } + return [lsort {*}$options_simple {*}$options $slist] + + + + #set options_simple [lreplace $options_simple $posn $posn] ;# + #set slist [list] + #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { + # lappend slist [list $n $v] + #} + #set slist [lsort {*}$options_simple {*}$options $slist] + #foreach i $slist { + # #determine the position in the collections list + # lappend result {*}[lsearch -exact $o_list [lindex $i 0]] + #} + #return $result + } else { + set slist [list] + dict for {k v} $o_data { + lappend slist [list $k $v] + } + #set slist [lsort {*}$options_simple {*}$options $slist] + set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency + + + #set o_list [lsearch -all -inline -subindices -index 0 $slist *] + + set o_data [dict create] + foreach pair $slist { + dict set o_data [lindex $pair 0] [lindex $pair 1] + } + + + + return + } + +} + + +$COL .. PatternMethod clear {} { + var o_data o_count + + set o_data [dict create] + set o_count 0 + #aliases? + return +} + +#see http://wiki.tcl.tk/15271 - A generic collection traversal interface +# +#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) +#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? +# - should this be an option? which mechanism should be the default? +# - currently only the keylist is treated in 'snapshot' fashion +# so values could be changed and the state could be invalidated by other code during an enumeration +# +$COL .. PatternMethod enumerate {args} { + #---------- + lassign [lrange $args end-1 end] cmd seed + set optionlist [list] + foreach a [lrange $args 0 end-2] { + lappend optionlist $a + } + set opt(-direction) left + set opt(-completioncommand) "" + array set opt $optionlist + #---------- + var o_data + + if {[string tolower [string index $opt(-direction) 0]] eq "r"} { + #'right' 'RIGHT' 'r' etc. + set list [lreverse [dict keys $o_data]] + } else { + #normal left-right order + set list [dict keys $o_data] + } + + if {![string length $opt(-completioncommand)]} { + #standard synchronous processing + foreach k $list { + set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] + } + return $seed + } else { + #ASYNCHRONOUS enumeration + var this o_bgEnum + #!todo - make id unique + #!todo - facility to abort running enumeration. + set enumID enum[array size o_bgEnum] + + set seedvar [$this . bgEnum $enumID .] + set $seedvar $seed + + after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] + return $enumID + } +} + +#!todo - make private? - put on a separate interface? +$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { + var this o_data + + + #Note that we don't post to the eventqueue using 'foreach s $slice' + # we only schedule another event after each item is processed + # - otherwise we would be spamming the eventqueue with items. + + #!todo? - accept a -granularity option to allow handling of n list-items per event? + + if {[llength $slice]} { + set slice [lassign $slice head] + + set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { + %cmd% [set %seedvar%] %val% + }] + + #post to eventqueue and re-enter _doBackgroundEnum + # + after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] + + } else { + #done. + + set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { + lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 + }] + + after idle [list after 0 [list uplevel #0 $script]] + } + + return +} + +$COL .. PatternMethod enumeratorstate {} { + var o_bgEnum + parray o_bgEnum +} + +#proc ::bgerror {args} { +# puts stderr "=bgerror===>$args" +#} + + +#map could be done in terms of the generic 'enumerate' method.. but it's slower. +# +#$PM map2 {proc} { +# var +# enumerate $_ID_ [list ::map-helper $proc] [list] +#} +#proc ::map-helper {proc accum item} { +# lappend accum [uplevel #0 [list {*}$proc $item]] +#} + +$COL .. PatternMethod map {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + + return $seed +} +$COL .. PatternMethod objectmap {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + + return $seed +} + + +#End core collection functionality. +#collection 'mixin' interfaces + +>pattern .. Create >keyvalprotector +>keyvalprotector .. PatternVariable o_protectedkeys +>keyvalprotector .. PatternVariable o_protectedvals + +#!todo - write test regarding errors in Constructors for mixins like this +# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args +>keyvalprotector .. Constructor {args} { + var this o_protectedkeys o_protectedvals + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -keys -vals ] + dict set default -keys [list] + dict set default -vals [list] + if {([llength $args] % 2) != 0} { + error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_protectedkeys [dict get $opts -keys] + set o_protectedvals [dict get $opts -vals] + #---------------------------------------------------------------------------- + set protections [concat $o_protectedkeys $o_protectedvals] + if {![llength $protections]} { + error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" + } + +} +>keyvalprotector .. PatternMethod clear {} { + error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" +} +>keyvalprotector .. PatternMethod pop {{idx ""}} { + var o_data o_count o_protectedkeys o_protectedvals + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." + } + set posn [lsearch -exact [dict keys $o_data] $key] + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + if {$result in $o_protectedvals} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." + } + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } + +} +>keyvalprotector .. PatternMethod remove {idx {endRange ""}} { + var this o_data o_count o_alias o_protectedkeys o_protectedvals + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" + } + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" + } + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#1) +#predicate methods (order preserving) +#usage: +# >collection .. Create >c1 +# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection + +#e.g >col1 . all {$val > 14} +#e.g >col1 . filterToCollection {$val > 19} . count +#e.g >col1 . filter {[string match "x*" $key]} +#!todo - fix. currying fails.. + +::>pattern .. Create >predicatedCollection +#process_pattern_aliases ::patternlib::>predicatedCollection + +set PM [>predicatedCollection .. PatternMethod .] + +>predicatedCollection .. PatternMethod filter {predicate} { + var this o_list o_array + set result [list] + + #!note (jmn 2004) how could we do smart filtering based on $posn? + #i.e it would make sense to lrange $o_list based on $posn... + #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? + #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. + #given this, is $posn even useful? + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToKeys {predicate} { + var this o_list o_array + set result [list] + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $key + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { + #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? + #!todo - implement as 'view' on current collection object.. extra o_list variables? + #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? + var this o_list o_array m_i_filteredCollection + + incr m_i_filteredCollection + if {![string length $destCollection]} { + #!todo? - implement 'one-shot' object (similar to RaTcl) + set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] + } else { + set result $destCollection + } + + #### + #externally manipulate new collection + #set ADD [$c . add .] + #foreach key $o_list { + # set val $o_array($key) + # if $predicate { + # $ADD $val $key + # } + #} + ### + + #internal manipulation faster + #set cID [lindex [set $result] 0] + set cID [lindex [$result --] 0] + + #use list to get keys so as to preserve order + set posn 0 + upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST + foreach key $o_list { + set val $o_array($key) + if $predicate { + if {[info exists cARRAY($key)]} { + error "key '$key' already exists in this collection" + } + lappend cLIST $key + set cARRAY($key) $val + } + incr posn + } + + return $result +} + +#NOTE! unbraced expr/if statements. We want to evaluate the predicate. +>predicatedCollection .. PatternMethod any {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + return 1 + } + incr posn + } + return 0 +} +>predicatedCollection .. PatternMethod all {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if !($predicate) { + return 0 + } + incr posn + } + return 1 +} +>predicatedCollection .. PatternMethod dropWhile {predicate} { + var this o_list o_array + set result [list] + set _idx 0 + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + incr _idx + } else { + break + } + incr posn + } + set remaining [lrange $o_list $_idx end] + foreach key $remaining { + set val $o_array($key) + lappend result $val + } + return $result +} +>predicatedCollection .. PatternMethod takeWhile {predicate} { + var this o_list o_array + set result [list] + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } else { + break + } + incr posn + } + set result +} + + + +#end >collection mixins +###################################### + + + + +#----------------------------------------------------------- +#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? +# Why do we need both? apart from the size variable, what is the use of hashMap? +#----------------------------------------------------------- +#::pattern::create >hashMap +::>pattern .. Create >hashMap + +>hashMap .. PatternVariable o_size +>hashMap .. PatternVariable o_array + +>hashMap .. Constructor {args} { + var o_array o_size + array set o_array [list] + set o_size 0 +} +>hashMap .. PatternDefaultMethod "item" +>hashMap .. PatternMethod item {key} { + var o_array + set o_array($key) +} +>hashMap .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>hashMap .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>hashMap .. PatternMethod add {val key} { + var o_array o_size + + set o_array($key) $val + incr o_size + return $key +} + +>hashMap .. PatternMethod del {key} { + var + puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>hashMap .. PatternMethod remove {key} { + var o_array o_size + unset o_array($key) + incr o_size -1 + return $key +} +>hashMap .. PatternMethod count {} { + var o_size + #array size o_array + return $o_size +} +>hashMap .. PatternMethod count2 {} { + var o_array + #array size o_array ;#slow, at least for TCLv8.4.4 + #even array statistics is faster than array size ! + #e.g return [lindex [array statistics o_array] 0] + #but.. apparently there are circumstances where array statistics doesn't report the correct size. + return [array size o_array] +} +>hashMap .. PatternMethod names {} { + var o_array + array names o_array +} +>hashMap .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>hashMap .. PatternMethod hasKey {key} { + var o_array + return [info exists o_array($key)] +} +>hashMap .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +#>hashMap .. Ready 1 + + + + + + + + + + + + + + + +#explicitly create metadata. Not required for user-defined patterns. +# this is only done here because this object is used for the metadata of all objects +# so the object must have all it's methods/props before its own metadata structure can be built. +#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" +#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" + + + + +if 0 { + + +#----------------------------------------------------------- +#::pattern::create >arrayHandle { +# variable o_arrayName +# variable this +#} +::>pattern .. Create >arrayHandle + +>arrayHandle .. PatternVariable o_arrayName +>arrayHandle .. PatternVariable this + +>arrayHandle .. Constructor {args} { + var o_arrayName this + set this @this@ + + + set o_arrayName [$this .. Namespace]::array + + upvar #0 $o_arrayName $this + #? how to automatically update this after a namespace import? + + array set $o_arrayName [list] + +} +>arrayHandle .. PatternMethod array {} { + var o_arrayName + return $o_arrayName +} + +#------------------------------------------------------- +#---- some experiments +>arrayHandle .. PatternMethod up {varname} { + var o_arrayName + + #is it dodgy to hard-code the calling depth? + #will it be different for different object systems? + #Will it even be consistent for the same object. + # Is this method necessary anyway? - + # - users can always instead do: + # upvar #0 [>instance . array] var + + uplevel 3 [list upvar 0 $o_arrayName $varname] + + return +} +>arrayHandle .. PatternMethod global {varname} { + var o_arrayName + # upvar #0 [>instance . array] var + + if {![string match ::* $varname]} { + set varname ::$varname + } + + upvar #0 $o_arrayName $varname + + return +} +>arrayHandle .. PatternMethod depth {} { + var o_arrayName + # + for {set i 0} {$i < [info level]} { + puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" + } + +} + # -------------------------------------------- + + +>arrayHandle .. PatternMethod item {key} { + var o_arrayName + set ${o_arrayName}($key) +} +>arrayHandle .. PatternMethod items {} { + var o_arrayName + + set result [list] + foreach nm [array names $o_arrayName] { + lappend result [set ${o_arrayName}($nm)] + } + return $result +} +>arrayHandle .. PatternMethod pairs {} { + var o_arrayName + + array get $o_arrayName +} +>arrayHandle .. PatternMethod add {val key} { + var o_arrayName + + set ${o_arrayName}($key) $val + return $key +} +>arrayHandle .. PatternMethod del {key} { + puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>arrayHandle .. PatternMethod remove {key} { + var o_arrayName + unset ${o_arrayName}($key) + return $key +} +>arrayHandle .. PatternMethod size {} { + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod count {} { + #alias for size + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod statistics {} { + var o_arrayName + return [array statistics $o_arrayName] +} +>arrayHandle .. PatternMethod names {} { + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod keys {} { + #synonym for names + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod hasKey {key} { + var o_arrayName + + return [info exists ${o_arrayName}($key)] +} +>arrayHandle .. PatternMethod clear {} { + var o_arrayName + unset $o_arrayName + array set $o_arrayName [list] + + return +} +#>arrayHandle .. Ready 1 + + + + +::>pattern .. Create >matrix + +>matrix .. PatternVariable o_array +>matrix .. PatternVariable o_size + +>matrix .. Constructor {args} { + var o_array o_size + + array set o_array [list] + set o_size 0 +} + + +#process_pattern_aliases ::patternlib::>matrix + +set PM [>matrix .. PatternMethod .] + +>matrix .. PatternMethod item {args} { + var o_array + + if {![llength $args]} { + error "indices required" + } else { + + } + if [info exists o_array($args)] { + return $o_array($args) + } else { + error "no such index: '$args'" + } +} +>matrix .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>matrix .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>matrix .. PatternMethod slice {args} { + var o_array + + if {"*" ni $args} { + lappend args * + } + + array get o_array $args +} +>matrix .. PatternMethod add {val args} { + var o_array o_size + + if {![llength $args]} { + error "indices required" + } + + set o_array($args) $val + incr o_size + + #return [array size o_array] + return $o_size +} +>matrix .. PatternMethod names {} { + var o_array + array names o_array +} +>matrix .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>matrix .. PatternMethod hasKey {args} { + var o_array + + return [info exists o_array($args)] +} +>matrix .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +>matrix .. PatternMethod count {} { + var o_size + return $o_size +} +>matrix .. PatternMethod count2 {} { + var o_array + #see comments for >hashMap count2 + return [array size o_array] +} +#>matrix .. Ready 1 + +#-------------------------------------------------------- +#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) +#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html +#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. +::>pattern .. Create >tree + +set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] +set _TREE_NODE $_NODE +#process_pattern_aliases $_TREE_NODE + +$_NODE .. PatternVariable o_treens ;#tree namespace +$_NODE .. PatternVariable o_idref +$_NODE .. PatternVariable o_nodePrototype + +#$_NODE .. PatternProperty data +$_NODE .. PatternProperty info + +$_NODE .. PatternProperty tree +$_NODE .. PatternProperty parent +$_NODE .. PatternProperty children +$_NODE .. PatternMethod addNode {} { + set nd_id [incr $o_idref] + set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] + @this@ . add $nd n-$nd_id + + return n-$nd_id +} +#flat list of all nodes below this +#!todo - something else? ad-hoc collections? +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod nodes {} { + set result [list] + + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + #eval lappend result $n [$o_array($n) . nodes] + #!todo - test + lappend result $n {*}[$o_array($n) . nodes] + } + return $result +} +#count of number of descendants +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod size {} { + set result 0 + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + incr result [expr {1 + [$o_array($n) . size]}] + } + return $result +} +$_NODE .. PatternMethod isLeaf {} { + #!todo - way to stop unused vars being uplevelled? + var o_tree + + #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? + tailcall [@this@ . isEmpty .] +} +$_NODE .. Constructor {args} { + array set A $args + + set o_tree $A(-tree) + set o_parent $A(-parent) + + #array set o_data [list] + array set o_info [list] + + set o_nodePrototype [::patternlib::>tree .. Namespace]::>node + set o_idref [$o_tree . nodeID .] + set o_treens [$o_tree .. Namespace] + #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] + + #overlay children collection directly on the node + set o_children [::patternlib::>collection .. Create @this@] + + return +} + +>tree .. PatternProperty test blah +>tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? +>tree .. PatternVariable o_ns +>tree .. Constructor {args} { + set o_ns [@this@ .. Namespace] + + #>tree is itself also a node (root node) + #overlay new 'root' node onto existing tree, pass tree to constructor + [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" +} + + + + +unset _NODE + + + + +#-------------------------------------------------------- +#a basic binary search tree experiment +# - todo - 'scheme' property to change behaviour? e.g balanced tree +::>pattern .. Create >bst +#process_pattern_aliases ::patternlib::>bst +>bst .. PatternVariable o_NS ;#namespace +>bst .. PatternVariable o_this ;#namespace +>bst .. PatternVariable o_nodeID + +>bst .. PatternProperty root "" +>bst .. Constructor {args} { + set o_this @this@ + set o_NS [$o_this .. Namespace] + namespace eval ${o_NS}::nodes {} + puts stdout ">bst constructor" + set o_nodeID 0 +} +>bst .. PatternMethod insert {key args} { + set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] + set [$newnode . key .] $key + if {[llength $args]} { + set [$newnode . value .] $args + } + if {![string length $o_root]} { + set o_root $newnode + set [$newnode . parent .] $o_this + } else { + set ipoint {} ;#insertion point + set tpoint $o_root ;#test point + set side {} + while {[string length $tpoint]} { + set ipoint $tpoint + if {[$newnode . key] < [$tpoint . key]} { + set tpoint [$tpoint . left] + set side left + } else { + set tpoint [$tpoint . right] + set side right + } + } + set [$newnode . parent .] $ipoint + set [$ipoint . $side .] $newnode + } + return $newnode +} +>bst .. PatternMethod item {key} { + if {![string length $o_root]} { + error "item $key not found" + } else { + set tpoint $o_root + while {[string length $tpoint]} { + if {[$tpoint . key] eq $key} { + return $tpoint + } else { + if {$key < [$tpoint . key]} { + set tpoint [$tpoint . left] + } else { + set tpoint [$tpoint . right] + } + } + } + error "item $key not found" + } +} +>bst .. PatternMethod inorder-walk {} { + if {[string length $o_root]} { + $o_root . inorder-walk + } + puts {} +} +>bst .. PatternMethod view {} { + array set result [list] + + if {[string length $o_root]} { + array set result [$o_root . view 0 [list]] + } + + foreach depth [lsort [array names result]] { + puts "$depth: $result($depth)" + } + +} +::>pattern .. Create >bstnode +#process_pattern_aliases ::patternlib::>bstnode +>bstnode .. PatternProperty parent +>bstnode .. PatternProperty left "" +>bstnode .. PatternProperty right "" +>bstnode .. PatternProperty key +>bstnode .. PatternProperty value + +>bstnode .. PatternMethod inorder-walk {} { + if {[string length $o_left]} { + $o_left . inorder-walk + } + + puts -nonewline "$o_key " + + if {[string length $o_right]} { + $o_right . inorder-walk + } + + return +} +>bstnode .. PatternMethod view {depth state} { + #!todo - show more useful representation of structure + set lower [incr depth] + + if {[string length $o_left]} { + set state [$o_left . view $lower $state] + } + + if {[string length $o_right]} { + set state [$o_right . view $lower $state] + } + + + array set s $state + lappend s($depth) $o_key + + return [array get s] +} + + +#-------------------------------------------------------- +#::pattern::create ::pattern::>metaObject +#::pattern::>metaObject PatternProperty methods +#::pattern::>metaObject PatternProperty properties +#::pattern::>metaObject PatternProperty PatternMethods +#::pattern::>metaObject PatternProperty patternProperties +#::pattern::>metaObject Constructor args { +# set this @this@ +# +# set [$this . methods .] [::>collection create [$this namespace]::methods] +# set [$this . properties .] [::>collection create [$this namespace]::properties] +# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] +# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] +# +#} + + + + #tidy up + unset PV + unset PM + + + +#-------------------------------------------------------- +::>pattern .. Create >enum +#process_pattern_aliases ::patternlib::>enum +>enum .. PatternMethod item {{idx 0}} { + var o_array o_list + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx'" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + error "no such index: '$idx'" + } else { + return $result + } + } +} + + + +#proc makeenum {type identifiers} { +# #!!todo - make generated procs import into whatever current system context? +# +# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 +# +# #obliterate any previous enum for this type +# catch {unset a1} +# catch {unset a2} +# +# set n 0 +# foreach id $identifiers { +# set a1($id) $n +# set a2($n) $id +# incr n +# } +# proc ::${type}_to_number key [string map [list @type@ $type] { +# upvar #0 wbpbenum_@type@_number ary +# if {[catch {set ary($key)} num]} { +# return -code error "unknown @type@ '$key'" +# } +# return $num +# }] +# +# proc ::number_to_${type} {number} [string map [list @type@ $type] { +# upvar #0 wbpbenum_number_@type@ ary +# if {[catch {set ary($number)} @type@]} { +# return -code error "no @type@ for '$number'" +# } +# return $@type@ +# }] +# +# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" +# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" +#} +# +#-------------------------------------------------------- +::>pattern .. Create >nest +>nest .. PatternVariable THIS +>nest .. PatternProperty data -autoclone +>nest .. Constructor {args} { + var o_data + var THIS + set THIS @this@ + array set o_data [list] +} +>nest .. PatternMethod item {args} { + set THIS @this@ + return [$THIS . data [join $args ,]] +} + +# +# e.g +# set [>nest a , b . data c .] blah +# >nest a , b , c +# +# set [>nest w x , y . data z .] etc +# >nest w x , y , z +#-------------------------------------------------------- + +} + +} + + +#package require patternlibtemp diff --git a/src/vendormodules/patternpredator2-1.2.8.tm b/src/vendormodules/patternpredator2-1.2.8.tm new file mode 100644 index 00000000..dd4f84c9 --- /dev/null +++ b/src/vendormodules/patternpredator2-1.2.8.tm @@ -0,0 +1,755 @@ + +proc ::p::internals::jaws {OID _ID_ args} { + #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" + #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) + #upvar #0 ::p::${OID}::_meta::map MAP + set MAP [set ::p::${OID}::_meta::map] + } else { + # error "jaws - OID = 'null' ???" + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key + } + set invocantdata [dict get $MAP invocantdata] + lassign $invocantdata OID alias default_method object_command wrapped + + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + if {$word in $terminals} { + set reduction [list 0 $_ID_ {*}$stack ] + #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" + + + set _ID_ [yield $reduction] + set stack [list] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _ID_ instead of MAP + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command + #lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + set command ::p::${OID}::$nextword + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command ;#taken from the MAP + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set command ::p::-1::$nextword + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + set stack [list $command] ;#faster, and intent is clearer than lappend. + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + set stack [list $command] + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set command $object_command + set stack [list "_exec_" $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack [list $command] + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + + } + } ;#end while + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + + + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] + yieldto return [::p::internals::ref_to_object $_ID_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _ID_ changed in this proc - we have updated the $OID variable + yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] + error "assert: never gets here" + } + set operator . + + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" + #set reduction [list 0 $_ID_ {*}$stack] + yieldto return [yield [list 0 $_ID_ {*}$stack]] + } {#} { + set unsupported 1 + } {,} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + + #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] + } + yieldto return $MAP + } {!} { + #error "untested branch" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] + } + lassign [dict get $MAP invocantdata] OID alias default_command object_command + set command $object_command + set stack [list "_exec_" $command] + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + lassign [dict get $MAP invocantdata] OID alias default_command object_command + #set command ::p::${OID}::item + set command ::p::${OID}::$default_command + lappend stack $command + set operator , + + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + + } + + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + #} + incr w + } + } + + + #final = 1 + #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" + + return [list 1 $_ID_ {*}$stack] +} + + + +#trailing. directly after object +proc ::p::internals::ref_to_object {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set refname ::p::${OID}::_ref::__OBJECT + + array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces + + set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] + if {[list {array} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {array} $traceCmd + } + + set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] + if {[list {write} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {write} $traceCmd + } + + set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] + if {[list {unset} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { + #if {[lindex $fullstack 0] eq "_exec_"} { + # #strip it. This instruction isn't relevant for a reference. + # set commandstack [lrange $fullstack 1 end] + #} else { + # set commandstack $fullstack + #} + #set argstack [lassign $commandstack command] + #set field [string map {> __OBJECT_} [namespace tail $command]] + + + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + #puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + } else { + #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] + } + lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_ID_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + #set iflist [lindex $map 1 0] + set iflist [dict get $MAP interfaces level0] + #set iflist [dict get $MAP interfaces level0] + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_ID_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod object_command + #get fully qualified varspace + + # + set propdict [$object_command .. GetPropertyInfo $field] + if {[dict exists $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::p::${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::p::${OID} + } + + + + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::p::${OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + # 2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] + } +} + + + +#trailing. after command/property +proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { + if {[lindex $fullstack 0] eq "_exec_"} { + #strip it. This instruction isn't relevant for a reference. + set commandstack [lrange $fullstack 1 end] + } else { + set commandstack $fullstack + } + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + + + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + ::p::internals::create_or_update_reference $OID $_ID_ $refname $command + return $refname +} + + +namespace eval pp { + variable operators [list .. . -- - & @ # , !] + variable operators_notin_args "" + foreach op $operators { + append operators_notin_args "({$op} ni \$args) && " + } + set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands + #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} +interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! + + + + + +# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. +#each map is a 2 element list of lists. +# form: {$commandinfo $interfaceinfo} +# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} + +#2018 +#each map is a dict. +#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} + + +#OID = Object ID (integer for now - could in future be a uuid) +proc ::p::predator2 {_ID_ args} { + #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + + #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. + #set this_role_members [dict get $invocants this] + #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. + #lassign $this_invocant this_OID this_info_dict + + set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + + set cheat 1 ;# + #------- + #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) + #(it should be functionally equivalent to remove this shortcut block) + if {$cheat} { + if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { + + set remaining_args [lassign $args dot method_or_prop] + + #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? + set command ::p::${this_OID}::$method_or_prop + #REVIEW! + #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') + #if {[llength $command] > 1} { + # error "methods with spaces not included in test suites - todo fix!" + #} + #Dont use {*}$command - (so we can support methods with spaces) + #if {![llength [info commands $command]]} {} + if {[namespace which $command] eq ""} { + if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { + #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces + set command ::p::${this_OID}::(UNKNOWN) + #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + #tailcall {*}$command $_ID_ {*}$remaining_args + tailcall $command $_ID_ {*}$remaining_args + } + } + } + #------------ + + + if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { + return $_ID_ + } + + + #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" + + + + #puts stderr "this_info_dict: $this_info_dict" + + + + + if {![llength $args]} { + #should return some sort of public info.. i.e probably not the ID which is an implementation detail + #return cmd + return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID + + #return a dict keyed on object command name - (suitable as use for a .. Create 'target') + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped + #return [list $object_command [list -id $this_OID ]] + } elseif {[llength $args] == 1} { + #short-circuit the single index case for speed. + if {[lindex $args 0] ni {.. . -- - & @ # , !}} { + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method + lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method + + tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] + } elseif {[lindex $args 0] eq {--}} { + + #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. + # - combined with using UUIDs for $OID, and a secured/removed metaface on the object + # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) + # - this could effectively hide the object's namespaces,vars etc from the caller (?) + return [set ::p::${this_OID}::_meta::map] + } + } + + + + #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) + #incr c + #set reduce ::p::reducer${this_OID}_$c + set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] + #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" + coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args + + + set current_ID_ $_ID_ + + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] + #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" + #if {[string match *Destroy $command]} { + # puts stdout " calling Destroy reduction_args:'$reduction_args'" + #} + if {$final == 1} { + + if {[llength $command] == 1} { + if {$command eq "_exec_"} { + tailcall {*}$reduction_args + } + if {[llength [info commands $command]]} { + tailcall {*}$command $current_ID_ {*}$reduction_args + } + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + lset command 0 ::p::${this_OID}::(UNKNOWN) + tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}$reduction_args + } + + + } else { + if {[lindex $command 0] eq "_exec_"} { + set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] + + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + } else { + if {[llength $command] == 1} { + if {![llength [info commands $command]]} { + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + + lset command 0 ::p::${this_OID}::(UNKNOWN) + set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + } else { + #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + + } + } else { + set result [uplevel 1 [list {*}$command {*}$reduction_args]] + } + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set current_ID_ [$result .. INVOCANTDATA] + + + #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA + #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { + # set current_ID_ $result_invocantdata + #} else { + # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" + #} + } else { + #non-pattern command + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + + } + } + + } + } + error "Assert: Shouldn't get here (end of ::p::predator2)" + #return $result +} + +package provide patternpredator2 1.2.8 diff --git a/src/vendormodules/tarjar-2.4.2.tm b/src/vendormodules/tarjar-2.4.2.tm new file mode 100644 index 00000000..c2c8464e Binary files /dev/null and b/src/vendormodules/tarjar-2.4.2.tm differ diff --git a/src/vendormodules/vfs/inmem-0.1.tm b/src/vendormodules/vfs/inmem-0.1.tm deleted file mode 100644 index e1aa76cc..00000000 --- a/src/vendormodules/vfs/inmem-0.1.tm +++ /dev/null @@ -1,495 +0,0 @@ - -#START-tarpack-loadscript-header---------------------------------------------------------------------------- -# -#If there is data above this header, then this is a tarpack. Do not edit the code whilst in 'packed' form. -# -#If there is no data above the header, it is an unpacked fragment of a tarpack and may be edited. -#Make sure however that your editor preserves the trailing comment (#) as the final character. -# -# A tarpack is a valid tar archive in which the first archived file consists of tcl script -# containing a leading newline and a trailing comment (#) character. -# The comment character hides the tar-header for the next file from Tcl. -# This first file in the tarball must be named with the prefix #tarpack-loadscript -# -# The next file is named #z and contains a final ctrl-z to tell Tcl it has reached the end of scripts -# (and thus to stop interpreting). -# The #z file is separate from the initial script file because some editors may not be able to handle the -# ctrl-z character. -# The tarball should have its contents within a single directory named #tarpack-- -# -# This header and the call to tarpack::disconnect are needed to: -# a) redirect to the unwrapped version of the tarpack -# b) enable sourcing & loading of other files contained in the tarpack - - -set TEMP_auto_path $::auto_path; set ::auto_path [list] -if {![catch {package require tarpack}]} { - #Do not wrap 'tarpack::connect' in its own 'catch'! - #for unwrapped execution, tarpack::connect may need to abort the 'source' operation using returneval. - set ::auto_path $TEMP_auto_path; unset TEMP_auto_path - ::tarpack::connect [info script] -} else { - set ::auto_path $TEMP_auto_path; unset TEMP_auto_path -} - - -# -#END-tarpack-loadscript-header------------------------------------------------------------------------------ - - - - -#START-tarpack-loadscript-tidy------------------------------------------------------------------------------ -# -::tarpack::disconnect [info script] -# -#END-tarpack-loadscript-tidy-------------------------------------------------------------------------------- -#This tarpack initially generated using tarpack::wrap inmem-1.0.tcl -#-------------------------script + tarpack footer follow------------------------- - -# Package vfs::inmem provides an in-memory file system; this is -# useful if you want a small file system on which you can -# mount other kinds of files and store small amounts of data. - -package provide vfs::inmem 0.1 - -# We use dicts, so we need Tcl 8.5 or later. - -package require Tcl 8.5- -package require vfs 1.0- - -# The "fsdata" array contains dicts describing file systems. The dicts -# represents a file structure. The file structure uses the following keys: -# -# data the file's data; what this is depends on the "type" -# attribute of the "stat" entry for the file. (See below.) -# For type "directory", it is a dict whose keys are directory -# names; the dict entries will be file structures. -# -# stat file attributes: file type, access permissions, etc. -# The data associated with this key is a dictionary -# containing data in the form returned by the "file stat" -# command. The only mandatory info is the file type. -# -# meta metadata associated with this file. This could be -# anything. -# -# fsdata is indexed by an arbitrarily-selected key supplied by the -# "Mount" command. - -namespace eval vfs::inmem { - variable fsdata - variable localmap -} - - -################################# -# # -# U T I L I T I E S # -# # -################################# - -# _dictpath converts "relpath" to a list of keys that indexes -# into the nested file structures. "relpath" is assumed to be -# a list of pathname components. (Basicly, this consists of putting -# the word "data" before the list element names.) No checking -# is done to ensure that the path is valid. - -proc vfs::inmem::_dictpath {relpath} { - set keylist [list] - foreach component $relpath { - lappend keylist data $component - } - return $keylist -} - -# _checkpath checks a relative path to make sure that all components -# except the last exist and are directories. It returns 1 on success, -# and throws an error otherwise. - -proc vfs::inmem::_checkpath {fsname relpath} { - variable fsdata - - if {![info exists fsdata($fsname)]} { - return -code error "File system \"$fsname\" doesn't exist." - } - - set dirdata $fsdata($fsname) - set reldir [lrange $relpath 0 end-1] - set file [lindex $relpath end] - - foreach component $reldir { - if {![string equal [dict get $dirdata stat type] "directory"]} { - return -code error "Path component is not a directory" - } - - set dirdata [dict get $dirdata data] - set dirdata [dict get $dirdata $component] - } - - return 1 -} - -# _getfiledict returns the dictionary associated with the file -# within file system "fsname" that is specified by "relpath". - -proc vfs::inmem::_getfiledict {fsname relpath} { - variable fsdata - - set dictpath [_dictpath $relpath] - if {[llength $dictpath] == 0} { - return $fsdata($fsname) - } - #return [eval [list dict get $fsdata($fsname)] $dictpath] - dict get $fsdata($fsname) {expand}$dictpath -} - -# _newstatinfo creates a dictionary appropriate for use as the "stat" -# entry for a file of type "type". - -proc vfs::inmem::_newstatinfo {type} { - return [dict create \ - atime [clock seconds] \ - ctime [clock seconds] \ - dev -1 \ - gid -1 \ - ino -1 \ - mode 0777 \ - mtime [clock seconds] \ - nlink 1 \ - size 0 \ - type $type \ - uid -1 \ - ] -} - -# _updatetime updates access/creation/modification times for -# the file given by "relpath". Which time to update is determined -# by the "timetype" argument, which should be one of "atime", -# "ctime", or "mtime". (This argument is NOT checked, so be careful!) - -proc vfs::inmem::_updatetime {fsname relpath timetype} { - variable fsdata - - set fpath [_dictpath $relpath] - dict set fsdata($fsname) {expand}$fpath stat $timetype [clock seconds] -} - -################################# -# # -# V F S P R O C S # -# # -################################# - -# The procs that follow are the ones required by the Tcl vfs package. - - -# Mount mounts an in-memory file system named "fsname" on the -# local mount point "local". "fsname" is an arbitrary key; -# it must be unique among all inmem vfs file systems. It returns -# the mount point. - -proc vfs::inmem::Mount {fsname local} { - variable fsdata - variable localmap - - # Make an empty directory. - - set fsdata($fsname) [dict create \ - data [dict create] \ - stat [_newstatinfo directory] \ - meta "" \ - ] - - vfs::filesystem mount $local [list vfs::inmem::handler $fsname] - vfs::RegisterMount $local [list vfs::inmem::Unmount] - set localmap($local) $fsname - - return $local -} - -# Unmount unmounts file system "local". - -proc vfs::inmem::Unmount {local} { - variable fsdata - variable localmap - - set fsname $localmap($local) - catch [list unset fsdata(fsname)] - vfs::filesystem unmount $local -} - -# This is the generic handler for file system commands. It dispatches -# calls to other handler functions. - -proc vfs::inmem::handler {fsname cmd root relative actualpath args} { - variable fsdata - - set relative [file split $relative] - - if {$cmd == "matchindirectory"} { - #eval [list $cmd $fsname $relative $actualpath] $args - $cmd $fsname $relative $actualpath {expand}$args - } else { - #eval [list $cmd $fsname $relative] $args - $cmd $fsname $relative {expand}$args - } -} - -# "stat" implements the "file stat" command. It accepts the -# file system name and the path name as arguments, and -# returns the file's status info as a dict. - -proc vfs::inmem::stat {fsname name} { - _checkpath $fsname $name - set fdict [_getfiledict $fsname $name] - return [dict get $fdict stat] -} - -proc vfs::inmem::access {fsname name mode} { - variable fsdata - - _checkpath $fsname $name - - set fdict [_getfiledict $fsname $name] - - set statInfo [dict get $fdict stat] - set fmode [dict get $statInfo mode] - - # We're assuming the file is owned by us and has our own - # gid. (Since it's seen only within this app, that has - # to be true.) - - return [expr {($mode & $fmode) != 0}] -} - -# vfs::inmem::exists returns 1 if file "name" exists on file -# system "fsname"; it returns zero otherwise. - -proc vfs::inmem::exists {fsname name} { - set ecode [catch [list _getfiledict $fsname $name] fdict] - - if {$ecode} { - return 0 - } - return 1 -} - -# Open a file. This returns a list containing two elements: -# 1. the Tcl channel name which has been opened -# 2. (optional) a command to evaluate when the channel is closed. - -proc vfs::inmem::open {fsname name mode permissions} { - variable fsdata - - - switch -- $mode { - "" - - "r" { - # The file was opened for read; we'll read the - # data out of the filesystem's dict and stuff - # it into a memchan file descriptor. We pass - # the memchan file descriptor back so that the - # data can be read from it. - - set nfd [vfs::memchan] - fconfigure $nfd -translation binary - set fdict [_getfiledict $fsname $name] - puts -nonewline $nfd [dict get $fdict data] - _updatetime $fsname $name atime - fconfigure $nfd -translation auto - seek $nfd 0 - return [list $nfd] - } - "w" { - # Open for write; we pass back an empty memchan, - # and on close we read the data out of it and put - # it into the file. - - set dictpath [_dictpath $name] - if {![exists $fsname $name]} { - set emptydata [dict create data {} \ - stat [_newstatinfo file] \ - meta {}] - dict set fsdata($fsname) {expand}$dictpath $emptydata - _updatetime $fsname $name ctime - _updatetime $fsname $name atime - } - _updatetime $fsname $name mtime - dict set fsdata($fsname) {expand}$dictpath stat size 0 - set nfd [vfs::memchan] - return [list $nfd [list ::vfs::inmem::_close $fsname $name $nfd]] - } - "a" { - # Open for append; this is pretty much like write, except - # that we put the data in it initially. - - set dictpath [_dictpath $name] - if {![exists $fsname $name]} { - set emptydata [dict create data {} \ - stat [_newstatinfo file] \ - meta {}] - dict set fsdata($fsname) {expand}$dictpath $emptydata - set initData "" - _updatetime $fsname $name ctime - _updatetime $fsname $name atime - } else { - set initData [dict get $fsdata($fsname) {expand}$dictpath data] - } - _updatetime $fsname $name mtime - dict set fsdata($fsname) {expand}$dictpath stat size \ - [string bytelength $initData] - set nfd [vfs::memchan] - fconfigure $nfd -translation binary - puts -nonewline $nfd $initData - _updatetime $fsname $name atime - fconfigure $nfd -translation auto - return [list $nfd [list ::vfs::inmem::_close $fsname $name $nfd]] - } - default { - return -code error "illegal or unimplemented access mode \"$mode\"" - } - } -} - - -# _close is called when we close a file we're writing to. It reads -# the data out of the memchan it was written to and puts it into -# the filesystem's dict. - -proc vfs::inmem::_close {fsname name nfd} { - variable fsdata - - set fpath [_dictpath $name] - seek $nfd 0 - set filedata [read $nfd] - dict set fsdata($fsname) {expand}$fpath data $filedata - dict set fsdata($fsname) {expand}$fpath stat size \ - [string bytelength $filedata] - _updatetime $fsname $name mtime - - close $nfd -} - - -# vfs::inmem::matchindirectory does a glob-style match on a single -# directory in an inmem filesystem. - -proc vfs::inmem::matchindirectory {fsname path actualpath pattern type} { - set dirdict [_getfiledict $fsname $path] - - # "res" will contain the matched directory. - - set res [list] - set filelist [dict get $dirdict data] - foreach f [dict keys $filelist] { - if {[string length $pattern] == 0 || [string match $pattern $f]} { - set ftype [dict get $filelist $f stat type] - switch $ftype { - directory { - if {[::vfs::matchDirectories $type]} { - lappend res $f - } - } - file { - if {[::vfs::matchFiles $type]} { - lappend res $f - } - } - link { - #@@@ NOT YET IMPLEMENTED @@@# - } - } - } - } - - # Prepend the directory name onto every name in the list. - - set realres [list] - foreach r $res { - lappend realres [file join $actualpath $r] - } - - return $realres -} - - -# vfs::inmem::createdirectory creates a directory entry for -# an inmem filesystem. It creates an entry in the filesystem's -# dict. - -proc vfs::inmem::createdirectory {fsname name} { - variable fsdata - - if {[string equal "" $name]} { - return - } - - if {[exists $fsname $name]} { - return - } - - set parent [lrange $name 0 end-1] - set dirname [lindex $name end] - set dictpath [_dictpath $parent] - lappend dictpath data - set newdir [dict create \ - data {} \ - stat [_newstatinfo directory] \ - ] - - dict set fsdata($fsname) {expand}$dictpath $dirname $newdir - _updatetime $fsname $parent mtime -} - - -# Remove a directory. - -proc vfs::inmem::removedirectory {fsname name recursive} { - variable fsdata - - set parent [lrange $name 0 end-1] - set dictpath [_dictpath $name] - dict unset fsdata($fsname) {expand}$dictpath - _updatetime $fsname $parent mtime -} - - -# Delete a file. - -proc vfs::inmem::deletefile {fsname name} { - variable fsdata - - set parent [lrange $name 0 end-1] - set dictpath [_dictpath $name] - dict unset fsdata($fsname) {expand}$dictpath - _updatetime $fsname $parent mtime -} - - -# fileattributes returns or sets filesystem-dependent file attributes. - -proc vfs::inmem::fileattributes {fsname name args} { - switch -- [llength $args] { - 0 { - # list strings - return [list "Unimplemented"] - } - 1 { - # get value - } - 2 { - # set value - } - } -} - - -#@@@ I don't know if this is necessary... @@@# - -proc vfs::inmem::utime {what name actime mtime} { - error "" -} - -#Do not remove the trailing comment character from this file. -# \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/metaface-1.2.8.tm b/src/vfs/_vfscommon.vfs/modules/metaface-1.2.8.tm index 39a54c8c..c216b1df 100644 --- a/src/vfs/_vfscommon.vfs/modules/metaface-1.2.8.tm +++ b/src/vfs/_vfscommon.vfs/modules/metaface-1.2.8.tm @@ -1,44 +1,44 @@ package require dictutils package provide metaface [namespace eval metaface { variable version - set version 1.2.8 + set version 1.2.8 }] # 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+ -# 2023-07 - add .. MetaMethods +# 2023-07 - add .. MetaMethods #example datastructure: #$_ID_ #{ -#i -# { -# this -# { -# {16 ::p::16 item ::>x {}} -# } -# role2 -# { -# {17 ::p::17 item ::>y {}} -# {18 ::p::18 item ::>z {}} -# } -# } +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } #context {} #} #$MAP -#invocantdata {16 ::p::16 item ::>x {}} -#interfaces {level0 -# { -# api0 {stack {123 999}} -# api1 {stack {333}} -# } -# level0_default api0 -# level1 -# { -# } -# level1_default {} -# } +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } #patterndata {patterndefaultmethod {}} @@ -105,7 +105,7 @@ proc ::p::predator::getprop_template_immediate {_ID_ args} { set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] if {$rType eq "object"} { #return [$val . item {*}$args] - #don't assume defaultmethod named 'item'! + #don't assume defaultmethod named 'item'! return [$val {*}$args] } else { #treat as list? @@ -127,60 +127,60 @@ proc ::p::predator::getprop_template_immediate {_ID_ args} { proc ::p::predator::getprop_array {_ID_ prop args} { set OID [lindex [dict get $_ID_ i this] 0 0] - #upvar 0 ::p::${OID}::o_${prop} prop - #1st try: assume array - if {[catch {array get ::p::${OID}::o_${prop}} result]} { - #treat as list (why?) - #!review - if {[info exists ::p::${OID}::o_${prop}]} { - array set temp [::list] - set i 0 - foreach element ::p::${OID}::o_${prop} { - set temp($i) $element - incr i - } - set result [array get temp] - } else { - error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" - } - } - return $result + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result } proc ::p::predator::setprop_template {prop _ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args] == 1} { - #return [set ::p::${OID}::o_%prop% [lindex $args 0]] - return [set ${ns}::o_%prop% [lindex $args 0]] - - } else { - if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { - #treat attempt to perform indexed write to nonexistant var, same as indexed write to array - - #2 args - single index followed by a value - if {[llength $args] == 2} { - return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] - } else { - #multiple indices - #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] - return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] - } - } else { - #treat as list - return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] - } - } + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } } #-------------------------------------- @@ -189,7 +189,7 @@ proc ::p::predator::setprop_template {prop _ID_ args} { proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { - + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. @@ -210,7 +210,7 @@ proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtrace set $refname $newval } } - return + return } } @@ -218,80 +218,80 @@ proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtrace proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { - #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" - - - #derive the name of the write command from the ref var. - set indices [lassign [split [namespace tail $refname] +] prop] - - - #assert - we will never have both a list in indices and an idx value - if {[llength $indices] && ($idx ne "")} { - #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x - #review - are there any datastructures which would/should allow this? - #this assertion is really just here as a sanity check for now - error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" - } - - #upvar #0 ::p::${OID}::_meta::map MAP - #puts "-->propref_trace_write map: $MAP" - - #temporarily deactivate refsync trace - #puts stderr -->1>--removing_trace_o_${field} -### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - #we need to catch, and re-raise any error that we may receive when writing the property - # because we have to reinstate the propvar_write_TraceHandler after the call. - #(e.g there may be a propertywrite handler that deliberately raises an error) - - set excludesync_refs $refname - set cmd ::p::${OID}::(SET)$prop - - - set f_error 0 - if {[catch { - - if {![llength $indices]} { - if {[string length $idx]} { - $cmd $_ID_ $idx [set ${refname}($idx)] - #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] - - } else { - $cmd $_ID_ [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] - } - } else { - #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" - $cmd $_ID_ {*}$indices [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices - } - - } result]} { - set f_error 1 - } - - - - - #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write - #reactivate refsync trace - #puts stderr "****** reactivating refsync trace on o_$field" - #puts stderr -->2>--reactivating_trace_o_${field} + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - if {$f_error} { - #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. - # ? return -code error $errMsg ? -errorinfo + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo - #!quick n dirty - #error $errorMsg - return -code error -errorinfo $::errorInfo $result - } else { - return $result - } + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } } @@ -301,7 +301,7 @@ proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname id proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') - + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set #set updated_value [::p::predator::getprop_array $prop $_ID_] @@ -311,7 +311,7 @@ proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { array set $refname {} } - #return value ignored for + #return value ignored for } @@ -319,7 +319,7 @@ proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { # proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd + lassign [dict get $MAP invocantdata] OID alias itemCmd #don't rely on variable name passed by trace - may have been 'upvar'ed @@ -334,7 +334,7 @@ proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { #!todo - get propertylist from cache on object(?) foreach IFID [lreverse $iflist] { dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { - #lassign $pdef v + #lassign $pdef v if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { if {[array exists ::p::${OID}::o_${prop}]} { lappend plist $prop [array get ::p::${OID}::o_${prop}] @@ -346,419 +346,395 @@ proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { } } } - array set $refvar $plist + array set $refvar $plist } proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" - - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - if {[string length $IID]} { - #property - if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { - puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" - } - } else { - #method - error "property '$idx' not found" - } -} + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd - lassign [dict get $MAP invocantdata] OID alias itemCmd - - #!todo - ??? - - if {![llength [info commands ::p::${OID}::$idx]]} { - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set found 0 - foreach id [lreverse $iflist] { + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { set found 1 break } - } - - if {$found} { - unset ::p::${OID}::o_$idx - } else { - puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" - } - } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } } proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" - - - if {![llength [info commands ::p::${OID}::$idx]]} { - #!todo - create new property in interface upon attempt to write to non-existant? - # - or should we require some different kind of object-reference for that? - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { set IID $id break } - } + } - #$IID is now topmost interface in default iStack which has this property + #$IID is now topmost interface in default iStack which has this property - if {[string length $IID]} { - #write to defined property + if {[string length $IID]} { + #write to defined property - ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] - } else { - #!todo - allow write of method body back to underlying object? - #attempted write to 'method' ..undo(?) - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "cannot write to method '$idx'" - #for now - disallow - } - } + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } } proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { - #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - - set refindices [lassign [split [namespace tail $refname] +] prop] - #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop - #if there is no PropertyUnset command - we unset the underlying variable directly - - trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - - if {[catch { - - #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value - #i.e - if {[llength $refindices] && [string length $idx]} { - puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" - error "unexpected call to propref_trace_unset" - } - - - upvar #0 ::p::${OID}::_meta::map MAP - - set iflist [dict get $MAP interfaces level0] - #find topmost interface containing this $prop - set IID "" - foreach id [lreverse $iflist] { - if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - if {![string length $IID]} { - error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" - } - - - - - - - if {[string length $idx]} { - #eval "$_alias ${unset_}$field $idx" - #what happens to $refindices??? - - - #!todo varspace - - if {![llength $refindices]} { - #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop}($idx) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx - } - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx - } else { - #assert - won't get here - error 1a - - } - - } else { - if {[llength $refindices]} { - #error 2a - #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - #review - what about list-type property? - #if {[array exists ::p::${OID}::o_${prop}]} ??? - unset ::p::${OID}::o_${prop}($refindices) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices - } - - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices - - - } else { - #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - #ref is not of form prop+x etc and no idx in the trace - this is a plain unset - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop} - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" - } - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} - - } - } - - - - - } errM]} { - #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" - set ruler [string repeat - 80] - puts stderr "\t$ruler" - puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - puts stderr "\t$ruler" - puts stderr $errM - puts stderr "\t$ruler" - - } else { - #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - #puts stderr "*@*@*@*@ end propref_trace_unset - no error" - } - - trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + } proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + if {[array exists SYNCVARIABLE]} { + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - if {[string length $triggeringRef]} { - set idx [lsearch -exact $refvars $triggeringRef] - if {$idx >= 0} { - set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] - } - } - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" - return - } - - - #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset - # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" - if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { - #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" - puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" - } - - - puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " - - - - upvar $vtraced SYNCVARIABLE - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - - #set triggeringRefIdx $vidx - - if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { - set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] - } else { - set triggering_indices [list] - } - - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #check indices of triggering refvar match this refvars indices - - - if {$reftail eq [namespace tail $triggeringRef]} { - #!todo - add test - error "untested, possibly unused branch spuds2" - #puts "222222222222222222" - unset $refvar - } else { - - #error "untested - branch spuds2a" - - - } - - } else { - #!todo -add test - #reference is directly to property var - error "untested, possibly unused branch spuds3" - #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? - puts "\t33333333333333333333" - - if {[string length $triggeringRefIdx]} { - unset $refvar($triggeringRefIdx) - } - } - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - @@ -768,676 +744,653 @@ proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtrace proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { - upvar $vtraced SYNCVARIABLE - - set refvars [::list] - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - #short_circuit breaks unset traces for array elements (why?) - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - return - } else { - puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - } - - if {[catch { - - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - set triggeringRefIdx $vidx - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - unset $refvar - - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - } errM]} { - set ruler [string repeat * 80] - puts stderr "\t$ruler" - puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" - puts stderr "\t$ruler" - puts stderr $::errorInfo - puts stderr "\t$ruler" - - } - + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + } proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { - error hmmmmm - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " - set refvars [::list] - - #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - #assert triggeringRef is in the list - if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { - error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" - } - set refposn [lsearch -exact $refvars $triggeringRef] - #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 - set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" - return [list refs_updates [list]] - } - - #suppress the propref_trace_* traces on all refvars - array set traces [::list] - array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." - #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync - #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? - #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #all other traces are 'external' - lappend external_traces($rv) $tinfo - #trace remove variable $rv $ops $cmd - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - if {![info exists SYNCVARIABLE]} { - error "WARNING: REVIEW why does $vartraced not exist here?" - } - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set treat_vtraced_as_array 1 - } else { - set treat_vtraced_as_array 0 - } - - set refs_updated [list] - set refs_deleted [list] ;#unset due to index no longer being relevant - if {$treat_vtraced_as_array} { - foreach refvar $refvars { - #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - if {[llength $indices]} { - if {[llength $indices] == 1} { - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - #error "untested xxx-a" - set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] - lappend refs_updated $refvar - } else { - #test exists - #error "xxx-ok single index" - #updating a different part of the property - nothing to do - } - } else { - #nested index - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - if {[llength $ref_indices] == 1} { - #error "untested xxx-b1" - set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] - } else { - #assert llength $ref_indices > 1 - #NOTE - we cannot test index equivalence reliably/simply just by comparing indices - #compare by value - - if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { - #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" - if {[set $refvar] ne $possiblyNewVal} { - set $refvar $possiblyNewVal - } - } else { - #fail to retrieve underlying value corrsponding to these $indices - unset $refvar - } - } - } else { - #test exists - #error "untested xxx-ok deepindex" - #updating a different part of the property - nothing to do - } - } - } else { - error "untested xxx-c" - - } - - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - if {[llength $indices] == 1} { - set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] - } else { - lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] - } - lappend refs_updated $refvar - } else { - error "untested yyy" - set $refvar $SYNCVARIABLE - } - } - } - } else { - #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) - # - foreach refvar $refvars { - #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - - if {[llength $indices]} { - #see if this update would affect this curried ref - #1st see if we can short-circuit our comparison based on numeric-indices - if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { - #both sets of indices are purely numeric (no end end-1 etc) - set rlen [llength $ref_indices] - set ilen [llength $indices] - set minlen [expr {min($rlen,$ilen)}] - set matched_firstfew_indices 1 ;#assume the best - for {set i 0} {$i < $minlen} {incr i} { - if {[lindex $ref_indices $i] ne [lindex $indices $i]} { - break ;# - } - } - if {!$matched_firstfew_indices} { - #update of this refvar not required - #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" - break ;#break to next refvar in the foreach loop - } - } - #failed to short-circuit - - #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set $refvar] ne $newval} { - set $refvar $newval - lappend refs_updated $refvar - } - - } else { - #we must be updating the entire variable - so this curried ref will either need to be updated or unset - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set ${refvar}] ne $newval} { - set ${refvar} $newval - lappend refs_updated $refvar - } - } - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - #error "untested zzz-a" - set newval [lindex $SYNCVARIABLE $indices] - if {[lindex [set $refvar] $indices] ne $newval} { - lset ${refvar} $indices $newval - lappend refs_updated $refvar - } - } else { - if {[set ${refvar}] ne $SYNCVARIABLE} { - set ${refvar} $SYNCVARIABLE - lappend refs_updated $refvar - } - } - - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - - #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - } - foreach rv [array names external_traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - #trace add variable $rv $ops $cmd - } - } - } - - - return [list updated_refs $refs_updated] + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] } #purpose: update all relevant references when context variable changed directly proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { - #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. - #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler - - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" - set t_info [trace info variable $vtraced] - foreach t_spec $t_info { - set t_ops [lindex $t_spec 0] - if {$op in $t_ops} { - puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + #set t_info [trace info variable $vtraced] + #foreach t_spec $t_info { + # set t_ops [lindex $t_spec 0] + # if {$op in $t_ops} { + # puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + # } + #} + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + } else { + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + } + + } else { + #no vidx + + if {$vtracedIsArray} { + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + } + + } + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd } } - - #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- - #vtype = array | array-item | list | simple - - set refvars [::list] - - ############################ - #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! - #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) - #The alternative 'info vars' does not trigger traces - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - ############################ - - #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" - return - } - - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars - array set predator_traces [::list] - #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. - #ie for something like 'trace add variable someref {write read array} somefunc' - # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace - array set external_read_traces [::list] ;#pure read traces the library user may have added - array set external_readetc_traces [::list] ;#read + something else traces the library user may have added - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - #if {$ops in {read write unset array}} {} - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend predator_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #other traces - # puts "##trace $tinfo" - if {"read" in $ops} { - if {[llength $ops] == 1} { - #pure read - - lappend external_read_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - } else { - #mixed operation trace - remove and reinstall without the 'read' - lappend external_readetc_traces($rv) $tinfo - set other_ops [lsearch -all -inline -not $ops "read"] - trace remove variable $rv $ops $cmd - #reinstall trace for non-read operations only - trace add variable $rv $other_ops $cmd - } - } - } - } - } - - - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set vtracedIsArray 1 - } else { - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" - #puts "**write*********** refvars: $refvars" - - #!todo? unroll foreach into multiple foreaches within ifs? - #foreach refvar $refvars {} - - - #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" - if {[string length $vidx]} { - #indexable - if {$vtracedIsArray} { - - foreach refvar $refvars { - #puts stderr " - - a refvar $refvar vidx: $vidx" - set tail [namespace tail $refvar] - if {[string match "${prop}+*" $tail]} { - #refvar is curried - #only set if vidx matches curried index - #!todo -review - set idx [lrange [split $tail +] 1 end] - if {$idx eq $vidx} { - set newval [set SYNCVARIABLE($vidx)] - if {[set $refvar] ne $newval} { - set ${refvar} $newval - } - #puts stderr "=a.1=> updated $refvar" - } - } else { - #refvar is simple - set newval [set SYNCVARIABLE($vidx)] - if {![info exists ${refvar}($vidx)]} { - #new key for this array - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } else { - set oldval [set ${refvar}($vidx)] - if {$oldval ne $newval} { - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } - } - #puts stderr "=a.2=> updated ${refvar} $vidx" - } - } - - - - } else { - - - foreach refvar $refvars { - upvar $refvar internal_property_reference - #puts stderr " - - b vidx: $vidx" - - #!? could be object not list?? - #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? - #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) - #There would still be an edge case of an initial write of a list of objects of length 1. - if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { - error "untested review!" - #the o_prop is object-shaped - #assumes object has a defaultmethod which accepts indices - set newval [[set $SYNCVARIABLE] {*}$vidx] - - } else { - set newval [lindex $SYNCVARIABLE {*}$vidx] - #if {[set $refvar] ne $newval} { - # set $refvar $newval - #} - if {$internal_property_reference ne $newval} { - set internal_property_reference $newval - } - - } - #puts stderr "=b=> updated $refvar" - } - - - } - - - - } else { - #no vidx - - if {$vtracedIsArray} { - - - foreach refvar $refvars { - set targetref_tail [namespace tail $refvar] - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - - #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" - if {$targetref_is_indexed} { - #curried array item ref of the form ${prop}+x or ${prop}+x+y etc - - #unindexed write on a property that is acting as an array.. - - #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. - - #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). - # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. - puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" - } else { - #How do we know what to write to array ref? - puts stderr "\tc.2 WARNING: unimplemented/unused?" - #error no_tests_for_branch - - #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation - #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate - array unset ${refvar} - array set ${refvar} [array get SYNCVARIABLE] - } - } - - - - } else { - foreach refvar $refvars { - #puts stderr "\t\t_________________[namespace current]" - set targetref_tail [namespace tail $refvar] - upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - if {$targetref_is_indexed} { - #puts "XXXXXXXXX vtraced:$vtraced" - #reference curried with index(es) - #we only set indexed refs if value has changed - # - this not required to be consistent with standard list-containing variable traces, - # as normally list elements can't be traced seperately anyway. - # - - - #only bother checking a ref if no setVia index - # i.e some operation on entire variable so need to test synchronisation for each element-ref - set targetref_indices [lrange [split $targetref_tail +] 1 end] - set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] - #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal - #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" - } - - - } else { - #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! - - #puts stderr "- d2 set" - #puts "refvar: [set $refvar]" - #puts "SYNCVARIABLE: $SYNCVARIABLE" - - #if {[set $refvar] ne $SYNCVARIABLE} { - # set $refvar $SYNCVARIABLE - #} - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE - } - - } - } - - - } - - } - - - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names predator_traces] { - foreach tinfo $predator_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - foreach rv [array names external_traces] { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - - + + + } - + # end propvar_write_TraceHandler @@ -1457,9 +1410,9 @@ proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { # -#returns 0 if method implementation not present for interface +#returns 0 if method implementation not present for interface proc ::p::predator::method_chainhead {iid method} { - #Interface proc + #Interface proc # examine the existing command-chain set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) set cmdchain [list] @@ -1483,7 +1436,7 @@ proc ::p::predator::method_chainhead {iid method} { -#this returns a script that upvars vars for all interfaces on the calling object - +#this returns a script that upvars vars for all interfaces on the calling object - # - must be called at runtime from a method proc ::p::predator::upvar_all {_ID_} { #::set OID [lindex $_ID_ 0 0] @@ -1491,16 +1444,16 @@ proc ::p::predator::upvar_all {_ID_} { ::set decl {} #[set ::p::${OID}::_meta::map] #[dict get [lindex [dict get $_ID_ i this] 0 1] map] - - ::upvar #0 ::p::${OID}::_meta::map MAP - #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" - #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] - ::foreach ifid [dict get $MAP interfaces level0] { + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { ::array unset nsvars ::array set nsvars [::list] - ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { ::set varspace [::dict get $vinfo varspace] ::lappend nsvars($varspace) $vname } @@ -1511,33 +1464,33 @@ proc ::p::predator::upvar_all {_ID_} { ::set ns ::p::${OID} } else { if {[::string match "::*" $varspace]} { - ::set ns $varspace + ::set ns $varspace } else { ::set ns ::p::${OID}::$varspace } } - ::append decl "namespace upvar $ns " + ::append decl "namespace upvar $ns " ::foreach vname [::set nsvars($varspace)] { ::append decl "$vname $vname " } - ::append decl " ;\n" + ::append decl " ;\n" } ::array unset nsvars - } - } - ::return $decl + } + } + ::return $decl } #we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) proc ::p::predator::runtime_vardecls {} { - set result "::eval \[::p::predator::upvar_all \$_ID_\]" - #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" - - #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" - #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" - #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" - return $result + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result } @@ -1547,103 +1500,103 @@ proc ::p::predator::runtime_vardecls {} { #OBSOLETE!(?) - todo - move stuff out of here. proc ::p::predator::compile_interface {IFID caller_ID_} { - upvar 0 ::p::${IFID}:: IFACE - - #namespace eval ::p::${IFID} { - # namespace ensemble create - #} - - #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables - - namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - #set varDecls {} - #if {[llength $o_variables]} { - # #puts "*********!!!! $vlist" + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " - # foreach vdef $o_variables { + # foreach vdef $o_variables { # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " - # } - # append varDecls \n - #} + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} - #runtime gathering of vars from other interfaces. - #append varDecls [runtime_vardecls] - set varDecls [runtime_vardecls] + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - #implement methods - #!todo - avoid globs on iface array? maintain list of methods in another slot? - #foreach {n mname} [array get IFACE m-1,name,*] {} + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] - #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - - - #implement property getters/setters/unsetters - #'setter' overrides - #pw short for propertywrite - foreach {n property} [array get IFACE pw,name,*] { - if {[string length $property]} { - #set property [lindex [split $n ,] end] - - #!todo - next_script - #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 - set maxversion [::p::predator::method_chainhead $IFID (SET)$property] - set chainhead [expr {$maxversion + 1}] - set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - - set body $IFACE(pw,body,$property) - + set body $IFACE(pw,body,$property) - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" - } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - set maxversion [::p::predator::method_chainhead $IFID $property] - set headid [expr {$maxversion + 1}] + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides - proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + dict for {property handler_info} $o_propertyunset_handlers { - interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - - #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body - } - } - #'unset' overrides + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array - dict for {property handler_info} $o_propertyunset_handlers { - - set body [dict get $handler_info body] - set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] - set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? @@ -1660,31 +1613,31 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { } else { set body $varDecls\n[dict get $processed body] #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" - + } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #implement - #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern "_dontcare_" - } - proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body - - - #chainhead pointer - interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid - } + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } - - interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) - - #the usual case will have no destructor - so use info exists to check. + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { #!todo - chained destructors (support @next@). @@ -1694,7 +1647,7 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { set body [set ::p::${IFID}::_iface::o_destructor_body] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { @@ -1707,23 +1660,23 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" } #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] proc ::p::${IFID}::___system___destructor _ID_ $body - } + } - if {[info exists o_unknown]} { - #use 'apply' somehow? - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - } + } + - - return + return } @@ -1736,7 +1689,7 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { proc ::p::predator::command_info_args {cmd} { if {[llength [set next [interp alias {} $cmd]]]} { set curriedargs [lrange $next 1 end] - + if {[catch {set arglist [info args [lindex $next 0]]}]} { set arglist [command_info_args [lindex $next 0]] } @@ -1757,11 +1710,11 @@ proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { set i 0 foreach arg [lrange $nextArgs 1 end] { upvar 1 $arg $i - if {$arg eq "args"} { + if {$arg eq "args"} { #need to check if 'args' is actually available in caller if {[info exists $i]} { set argVals [concat $argVals [set $i]] - } + } } else { lappend argVals [set $i] } @@ -1779,11 +1732,11 @@ proc ::p::predator::next_script {IFID method caller caller_ID_} { if {$caller eq "(CONSTRUCTOR).1"} { return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] } elseif {$caller eq "$method.1"} { - #delegate to next interface lower down the stack which has a member named $method + #delegate to next interface lower down the stack which has a member named $method return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] } elseif {[string match "(GET)*.2" $caller]} { - # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. - + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + #jmn set prop [string trimright $caller 1234567890] set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . @@ -1799,8 +1752,8 @@ proc ::p::predator::next_script {IFID method caller caller_ID_} { } elseif {[string match "(SET)*.2" $caller]} { return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] } else { - #this branch will also handle (SET)*.x and (GET)*.x where x >2 - + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" set callerid [string range $caller [string length "$method."] end] set nextid [expr {$callerid - 1}] @@ -1837,8 +1790,8 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { foreach if_sub [lreverse $lower_interfaces] { if {[string match "(GET)*" $method]} { #do not test o_properties here! We need to call even if there is no underlying property on this interface - #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) - # relevant test: higher_order_propertyread_chaining + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] } elseif {[string match "(SET)*" $method]} { #must be called even if there is no matching $method in o_properties @@ -1848,17 +1801,17 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { #error "do_next_if (UNSET) untested" #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { if {[llength $args]} { #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" - + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args - + #!todo - handle case where llength $args is less than number of args for subinterface command #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) - + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) set head [interp alias {} ::p::${if_sub}::_iface::$method] set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc @@ -1866,33 +1819,33 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { foreach a $nextArgs { lappend argx "\$a" } - + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared - + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args } else { #todo - upvars required for tail end of arglist tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args } - + } else { #auto-set: upvar vars from calling scope - #!todo - robustify? alias not necessarily matching command name.. + #!todo - robustify? alias not necessarily matching command name.. set head [interp alias {} ::p::${if_sub}::_iface::$method] - + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc if {[llength $nextArgs] > 1} { set argVals [::list] set i 0 foreach arg [lrange $nextArgs 1 end] { upvar 1 $arg $i - if {$arg eq "args"} { + if {$arg eq "args"} { #need to check if 'args' is actually available in caller if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } + set argVals [concat $argVals [set $i]] + } } else { lappend argVals [set $i] } @@ -1911,7 +1864,7 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args } } - #no interfaces in the iStack contained a matching method. + #no interfaces in the iStack contained a matching method. return } else { #no further interfaces in this iStack @@ -1923,43 +1876,42 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { #only really makes sense for (CONSTRUCTOR) calls. #_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { - #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" #set invocants [dict get $_ID_ i] #set this_invocant [lindex [dict get $invocants this] 0] #lassign $this_invocant OID this_info - #set OID [lindex [dict get $invocants this] 0 0] + #set OID [lindex [dict get $invocants this] 0 0] #upvar #0 ::p::${OID}::_meta::map map - #lassign [lindex $map 0] OID alias itemCmd cmd - - - set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] - upvar #0 ::p::${caller_OID}::_meta::map callermap - - #set interfaces [lindex $map 1 0] - set patterninterfaces [dict get $callermap interfaces level1] - - set L0_posn [lsearch $patterninterfaces $IFID] - if {$L0_posn == -1} { - error "do_next_pattern_if called with interface not present at level1 for this object" - } elseif {$L0_posn > 0} { - - - set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } } @@ -1984,28 +1936,28 @@ proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { #!todo - can we just call new_object somehow to create this? - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + #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://mini.net/tcl/1030 'Dangers of creative writing') namespace eval ::p::-1 { #namespace ensemble create - - namespace eval _ref {} - namespace eval _meta {} + + namespace eval _ref {} + namespace eval _meta {} namespace eval _iface { variable o_usedby variable o_open variable o_constructor variable o_variables - variable o_properties - variable o_methods + variable o_properties + variable o_methods variable o_definition variable o_varspace variable o_varspaces - + array set o_usedby [list i0 1] ;#!todo - review - #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? set o_open 1 set o_constructor [list] @@ -2030,51 +1982,51 @@ upvar #0 ::p::-1::_iface::o_definition def #! concatenate -> compose ?? dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} -proc ::p::-1::Concatenate {_ID_ target args} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {![string match "::*" $target]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set target ::$target - } else { - set target ${ns}::$target - } - } - #add > character if not already present - set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] - set _target [string map {::> ::} $target] - - set ns [namespace qualifiers $target] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - if {![llength [info commands $target]]} { - #degenerate case - target does not exist + if {![llength [info commands $target]]} { + #degenerate case - target does not exist #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' #review - should be 'Copy' so it has object state from namespaces and variables? return [::p::-1::Clone $_ID_ $target {*}$args] - - #set TARGETMAP [::p::predator::new_object $target] - #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd - } else { - #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] - set TARGETMAP [$target --] + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - - #Merge lastmodified(?) level0 and level1 interfaces. - - } + #Merge lastmodified(?) level0 and level1 interfaces. + + } return $target } @@ -2087,70 +2039,67 @@ proc ::p::-1::Concatenate {_ID_ target args} { dict set ::p::-1::_iface::o_methods Define {arglist definitions} #define objects in one step proc ::p::-1::Define {_ID_ definitions} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern - lassign [dict get $MAP invocantdata] OID alias default_method cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - - #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack - #set IFID0 [lindex $interfaces 0] - #set IFID1 [lindex $patterns 0] ;#1st pattern - - #set IFID_TOP [lindex $interfaces end] - set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] - - #set ns ::p::${OID} - - #set script [string map [list %definitions% $definitions] { - # if {[lindex [namespace path] 0] ne "::p::-1"} { - # namespace path [list ::p::-1 {*}[namespace path]] - # } - # %definitions% - # namespace path [lrange [namespace path] 1 end] - # - #}] - - set script [string map [list %id% $_ID_ %definitions% $definitions] { - set ::p::-1::temp_unknown [namespace unknown] - - namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] - - - #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] - - - %definitions% - - - namespace unknown ${::p::-1::temp_unknown} - return - }] - - - - #uplevel 1 $script ;#this would run the script in the global namespace - #run script in the namespace of the open interface, this allows creating of private helper procs - #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack - #namespace inscope ::p::${OID} $script + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script namespace eval ::p::${OID} $script - #return $cmd + #return $cmd } proc ::p::predator::redirect {func args} { - - #todo - review tailcall - tests? - if {![llength [info commands ::p::-1::$func]]} { - #error "invalid command name \"$func\"" - tailcall uplevel 1 [list ::unknown $func {*}$args] - } else { - tailcall uplevel 1 [list ::p::-1::$func {*}$args] - } + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } } @@ -2159,44 +2108,44 @@ dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} proc ::p::-1::Construct {_ID_ argpairs body args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set ARGSETTER {} - foreach {argname argval} $argpairs { - append ARGSETTER "set $argname $argval\n" - } - #$_self (VIOLATE) $ARGSETTER$body - - set body $ARGSETTER\n$body - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - # puts stderr "\t runtime_vardecls in Construct $varDecls" - } + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } - set next "\[error {next not implemented}\]" - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #namespace eval ::p::${iid_top} $body + #namespace eval ::p::${iid_top} $body - #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] - #does this handle Varspace before constructor? - return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] } @@ -2206,64 +2155,64 @@ proc ::p::-1::Construct {_ID_ argpairs body args} { #hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects namespace eval ::p::3 {} proc ::p::3::_create {child {OID "-2"}} { - #puts stderr "::p::3::_create $child $OID" - set _child [string map {::> ::} $child] - if {$OID eq "-2"} { - #set childmapdata [::p::internals::new_object $child] - #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] - set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } else { - set child_ID $OID - #set _childmap [::p::internals::new_object $child "" $child_ID] - ::p::internals::new_object $child "" $child_ID - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } - - #-------------- + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- - set oldinterfaces [dict get $CHILDMAP interfaces] - dict set oldinterfaces level0 [list 2] - set modifiedinterfaces $oldinterfaces - dict set CHILDMAP interfaces $modifiedinterfaces - - #-------------- + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + #-------------- - #puts stderr ">>>> creating alias for ::p::$child_ID" - #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" - - #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! - #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] - #puts stderr ">>>[interp alias {} ::p::$child_ID]" - - + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] #--------------- - namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties - foreach method [dict keys $o_methods] { - #todo - change from interp alias to context proc - interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method - } - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop - - } - ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] - #--------------- - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - return $child + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child } -#configure -prop1 val1 -prop2 val2 ... +#configure -prop1 val1 -prop2 val2 ... dict set ::p::-1::_iface::o_methods Configure {arglist args} proc ::p::-1::Configure {_ID_ args} { @@ -2272,7 +2221,7 @@ proc ::p::-1::Configure {_ID_ args} { ::p::map $OID MAP lassign [dict get $MAP invocantdata] OID alias itemCmd this - + if {![expr {([llength $args] % 2) == 0}]} { error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" } @@ -2286,7 +2235,7 @@ proc ::p::-1::Configure {_ID_ args} { lappend properties_to_configure [string range $argprop 1 end] } - #gather all valid property names for all level0 interfaces in the relevant interface stack + #gather all valid property names for all level0 interfaces in the relevant interface stack set valid_property_names [list] set iflist [dict get $MAP interfaces level0] foreach id [lreverse $iflist] { @@ -2323,59 +2272,59 @@ proc ::p::-1::Configure {_ID_ args} { dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} -proc ::p::-1::AddPatternInterface {_ID_ iid} { - #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces - - - #it is theoretically possible to have the same interface present multiple times in an iStack. - # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? - lappend existing_ifaces $iid - #lset map {1 1} $existing_ifaces - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - - #lset invocant {1 1} $existing_ifaces + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict -} + #lset invocant {1 1} $existing_ifaces + +} #!todo - update usedby ?? dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} -proc ::p::-1::AddInterface {_ID_ iid} { - #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - - lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. - set this_invocant [lindex $list_of_invocants_for_role_this 0] - - lassign $this_invocant OID _etc +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level0] - lappend existing_ifaces $iid - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - return [dict get $extracted_sub_dict level0] + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] } @@ -2395,7 +2344,7 @@ proc ::p::-1::AddInterface {_ID_ iid} { #simple form with arguments to the constructor: # >somepattern .. Create >child arg1 arg2 etc #complex form - specify more info about the target (dict keyed on childobject name): -# >somepattern .. Create {>child {-id 1}} +# >somepattern .. Create {>child {-id 1}} #or # >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] #complex form - with arguments to the contructor: @@ -2409,12 +2358,12 @@ proc ::p::-1::Create {_ID_ target_spec args} { } else { set targets $target_spec } - + set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP set invocants [dict get $_ID_ i] set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) - + foreach {child target_spec_dict} $targets { #puts ">>>::p::-1::Create $_ID_ $child $args <<<" @@ -2422,9 +2371,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { #set invocant_alias [lindex [dict get $invocants this] 0] #set invocant [lindex [interp alias {} $invocant_alias] 1] - - - + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" @@ -2433,15 +2380,15 @@ proc ::p::-1::Create {_ID_ target_spec args} { #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces #puts "parent: $OID -> child:$child Patterns $patterns" #todo - change to dict of interface stacks - set IFID0 [lindex $interfaces 0] - set IFID1 [lindex $patterns 0] ;#1st pattern - + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + #upvar ::p::${OID}:: INFO if {![string match {::*} $child]} { @@ -2456,14 +2403,14 @@ proc ::p::-1::Create {_ID_ target_spec args} { #add > character if not already present set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] set _child [string map {::> ::} $child] - + set ns [namespace qualifiers $child] if {$ns eq ""} { set ns "::" } else { namespace eval $ns {} } - + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. set new_interfaces [list] @@ -2471,7 +2418,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {![llength $patterns]} { ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" #lappend patterns [::p::internals::new_interface $OID] - + #lset invocant {1 1} $patterns ##update our command because we changed the interface list. #set IFID1 [lindex $patterns 0] @@ -2487,20 +2434,20 @@ proc ::p::-1::Create {_ID_ target_spec args} { #--------- #set iface [::p::>interface .. Create ::p::ifaces::>$iid] #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid - + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] - + #--------- #puts "??> p::>interface .. Create ::p::ifaces::>$iid" #puts "??> [::p::ifaces::>$iid --]" #set [$iface . UsedBy .] } - set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] #if {![llength [info commands $child]]} {} - + if {[namespace which $child] eq ""} { #normal case - target/child does not exist set is_new_object 1 @@ -2512,40 +2459,38 @@ proc ::p::-1::Create {_ID_ target_spec args} { } lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - - + #child initially uses parent's level1 interface as it's level0 interface - # child has no level1 interface until PatternMethods or PatternProperties are added + # child has no level1 interface until PatternMethods or PatternProperties are added # (or applied via clone; or via create with a parent with level2 interface) #set child_IFID $IFID1 - + #lset CHILDMAP {1 0} [list $IFID1] #lset CHILDMAP {1 0} $patterns - + set extracted_sub_dict [dict get $CHILDMAP interfaces] dict set extracted_sub_dict level0 $patterns dict set CHILDMAP interfaces $extracted_sub_dict - + #why write back when upvared??? #review set ::p::${child_ID}::_meta::map $CHILDMAP - + #::p::predator::remap $CHILDMAP #interp alias {} $child {} ::p::internals::predator $CHILDMAP #set child_IFID $IFID1 - #upvar ::p::${child_ID}:: child_INFO + #upvar ::p::${child_ID}:: child_INFO #!todo review #set n ::p::${child_ID} #if {![info exists ${n}::-->PATTERN_ANCHOR]} { - # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" - # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack - # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" - # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] #} set ifaces_added $patterns @@ -2562,16 +2507,16 @@ proc ::p::-1::Create {_ID_ target_spec args} { #puts " **** CHILDMAP: $CHILDMAP" #puts " ****" - #puts stderr " ---> Properties: [$child .. Properties . names]" - #puts stderr " ---> Methods: [$child .. Properties . names]" - + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - #set child_IFID [lindex $CHILDMAP 1 0 end] + #set child_IFID [lindex $CHILDMAP 1 0 end] #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { - # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] - # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP #} ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces #::p::merge_interface $IFID1 $child_IFID @@ -2604,17 +2549,17 @@ proc ::p::-1::Create {_ID_ target_spec args} { #update the child's _ID_ interp alias {} $child_alias {} ;#first we must delete it interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] - + #! object_command was initially created as the renamed alias - so we have to do it again rename $child_alias $child - trace add command $child rename [list $child .. Rename] + trace add command $child rename [list $child .. Rename] } #!todo - review - dont we already have interp alias entries for every method/prop? #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. @@ -2683,7 +2628,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {![info exists o_usedby(i$child_ID)]} { set o_usedby(i$child_ID) $child_alias } - + #compile and close the interface only if it is shared if {$o_open} { ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ @@ -2691,8 +2636,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } - - + package require struct::set set propcmds [list] @@ -2707,8 +2651,8 @@ proc ::p::-1::Create {_ID_ target_spec args} { #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. foreach property $propcmds { #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" - interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces - interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property } set propcmds [list] @@ -2735,7 +2679,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { } else { set a $argspec } - + if {$a eq "args"} { append argvals " \{*\}\$args" } else { @@ -2743,29 +2687,27 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } set argvals [string trimleft $argvals] - + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method - - #this proc directly on the object is not *just* a forwarding proc + + #this proc directly on the object is not *just* a forwarding proc # - it provides a context in which the 'uplevel 1' from the running interface proc runs #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - - + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { ::p::${IFID}::_iface::$method \$_ID_ $argvals }] - + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { - # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ #}] - - + } #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - + #implement property even if interface already compiled because we need to create defaults for each new child obj. # also need to add alias on base interface #make sure we are only implementing properties from the current CREATOR @@ -2788,23 +2730,23 @@ proc ::p::-1::Create {_ID_ target_spec args} { } #! May be replaced by a method with the same name if {$prop ni [dict keys $o_methods]} { - interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop } - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop } #variables #foreach vdef $o_variables { - # if {[llength $vdef] == 2} { - # #there is a default value defined. - # lassign $vdef v default - # if {![info exists ::p::${child_ID}::$v]} { - # set ::p::${child_ID}::$v $default - # } - # } + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } #} dict for {vname vdef} $o_variables { if {[dict exists $vdef default]} { @@ -2822,16 +2764,15 @@ proc ::p::-1::Create {_ID_ target_spec args} { set ${ns}::$vname [dict get $vdef default] } } - - + #!todo - review. Write tests for cases of multiple constructors! - + #We don't want to the run constructor for each added interface with the same set of args! #run for last one - rely on constructor authors to use @next@ properly? if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { set highest_constructor_IFID $IFID } - + if {$idx == $idx_count} { #we are processing the last interface that was added - now run the latest constructor found if {$highest_constructor_IFID ne ""} { @@ -2846,13 +2787,12 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } } - + if {[info exists o_unknown]} { - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - - - #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] } @@ -2861,9 +2801,9 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {$constructor_failure} { if {$is_new_object} { #is Destroy enough to ensure that no new interfaces or objects were left dangling? - $child .. Destroy + $child .. Destroy } else { - #object needs to be returned to a sensible state.. + #object needs to be returned to a sensible state.. #attempt to rollback all interface additions and object state changes! puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" #remove variables from the object's namespace - which don't exist in the snapshot. @@ -2880,10 +2820,10 @@ proc ::p::-1::Create {_ID_ target_spec args} { #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) #values of vars may also have Changed #todo - consider traces? what is the correct behaviour? - # - some application traces may have fired before the constructor error occurred. - # Should the rollback now also trigger traces? - #probably yes. - + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value foreach vname $snap_vars { #puts stdout "@@@@@@@@@@@ restoring $vname" @@ -2895,7 +2835,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {$target in [info vars ::p::${child_ID}::*]} { set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' } else { - set present 0 + set present 0 } if {[array exists $vname]} { @@ -2904,7 +2844,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { array set $target [array get $vname] } else { if {[array exists $target]} { - #unset superfluous elements + #unset superfluous elements foreach key [array names $target] { if {$key ni [array names $vname]} { array unset $target $key @@ -2930,7 +2870,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {[array exists $target]} { #target has been changed to array - unset it and recreate the simple variable. unset $target - set $target [set $vname] + set $target [set $vname] } else { if {[set $target] ne [set $vname]} { set $target [set $vname] @@ -2950,12 +2890,10 @@ proc ::p::-1::Create {_ID_ target_spec args} { return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error } namespace delete $ns_snap - - } - - - return $child + } + + return $child } dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} @@ -2969,8 +2907,8 @@ proc ::p::-1::Clone {_ID_ clone args} { set invocants [dict get $_ID_ i] lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set _cmd [string map {::> ::} $cmd] - set tail [namespace tail $_cmd] + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] #obsolete? @@ -2989,17 +2927,17 @@ proc ::p::-1::Clone {_ID_ clone args} { } - set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] - set _clone [string map {::> ::} $clone] + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] - set cTail [namespace tail $_clone] + set cTail [namespace tail $_clone] set ns [namespace qualifiers $clone] if {$ns eq ""} { set ns "::" } - + namespace eval $ns {} @@ -3014,7 +2952,7 @@ proc ::p::-1::Clone {_ID_ clone args} { set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP - + #copy patterndata element of MAP straight across dict set CLONEMAP patterndata [dict get $MAP patterndata] @@ -3029,18 +2967,18 @@ proc ::p::-1::Clone {_ID_ clone args} { #! object_command was initially created as the renamed alias - so we have to do it again rename $clone_alias $clone - trace add command $clone rename [list $clone .. Rename] + trace add command $clone rename [list $clone .. Rename] #obsolete? - #upvar ::p::${clone_ID}:: clone_INFO - #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. - #upvar ::p::${OID}:: INFO + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO - array set clone_INFO [array get INFO] + array set clone_INFO [array get INFO] array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' @@ -3056,28 +2994,28 @@ proc ::p::-1::Clone {_ID_ clone args} { #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern - #clone's interface maps must be a superset of original's + #clone's interface maps must be a superset of original's foreach lev {0 1} { - #set parent_ifaces [lindex $map 1 $lev] + #set parent_ifaces [lindex $map 1 $lev] set parent_ifaces [dict get $MAP interfaces level$lev] - + #set existing_ifaces [lindex $CLONEMAP 1 $lev] set existing_ifaces [dict get $CLONEMAP interfaces level$lev] - + set added_ifaces_$lev [list] foreach ifid $parent_ifaces { if {$ifid ni $existing_ifaces} { - - #interface must not remain extensible after cloning. + + #interface must not remain extensible after cloning. if {[set ::p::${ifid}::_iface::o_open]} { ::p::predator::compile_interface $ifid $_ID_ set ::p::${ifid}::_iface::o_open 0 - } + } lappend added_ifaces_$lev $ifid - #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone } } @@ -3117,10 +3055,10 @@ proc ::p::-1::Clone {_ID_ clone args} { #! May be replaced by method of same name if {[namespace which ::p::${clone_ID}::$prop] eq ""} { - interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop } - interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop - interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop } #variables @@ -3144,18 +3082,18 @@ proc ::p::-1::Clone {_ID_ clone args} { #update the clone object's base interface to reflect the new methods. - #upvar 0 ::p::${ifid}:: IFACE + #upvar 0 ::p::${ifid}:: IFACE #set methods [list] #foreach {key mname} [array get IFACE m-1,name,*] { - # set method [lindex [split $key ,] end] - # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP - # lappend methods $method + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method #} #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] - + foreach method [dict keys $o_methods] { - + set arglist [dict get $o_methods $method arglist] set argvals "" foreach argspec $arglist { @@ -3164,7 +3102,7 @@ proc ::p::-1::Clone {_ID_ clone args} { } else { set a $argspec } - + if {$a eq "args"} { append argvals " \{*\}\$args" } else { @@ -3172,10 +3110,9 @@ proc ::p::-1::Clone {_ID_ clone args} { } } set argvals [string trimleft $argvals] - #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method - - - #this proc directly on the object is not *just* a forwarding proc + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc # - it provides a context in which the 'uplevel 1' from the running interface proc runs #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) @@ -3183,15 +3120,15 @@ proc ::p::-1::Clone {_ID_ clone args} { proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { ::p::${ifid}::_iface::$method \$_ID_ $argvals }] - + } #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] if {[info exists o_unknown]} { #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown - interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] @@ -3213,12 +3150,12 @@ proc ::p::-1::Clone {_ID_ clone args} { # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... - # when we now do >sibling .. Create >grandchild + # when we now do >sibling .. Create >grandchild # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) - # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild #(though other arguments can be manually passed) - # #!review - does this make sense? What if we add + # #!review - does this make sense? What if we add # #constructor for each interface called after properties initialised. #run each interface's constructor against child object, using the args passed into this clone method. @@ -3226,14 +3163,14 @@ proc ::p::-1::Clone {_ID_ clone args} { #error puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args - + } } return $clone - + } @@ -3241,77 +3178,77 @@ proc ::p::-1::Clone {_ID_ clone args} { interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} proc ::p::-1::Constructor {_ID_ arglist body} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - set iface ::p::ifaces::>$iid_top + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - #set iid_top [::p::get_new_object_id] - - #the >interface constructor takes a list of IDs for o_usedby - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] - #::p::predator::remap $invocant - } - set IID $iid_top + #::p::predator::remap $invocant + } + set IID $iid_top namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] - set headid [expr {$maxversion + 1}] - set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 - set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] #set varspaces [::pattern::varspace_list] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] - set body $varDecls\n[dict get $processed body] - #puts stderr "\t runtime_vardecls in Constructor $varDecls" - } + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #puts stderr ---- - #puts stderr $body - #puts stderr ---- + #puts stderr ---- + #puts stderr $body + #puts stderr ---- - proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body - interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid - set o_constructor [list $arglist $body] - set o_open 1 - - return + set o_constructor [list $arglist $body] + set o_open 1 + + return } @@ -3340,246 +3277,245 @@ proc ::p::-1::Destroy {_ID_ {force 1}} { set invocants [dict get $_ID_ i] set OID [lindex [dict get $invocants this] 0 0] - if {$OID eq "null"} { - puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" - return - } + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } - upvar #0 ::p::${OID}::_meta::map MAP + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout - - #explicit Destroy - remove traces - #puts ">>TRACES: [trace info variable $cmd]" - #foreach tinfo [trace info variable $cmd] { - # trace remove variable $cmd {*}$tinfo - #} - #foreach tinfo [trace info command $cmd] { - # trace remove command $cmd {*}$tinfo - #} - - - set _cmd [string map {::> ::} $cmd] - - #set ifaces [lindex $map 1] - set iface_stacks [dict get $MAP interfaces level0] - #set patterns [lindex $map 2] - set pattern_stacks [dict get $MAP interfaces level1] - - - - set ifaces $iface_stacks - - - set patterns $pattern_stacks - - - #set i 0 - #foreach iflist $ifaces { - # set IFID$i [lindex $iflist 0] - # incr i - #} - - - set IFTOP [lindex $ifaces end] - - set DESTRUCTOR ::p::${IFTOP}::___system___destructor - #may be a proc, or may be an alias + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias if {[namespace which $DESTRUCTOR] ne ""} { - set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] - - if {[catch {$DESTRUCTOR $temp_ID_} prob]} { - #!todo - ensure correct calling order of interfaces referencing the destructor proc - - - #!todo - emit destructor errors somewhere - logger? - #puts stderr "underlying proc already removed??? ---> $prob" - #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" - #puts stderr $::errorInfo - #puts stderr "---------------------" - } - } - - - #remove ourself from each interfaces list of referencers - #puts stderr "--- $ifaces" - - foreach var {ifaces patterns} { - - foreach i [set $var] { - - if {[string length $i]} { - if {$i == 2} { - #skip the >ifinfo interface which doesn't maintain a usedby list anyway. - continue - } - - if {[catch { - - upvar #0 ::p::${i}::_iface::o_usedby usedby - - array unset usedby i$OID - - - #puts "\n***>>***" - #puts "IFACE: $i usedby: $usedby" - #puts "***>>***\n" - - #remove interface if no more referencers - if {![array size usedby]} { - #puts " **************** DESTROYING unused interface $i *****" - #catch {namespace delete ::p::$i} - - #we happen to know where 'interface' object commands are kept: - - ::p::ifaces::>$i .. Destroy - - } - - } errMsg]} { - #warning - puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" - } - } - - } - - } - - set ns ::p::${OID} - #puts "-- destroying objects below namespace:'$ns'" - ::p::internals::DestroyObjectsBelowNamespace $ns - #puts "--.destroyed objects below '$ns'" - - - #set ns ::p::${OID}::_sub - #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace - #( ::p::OBJECT::$OID ) - #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" - #::p::internals::DestroyObjectsBelowNamespace $ns + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns #same for _meta objects (e.g Methods,Properties collections) #set ns ::p::${OID}::_meta - #::p::internals::DestroyObjectsBelowNamespace $ns - + #::p::internals::DestroyObjectsBelowNamespace $ns + - #foreach obj [info commands ${ns}::>*] { - # #Assume it's one of ours, and ask it to die. - # catch {::p::meta::Destroy $obj} - # #catch {$cmd .. Destroy} - #} - #just in case the user created subnamespaces.. kill objects there too. - #foreach sub [namespace children $ns] { - # ::p::internals::DestroyObjectsBelowNamespace $sub - #} + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! #use info commands ::p::${OID}::_ref::* to find all references - including variables never set #remove variable traces on REF vars #foreach rv [info vars ::p::${OID}::_ref::*] { - # foreach tinfo [trace info variable $rv] { + # foreach tinfo [trace info variable $rv] { # #puts "-->removing traces on $rv: $tinfo" # trace remove variable $rv {*}$tinfo # } #} #!todo - write tests - #refs create aliases and variables at the same place - #- but variable may not exist if it was never set e.g if it was only used with info exists + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists foreach rv [info commands ::p::${OID}::_ref::*] { - foreach tinfo [trace info variable $rv] { + foreach tinfo [trace info variable $rv] { #puts "-->removing traces on $rv: $tinfo" trace remove variable $rv {*}$tinfo } } - - - #if {[catch {namespace delete $nsMeta} msg]} { - # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " - #} else { - # #puts stderr "------ -- -- -- -- deleted $nsMeta " - #} - #!todo - remove - #temp - #catch {interp alias "" ::>$OID ""} + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} - if {$force} { - #rename $cmd {} + if {$force} { + #rename $cmd {} - #removing the alias will remove the command - even if it's been renamed - interp alias {} $alias {} + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} - #if {[catch {rename $_cmd {} } why]} { - # #!todo - work out why some objects don't have matching command. - # #puts stderr "\t rename $_cmd {} failed" - #} else { - # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" - #} + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } - } + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" - set refns ::p::${OID}::_ref - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- matching command: [llength [info commands ${refns}]]" - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} - #foreach v [info vars ${refns}::*] { - # unset $v - #} - #foreach p [info procs ${refns}::*] { - # rename $p {} - #} - #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { - # interp alias {} $a {} - #} + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" - #set ts1 [clock seconds] - #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- exact command: [info commands ${refns}]" + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" - #puts "--delete ::p::${OID}::_ref" - if {[namespace exists ::p::${OID}::_ref]} { - #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. - namespace delete ::p::${OID}::_ref:: - } - set ts2 [clock seconds] - #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID - #delete namespace where instance variables reside - #catch {namespace delete ::p::$OID} - namespace delete ::p::$OID - - #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout - return + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return } @@ -3593,44 +3529,44 @@ proc ::p::-1::Destructor {_ID_ args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - #lassign [lindex $map 0] OID alias itemCmd cmd - - set patterns [dict get $MAP interfaces level1] - - if {[llength $args] > 2} { - error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" - } - - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - error "NOT TESTED" - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - #::p::predator::remap $invocant - } - - - set ::p::${IID}::_iface::o_destructor_body [lindex $args end] - - if {[llength $args] > 1} { - #!todo - allow destructor args(?) - set arglist [lindex $args 0] - } else { - set arglist [list] - } - - set ::p::${IID}::_iface::o_destructor_args $arglist - - return + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return } @@ -3645,7 +3581,7 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - + set patterns [dict get $MAP interfaces level1] set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. set iface ::p::ifaces::>$iid_top @@ -3667,12 +3603,12 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { # examine the existing command-chain set maxversion [::p::predator::method_chainhead $IID $method] set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 + set THISNAME $method.$headid ;#first version will be $method.1 - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { @@ -3690,11 +3626,11 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] #puts "\t\t--------------------" #puts "\n" - #puts $body + #puts $body #puts "\n" #puts "\t\t--------------------" proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body @@ -3706,7 +3642,7 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { - if {$method in [dict keys $o_methods]} { + if {$method in [dict keys $o_methods]} { #error "patternmethod '$method' already present in interface $IID" set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" if {[string match "*@next@*" $body]} { @@ -3732,15 +3668,15 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { # for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. # (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) # !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) -# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? # - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? -# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? # (and how would we define the call order? - presumably as it appears in the conglomerate) # (or could that be done with a more general method-wrapping mechanism?) #...should multimethods use some sort of event mechanism, and/or message-passing system? # dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} -proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { set invocants [dict get $_ID_ i] error "not implemented" @@ -3750,45 +3686,45 @@ dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsu # we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) #we can create a method named "." by using the argprotect operator -- # e.g >x .. Method -- . {args} $body -#It can then be called like so: >x . . -#This is not guaranteed to work and is not in the test suite +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite #for now we'll just use a highly unlikely string to indicate no argument was supplied -proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - if {$methodname eq $non_argument_magicstring} { - return $default_method - } else { - set extracted_value [dict get $MAP invocantdata] - lset extracted_value 2 $methodname - dict set MAP invocantdata $extracted_value ;#write modified value back - #update the object's command alias to match - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] - - #! $object_command was initially created as the renamed alias - so we have to do it again - rename $alias $object_command - trace add command $object_command rename [list $object_command .. Rename] - return $methodname - } +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } } dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set extracted_patterndata [dict get $MAP patterndata] - set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] - if {$methodname eq $non_argument_magicstring} { - return $pattern_default_method - } else { - dict set extracted_patterndata patterndefaultmethod $methodname - dict set MAP patterndata $extracted_patterndata - return $methodname - } +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } } @@ -3801,7 +3737,7 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { set invocant_signature [list] ; - ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. foreach role [lsort [dict keys $invocants]] { lappend invocant_signature $role [llength [dict get $invocants $role]] } @@ -3816,11 +3752,11 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { ################################################################################# if 0 { - set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface set prev_open [set ::p::${iid_top}::_iface::o_open] set iface ::p::ifaces::>$iid_top - + set f_new 0 if {![string length $iid_top]} { set f_new 1 @@ -3837,25 +3773,25 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat $interfaces $iid_top] dict set MAP interfaces $extracted_sub_dict - + } set IID $iid_top } ################################################################################# - + set IID [::p::predator::get_possibly_new_open_interface $OID] - #upvar 0 ::p::${IID}:: IFACE + #upvar 0 ::p::${IID}:: IFACE namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - #Interface proc - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 if {$method ni [dict keys $o_methods]} { dict set o_methods $method [list arglist $arglist] @@ -3866,10 +3802,10 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" - #implement - #----------------------------------- - set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs @@ -3877,97 +3813,93 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { } set body [dict get $processed body] set varDecls "" - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - } + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] - - + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #if {[string length $varDecls]} { - # puts stdout "\t---------------------------------------------------------------" - # puts stdout "\t----- efficiency warning - implicit var declarations used -----" - # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" - # puts stdout "\t[string map [list \n \t\t\n] $body]" - # puts stdout "\t--------------------------" - #} + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role - # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. #(as specified by the @ operator during object conglomeration) - #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] #puts stdout "\t\t----------------------------" #puts stdout "$body" #puts stdout "\t\t----------------------------" - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - #----------------------------------- - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - #point to the interface command only. The dispatcher will supply the invocant data - #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IID}::_iface::$method \$_ID_ $argvals - }] - - - if 0 { - if {[llength $argvals]} { - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { - apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ - }] - } else { - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { - apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ - }] - - } - } - - - #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - # ::p::${IID}::_iface::$method \$_ID_ $argvals - #}] - - #todo - for o_varspaces - #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method - #- this should work correctly with the 'uplevel 1' procs in the interfaces - - + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + if {[string length $o_varspace]} { if {[string match "::*" $o_varspace]} { namespace eval $o_varspace {} @@ -3977,37 +3909,37 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { } - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. set colMethods ::p::${OID}::_meta::>colMethods - + if {[namespace which $colMethods] ne ""} { if {![$colMethods . hasKey $method]} { $colMethods . add [::p::internals::predator $_ID_ . $method .] $method } } - #::p::-1::update_invocant_aliases $_ID_ - return - #::>pattern .. Create [::>pattern .. Namespace]::>method_??? - #return $method_object + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object } dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} proc ::p::-1::V {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set vlist [list] + set vlist [list] foreach IID $ifaces { dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { if {[string match $glob $vname]} { @@ -4015,8 +3947,6 @@ proc ::p::-1::V {_ID_ {glob *}} { } } } - - return $vlist } @@ -4036,105 +3966,100 @@ proc p::predator::pipeline {args} { } proc ::p::predator::get_apply_arg_0_oid {} { - set apply_args [lrange [info level 0] 2 end] - puts stderr ">>>>> apply_args:'$apply_args'<<<<" - set invocant [lindex $apply_args 0] - return [lindex [dict get $invocant i this] 0 0] + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] } proc ::p::predator::get_oid {} { - #puts stderr "---->> [info level 1] <<-----" - set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 - tailcall lindex [dict get $_ID_ i this] 0 0 + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 } #todo - make sure this is called for all script installations - e.g propertyread etc etc -#Add tests to check code runs in correct namespace +#Add tests to check code runs in correct namespace #review - how does 'Varspace' command affect this? proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { - #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) - set arglist_apply "" - append arglist_apply "\$_ID_ " - foreach a $arglist { - if {$a eq "args"} { - append arglist_apply "{*}\$args" - } else { - append arglist_apply "\$[lindex $a 0] " - } - } - #!todo - allow fully qualified varspaces - if {[string length $varspace]} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { if {[string match ::* $varspace]} { return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" } else { #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" } - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" - #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" - - set script "tailcall apply \[list \{_ID_" - - if {[llength $arglist]} { - append script " $arglist" - } - append script "\} \{" - append script $body - append script "\} ::p::@OID@\] " - append script $arglist_apply - #puts stderr "\n88888888888888888888888888\n\t$script\n" - #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" - #return $script - - - #----------------------------------------------------------------------------- - # 2018 candidates - # - #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - - - #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) - #faster though. - #return "uplevel 1 \{$body\}" - return "uplevel 1 [list $body]" - #----------------------------------------------------------------------------- - - - - - #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" - #return "uplevel 1 \{$script\}" - - #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - - - - #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong - - #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns - - - #experiment with different dispatch mechanism (interp alias with 'namespace inscope') - #----------- - #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" - - - #return "uplevel 1 \{$body\}" ;#do nothing - - #---------- - - #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) - - #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body - - #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker - - #return "tailcall " - - - } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + } } @@ -4145,67 +4070,67 @@ proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist #concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces #WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! # e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. -#Think of var & varspace statments as a form of compile-time 'macro' +#Think of var & varspace statments as a form of compile-time 'macro' # #caters for 2-element lists as arguments to var statement to allow 'aliasing' #e.g var o_thing {o_data mydata} # this will upvar o_thing as o_thing & o_data as mydata # proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { - set body {} + set body {} - #keep count of any explicit var statments per varspace in 'numDeclared' array + #keep count of any explicit var statments per varspace in 'numDeclared' array # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. #default varspace is "" #varspace should only have leading :: if it is an absolute namespace path. - foreach ln [split $rawbody \n] { - set trimline [string trim $ln] + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] - if {$trimline eq "var"} { - #plain var statement alone indicates we don't have any explicit declarations in this branch - # and we don't want implicit declarations for the current varspace either. - #!todo - implement test + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test - incr numDeclared($varspace) + incr numDeclared($varspace) - #may be further var statements e.g - in other code branches - #return [list body $rawbody varspaces_with_explicit_vars 1] - } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { - #append body " upvar #0 " - #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " - #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " if {$varspace eq ""} { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " } else { if {[string match "::*" $varspace]} { append body " namespace upvar $varspace " - } else { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " } } - #any whitespace before or betw var names doesn't matter - about to use as list. - foreach varspec [string range $trimline 4 end] { - lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. - ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " - #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " - - append body "$var $alias " - - } - append body \n - - incr numDeclared($varspace) - } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { - #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? - #it is assumed there is a single word following the 'varspace' keyword. - set varspace [string trim [string range $trimline 9 end]] - + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + # 2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + if {$varspace in [list {{}} {""}]} { set varspace "" } @@ -4213,7 +4138,7 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { #set varspace ::${varspace}:: #no need to initialize numDeclared($varspace) incr will work anyway. #if {![info exists numDeclared($varspace)]} { - # set numDeclared($varspace) 0 + # set numDeclared($varspace) 0 #} if {[string match "::*" $varspace]} { @@ -4229,13 +4154,13 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" } #!review - why? why do we need the magic 'default' name instead of just using the empty string? - #if varspace argument was empty string - leave it alone - } else { - append body $ln\n - } - } + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + - set varspaces [array names numDeclared] return [list body $body varspaces_with_explicit_vars $varspaces] @@ -4244,7 +4169,7 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { -#Interface Variables +#Interface Variables dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} proc ::p::-1::IV {_ID_ {glob *}} { set invocants [dict get $_ID_ i] @@ -4258,16 +4183,16 @@ proc ::p::-1::IV {_ID_ {glob *}} { #!todo - test #return [dict keys ::p::${OID}::_iface::o_variables $glob] - set members [list] - foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { - if {[string match $glob $vname]} { - lappend members $vname - } - } - return $members + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members } -dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} +dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} proc ::p::-1::MetaMethods {_ID_ {glob *}} { upvar ::p::-1::_iface::o_methods metaface_methods set metamethod_names [lsort [dict keys $metaface_methods]] @@ -4286,7 +4211,7 @@ proc ::p::-1::Methods {_ID_ {idx ""}} { #set map [dict get $this_info map] set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces @@ -4305,11 +4230,11 @@ proc ::p::-1::Methods {_ID_ {idx ""}} { } } } - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } } dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}} @@ -4320,13 +4245,13 @@ proc ::p::-1::M {_ID_ {glob *}} { #set map [dict get $this_info map] set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] + set members [list] foreach IID $ifaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] } - return $members + return $members } #PatternMethods @@ -4337,13 +4262,13 @@ proc ::p::-1::PM {_ID_ {glob *}} { lassign $this_invocant OID _etc #set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set members [list] + set members [list] foreach IID $ifaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] } - return [lsort $members] + return [lsort $members] } @@ -4358,10 +4283,10 @@ proc ::p::-1::IM {_ID_ {glob *}} { set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] } @@ -4369,70 +4294,70 @@ proc ::p::-1::IM {_ID_ {glob *}} { dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} proc ::p::-1::InterfaceStacks {_ID_} { - upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP - return [dict get $MAP interfaces level0] + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] } dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} proc ::p::-1::PatternStacks {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - return [dict get $MAP interfaces level1] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] } -#!todo fix. need to account for references which were never set to a value +#!todo fix. need to account for references which were never set to a value dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} proc ::p::-1::DeletePropertyReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - set refvars [info vars ::p::${OID}::_ref::*] - #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. - foreach rv $refvars { - foreach tinfo [trace info variable $rv] { - set ops {}; set cmd {} - lassign $tinfo ops cmd - trace remove variable $rv $ops $cmd - } - unset $rv - lappend cleared_references $rv - } - - - return [list deleted_property_references $cleared_references] + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] } dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} proc ::p::-1::DeleteMethodReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - - set iflist [dict get $MAP interfaces level0] - set iflist_reverse [lreferse $iflist] - #set iflist [dict get $MAP interfaces level0] - - - set refcommands [info commands ::p::${OID}::_ref::*] - foreach c $refcommands { - set reftail [namespace tail $c] - set field [lindex [split $c +] 0] - set field_is_a_method 0 - foreach IFID $iflist_reverse { - if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - set field_is_a_method 1 - break - } - } - if {$field_is_a_method} { - #what if it's also a property? - interp alias {} $c {} - lappend cleared_references $c - } - } - - - return [list deleted_method_references $cleared_references] + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] } @@ -4441,18 +4366,18 @@ proc ::p::-1::DeleteReferences {_ID_} { set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias default_method this - - set result [dict create] - dict set result {*}[$this .. DeletePropertyReferences] - dict set result {*}[$this .. DeleteMethodReferences] - - return $result + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result } ## #Digest # -#!todo - review +#!todo - review # -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) # #!todo - write tests - check that digest changes when properties of contained objects change value @@ -4469,7 +4394,7 @@ proc ::p::-1::Digest {_ID_ args} { upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] _OID alias default_method this - + set interface_ids [dict get $MAP interfaces level0] set IFID0 [lindex $interface_ids end] @@ -4478,15 +4403,14 @@ proc ::p::-1::Digest {_ID_ args} { if {[dict exists $args -a] && ![dict exists $args -algorithm]} { dict set args -algorithm [dict get $args -a] } - + set opts [dict merge $defaults $args] foreach key [dict keys $opts] { if {$key ni $known_flags} { error "unknown option $key. Expected only: $known_flags" } } - - + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} if {[dict get $opts -algorithm] ni $known_algos} { error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" @@ -4494,9 +4418,9 @@ proc ::p::-1::Digest {_ID_ args} { set algo [string tolower [dict get $opts -algorithm]] # append comma for each var so that all changes in adjacent vars detectable. - # i.e set x 34; set y 5 + # i.e set x 34; set y 5 # must be distinguishable from: - # set x 3; set y 45 + # set x 3; set y 45 if {[dict get $opts -indent] ne ""} { set state "" @@ -4507,13 +4431,11 @@ proc ::p::-1::Digest {_ID_ args} { } append state "${indent}object_command: $this\n" set indent "${indent} " - + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. - - - + #!todo - recurse into 'varspaces' set varspaces_found [list] append state "${indent}interfaces:\n" @@ -4528,7 +4450,7 @@ proc ::p::-1::Digest {_ID_ args} { } } } - + append state "${indent}vars:\n" foreach var [info vars ::p::${OID}::*] { append state "${indent} - [namespace tail $var] : \"" @@ -4545,7 +4467,7 @@ proc ::p::-1::Digest {_ID_ args} { foreach obj [info commands ::p::${OID}::>*] { append state "[$obj .. Digest {*}$subargs]\n" } - + append state "${indent}sub-namespaces:\n" set subargs $args dict set subargs -indent "$indent " @@ -4556,8 +4478,7 @@ proc ::p::-1::Digest {_ID_ args} { } } } - - + if {$algo in {"" raw none}} { return $state } else { @@ -4574,13 +4495,13 @@ proc ::p::-1::Digest {_ID_ args} { >b1 . encrypt $state -final 1 set result [>b1 . ciphertext] >b1 .. Destroy - + } elseif {$algo eq "blowfish-binary"} { - + } else { error "can't get here" } - + } } @@ -4629,12 +4550,12 @@ proc ::p::-1::Variable {_ID_ varname args} { #!assume var not already present on interface - it is an error to define twice (?) #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - + #Implement if there is a default #!todo - correct behaviour when overlaying on existing object with existing var of this name? #if {[string length $varspace]} { - # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] #} else { set ::p::${OID}::$varname [lindex $args 0] #} @@ -4653,45 +4574,45 @@ proc ::p::-1::Variable {_ID_ varname args} { dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} proc ::p::-1::PatternVariable {_ID_ varname args} { - set invocants [dict get $_ID_ i] + set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - ##this interface itself is always a co-invocant - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - set iface ::p::ifaces::>$iid_top + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top - set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. - if {[llength $args]} { - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - } else { - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } - return + return } dict set ::p::-1::_iface::o_methods Varspaces {arglist args} @@ -4701,7 +4622,7 @@ proc ::p::-1::Varspaces {_ID_ args} { upvar #0 ::p::${OID}::_meta::map MAP if {![llength $args]} { - #query + #query set iid_top [lindex [dict get $MAP interfaces level0] end] set iface ::p::ifaces::>$iid_top if {![string length $iid_top]} { @@ -4717,7 +4638,7 @@ proc ::p::-1::Varspaces {_ID_ args} { set varspaces $args foreach vs $varspaces { if {[string length $vs] && ($vs ni $o_varspaces)} { - if {[string match ::* $vs} { + if {[string match ::* $vs]} { namespace eval $vs {} } else { namespace eval ::p::${OID}::$vs {} @@ -4725,7 +4646,7 @@ proc ::p::-1::Varspaces {_ID_ args} { lappend o_varspaces $vs } } - return $o_varspaces + return $o_varspaces } #set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface @@ -4737,7 +4658,7 @@ proc ::p::-1::Varspace {_ID_ args} { ::p::map $OID MAP if {![llength $args]} { - #query + #query set iid_top [lindex [dict get $MAP interfaces level0] end] set iface ::p::ifaces::>$iid_top if {![string length $iid_top]} { @@ -4775,7 +4696,7 @@ proc ::p::-1::Varspace {_ID_ args} { proc ::p::predator::get_possibly_new_open_interface {OID} { #we need to re-upvar MAP rather than using a parameter - as we need to write back to it - upvar #0 ::p::${OID}::_meta::map MAP + upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level0] set iid_top [lindex $interfaces end] @@ -4786,7 +4707,7 @@ proc ::p::predator::get_possibly_new_open_interface {OID} { set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id #puts stderr ">>>>creating new interface $iid_top" set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - + set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat $interfaces $iid_top] dict set MAP interfaces $extracted_sub_dict @@ -4811,73 +4732,72 @@ dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} # set the default varspace for the interface, so that new methods/properties refer to it. # varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. proc ::p::-1::PatternVarspace {_ID_ varspace args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - if {[string length $varspace]} { - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - #o_varspace is the currently active varspace - set o_varspace $varspace + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace } ################################################################################################################################################### #get varspace and default from highest interface - return all interface ids which define it dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - - array set propinfo {} - set found_property_names [list] - #start at the lowest and work up (normal storage order of $interfaces) - foreach iid $interfaces { - set propinfodict [set ::p::${iid}::_iface::o_properties] - set matching_propnames [dict keys $propinfodict $propnamepattern] - foreach propname $matching_propnames { - if {$propname ni $found_property_names} { - lappend found_property_names $propname - } - lappend propinfo($propname,interfaces) $iid - ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one - if {[dict exists $propinfodict $propname default]} { - set propinfo($propname,default) [dict get $propinfodict $propname default] - } - set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] - } - } - - set resultdict [dict create] - foreach propname $found_property_names { - set fields [list varspace $propinfo($propname,varspace)] - if {[array exists propinfo($propname,default)]} { - lappend fields default [set propinfo($propname,default)] - } - lappend fields interfaces $propinfo($propname,interfaces) - dict set resultdict $propname $fields - } - return $resultdict + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict } @@ -4885,7 +4805,7 @@ dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} proc ::p::-1::GetTopPattern {_ID_ args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - + set interfaces [dict get $MAP interfaces level1] set iid_top [lindex $interfaces end] if {![string length $iid_top]} { @@ -4913,7 +4833,7 @@ proc ::p::-1::GetTopInterface {_ID_ args} { dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} proc ::p::-1::GetExpandableInterface {_ID_ args} { - + } @@ -4946,7 +4866,7 @@ proc ::p::-1::Property {_ID_ property args} { #create a new interface set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - + set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat $interfaces $iid_top] dict set MAP interfaces $extracted_sub_dict @@ -4959,27 +4879,27 @@ proc ::p::-1::Property {_ID_ property args} { set maxversion [::p::predator::method_chainhead $IID (GET)$property] set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + - if {$headid == 1} { #implementation #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - + #if {$o_varspace eq ""} { - # set ns ::p::${OID} + # set ns ::p::${OID} #} else { - # if {[string match "::*" $o_varspace]} { - # set ns $o_varspace - # } else { - # set ns ::p::${OID}::$o_varspace - # } + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } #} #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] - - + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] @@ -4987,56 +4907,56 @@ proc ::p::-1::Property {_ID_ property args} { #chainhead pointers interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - + + } if {($property ni [dict keys $o_methods])} { interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } + } - #installation on object + #installation on object - #namespace eval ::p::${OID} [list namespace export $property] + #namespace eval ::p::${OID} [list namespace export $property] #obsolete? - #if {$property ni [P $_ID_]} { - #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces - #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant - #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant - #} + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} #link main (GET)/(SET) to this interface - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property - interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - #Only install property if no method of same name already installed here. - #(Method takes precedence over property because property always accessible via 'set' reference) - #convenience pointer to chainhead pointer. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } else { - #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - - - } + + } set varspace [set ::p::${IID}::_iface::o_varspace] - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} dict set o_variables o_$property [list varspace $varspace] @@ -5051,10 +4971,10 @@ proc ::p::-1::Property {_ID_ property args} { dict set o_properties $property [list default $default varspace $varspace] #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] #} else { - # lappend o_properties [list $property $default] - #} + # lappend o_properties [list $property $default] + #} if {$varspace eq ""} { set ns ::p::${OID} @@ -5065,16 +4985,16 @@ proc ::p::-1::Property {_ID_ property args} { set ns ::p::${OID}::$o_varspace } } - + set ${ns}::o_$property $default #set ::p::${OID}::o_$property $default } else { - + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property]] + # set o_properties [lreplace $o_properties $posn $posn [list $property]] #} else { - # lappend o_properties [list $property] - #} + # lappend o_properties [list $property] + #} dict set o_properties $property [list varspace $varspace] @@ -5085,18 +5005,18 @@ proc ::p::-1::Property {_ID_ property args} { - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) - #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} - + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + set colProperties ::p::${OID}::_meta::>colProperties if {[namespace which $colProperties] ne ""} { if {![$colProperties . hasKey $property]} { $colProperties . add [::p::internals::predator $_ID_ . $property .] $property } } - - return + + return } ################################################################################################################################################### @@ -5131,7 +5051,7 @@ proc ::p::-1::PatternProperty {_ID_ property args} { set maxversion [::p::predator::method_chainhead $IID (GET)$property] set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 @@ -5141,12 +5061,12 @@ proc ::p::-1::PatternProperty {_ID_ property args} { proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - + #chainhead pointers interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - + } if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { @@ -5158,15 +5078,15 @@ proc ::p::-1::PatternProperty {_ID_ property args} { #Install the matching Variable #!todo - which should take preference if Variable also given a default? #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] + # set o_variables [lreplace $o_variables $posn $posn o_$property] #} else { - # lappend o_variables [list o_$property] + # lappend o_variables [list o_$property] #} dict set o_variables o_$property [list varspace $varspace] set argc [llength $args] - if {$argc} { + if {$argc} { if {$argc == 1} { set default [lindex $args 0] dict set o_properties $property [list default $default varspace $varspace] @@ -5210,93 +5130,93 @@ proc ::p::-1::PatternProperty {_ID_ property args} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} proc ::p::-1::PatternPropertyRead {_ID_ property args} { - set invocants [dict get $_ID_ i] - - set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' - set OID [lindex $this_invocant 0] - #set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } + set posn [lsearch $patterns $existing_IID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] if {$headid == 1} { - set headid 2 ;#reserve 1 for the getprop of the underlying property + set headid 2 ;#reserve 1 for the getprop of the underlying property } - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ - + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #implementation - if {![llength $idxlist]} { - proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body - } else { - #what are we trying to achieve here? .. - proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body - } + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } - #----------------------------------- + #----------------------------------- - #adjust chain-head pointer to point to new head. - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - return + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return } ################################################################################################################################################### @@ -5318,7 +5238,7 @@ dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} proc ::p::-1::PropertyRead {_ID_ property args} { set OID [::p::obj_get_this_oid $_ID_] ::p::map $OID MAP - + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) lassign [dict get $MAP invocantdata] OID alias default_command cmd @@ -5351,7 +5271,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { } else { set prev_open [set ::p::${existing_IID}::_iface::o_open] set ::p::${IID}::_iface::o_open $prev_open - } + } namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] @@ -5367,7 +5287,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] #implement - #----------------------------------- + #----------------------------------- set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] if {[llength [dict get $processed varspaces_with_explicit_vars]]} { @@ -5381,12 +5301,12 @@ proc ::p::-1::PropertyRead {_ID_ property args} { set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. set body $varDecls[dict get $processed body] } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body - #----------------------------------- + #----------------------------------- @@ -5396,7 +5316,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property } } ################################################################################################################################################### @@ -5424,69 +5344,69 @@ proc ::p::-1::PropertyWrite {_ID_ property argname body} { upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias default_command cmd - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. - + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set posn [lsearch $interfaces $existing_IID] - set posn [lsearch $interfaces $existing_IID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #pw short for propertywrite - #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] - set maxversion [::p::predator::method_chainhead $IID (SET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (SET)$property.$headid - set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body - #----------------------------------- + #----------------------------------- - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid } ################################################################################################################################################### @@ -5508,40 +5428,38 @@ proc ::p::-1::PropertyWrite {_ID_ property argname body} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set existing_ifaces [lindex $map 1 1] - set posn [lsearch $existing_ifaces $existing_IID] + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] - #set ::p::${IID}::_iface::o_open 0 - } else { - } + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] - #pw short for propertywrite - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + #set ::p::${IID}::_iface::o_open 0 + } else { + } + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - - return + return } ################################################################################################################################################### @@ -5557,69 +5475,69 @@ proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set posn [lsearch $interfaces $existing_IID] - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] - set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid + set THISNAME (UNSET)$property.$headid - set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { foreach vs [dict get $processed varspaces_with_explicit_vars] { if {[string length $vs] && ($vs ni $o_varspaces)} { lappend o_varspaces $vs } } set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - #note $arraykeypattern actually contains the name of the argument - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern _dontcare_ ;# - } - proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body - #----------------------------------- +#----------------------------------- - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid +#pointer from method-name to head of override-chain +interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid } ################################################################################################################################################### @@ -5636,34 +5554,34 @@ proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { ################################################################################################################################################### dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set posn [lsearch $patterns $existing_IID] - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #set ::p::${IID}::_iface::o_open 0 - } - - upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - return + return } ################################################################################################################################################### @@ -5680,31 +5598,30 @@ proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { #implementation reuse - sugar for >object .. Clone >target dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} proc ::p::-1::Extends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'Extends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Clone $object_command + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + tailcall $pattern .. Clone $object_command } #implementation reuse - sugar for >pattern .. Create >target dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} proc ::p::-1::PatternExtends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'PatternExtends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Create $object_command + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command } @@ -5714,7 +5631,7 @@ proc ::p::-1::Extend {_ID_ {idx ""}} { tailcall ::p::-1::Expand $_ID_ $idx } -#set the topmost interface on the iStack to be 'open' +#set the topmost interface on the iStack to be 'open' dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} proc ::p::-1::Expand {_ID_ {idx ""}} { set invocants [dict get $_ID_ i] @@ -5723,7 +5640,7 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces set iid_top [lindex $interfaces end] set iface ::p::ifaces::>$iid_top - + if {![string length $iid_top]} { #no existing interface - create a new one set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id @@ -5735,7 +5652,7 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { return $iid_top } else { if {[$iface . isOpen]} { - #already open.. + #already open.. #assume ready to expand.. shared or not! return $iid_top } @@ -5744,21 +5661,21 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { if {[$iface . refCount] > 1} { if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { #!warning! not exercised by test suites! - + #remove ourself from the usedby list of the previous interface array unset ::p::${iid_top}::_iface::o_usedby i$OID set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - #remove existing interface & add - set posn [lsearch $interfaces $iid_top] + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] dict set MAP interfaces $extracted_sub_dict #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - + set iid_top $IID - set iface ::p::ifaces::>$iid_top + set iface ::p::ifaces::>$iid_top } } } @@ -5783,7 +5700,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { ::p::map $OID MAP #puts stderr "no tests written for PatternExpand " lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces set iid_top [lindex $ifaces end] set iface ::p::ifaces::>$iid_top @@ -5800,7 +5717,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { return $iid_top } else { if {[$iface . isOpen]} { - #already open.. + #already open.. #assume ready to expand.. shared or not! return $iid_top } @@ -5811,7 +5728,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { #remove ourself from the usedby list of the previous interface array unset ::p::${iid_top}::_iface::o_usedby i$OID set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - + set posn [lsearch $ifaces $iid_top] set extracted_sub_dict [dict get $MAP interfaces] dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] @@ -5820,7 +5737,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { set iid_top $IID set iface ::p::ifaces::>$iid_top - } + } } } @@ -5834,7 +5751,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} proc ::p::-1::Properties {_ID_ {idx ""}} { - set OID [lindex [dict get $_ID_ i this] 0 0] + set OID [lindex [dict get $_ID_ i this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces @@ -5867,11 +5784,11 @@ proc ::p::-1::P {_ID_ {glob *}} { upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] + set members [list] foreach IID $interfaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] } - return [lsort $members] + return [lsort $members] } #PatternProperties @@ -5884,11 +5801,11 @@ proc ::p::-1::PP {_ID_ {glob *}} { upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set members [list] + set members [list] foreach IID $interfaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] } - return [lsort $members] + return [lsort $members] } @@ -5896,71 +5813,71 @@ proc ::p::-1::PP {_ID_ {glob *}} { #Interface Properties dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} proc ::p::-1::IP {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] - - foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { - if {[string match $glob [lindex $m 0]]} { - lappend members [lindex $m 0] - } - } - return $members + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members } #used by rename.test - theoretically should be on a separate interface! dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} proc ::p::-1::CheckInvocants {_ID_ args} { - #check all invocants in the _ID_ are consistent with data stored in their MAP variable - set status "ok" ;#default to optimistic assumption - set problems [list] - - set invocant_dict [dict get $_ID_ i] - set invocant_roles [dict keys $invocant_dict] - - foreach role $invocant_roles { - set invocant_list [dict get $invocant_dict $role] - foreach aliased_invocantdata $invocant_list { - set OID [lindex $aliased_invocantdata 0] - set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] - #we use lrange to make sure the lists are in canonical form - if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { - set status "not-ok" - lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] - } - } - - } - - - set result [dict create] - dict set result status $status - dict set result problems $problems - - return $result + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result } #get or set t dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} proc ::p::-1::Namespace {_ID_ args} { - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set IID [lindex [dict get $MAP interfaces level0] end] - - namespace upvar ::p::${IID}::_iface o_varspace active_varspace - - if {[string length $active_varspace]} { - set ns ::p::${OID}::$active_varspace - } else { - set ns ::p::${OID} - } + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? # - should .. Namespace be usable at all from outside the object? @@ -6003,33 +5920,33 @@ proc ::p::-1::PatternUnknown {_ID_ args} { set invocants [dict get $_ID_ i] set OID [lindex [dict get $invocants this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - #::p::predator::remap $invocant - } - - set handlermethod [lindex $args 0] - - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } } @@ -6041,58 +5958,58 @@ proc ::p::-1::Unknown {_ID_ args} { set OID [lindex [dict get $invocants this] 0 0] upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - set prev_open [set ::p::${existing_IID}::_iface::o_open] + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - set posn [lsearch $interfaces $existing_IID] + set posn [lsearch $interfaces $existing_IID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_open - } + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } - set handlermethod [lindex $args 0] + set handlermethod [lindex $args 0] - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - #set ::p::${IID}::(unknown) $handlermethod + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod - interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] #namespace eval ::p::${OID} [list namespace unknown $handlermethod] - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } } #useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' -# should also work for non-object results +# should also work for non-object results dict set ::p::-1::_iface::o_methods As {arglist {varname}} proc ::p::-1::As {_ID_ varname} { set invocants [dict get $_ID_ i] #puts stdout "invocants: $invocants" #!todo - handle multiple invocants with other roles, not just 'this' - + set OID [lindex [dict get $_ID_ i this] 0 0] if {$OID ne "null"} { upvar #0 ::p::${OID}::_meta::map MAP @@ -6143,8 +6060,8 @@ proc ::p::-1::AsFile {_ID_ filename args} { } } set fd [open $filename w] - fconfigure $fd -translation binary - + fconfigure $fd -translation binary + set invocants [dict get $_ID_ i] set OID [lindex [dict get $_ID_ i this] 0 0] if {$OID ne "null"} { @@ -6178,7 +6095,7 @@ proc ::p::-1::AsFile {_ID_ filename args} { #tailcall set $varname $resultlist } } - + } @@ -6190,58 +6107,58 @@ proc ::p::-1::Object {_ID_} { upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set result [string map [list ::> ::] $cmd] - if {![catch {info level -1} prev_level]} { - set called_by "(called by: $prev_level)" - } else { - set called_by "(called by: interp?)" + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } - } - - puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" - puts stdout " (returning $result)" + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" - return $result + return $result } #todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname -dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} proc ::p::-1::MakeAlias {_ID_cmdname } { set OID [::p::obj_get_this_oid $_ID_] upvar #0 ::p::${OID}::_meta::map MAP lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " } dict set ::p::-1::_iface::o_methods ID {arglist {}} proc ::p::-1::ID {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - return $OID + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID } dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} proc ::p::-1::IFINFO {_ID_} { - puts stderr "--_ID_: $_ID_--" - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - - puts stderr "-- MAP: $MAP--" - - set interfaces [dict get $MAP interfaces level0] - set IFID [lindex $interfaces 0] - - if {![llength $interfaces]} { - puts stderr "No interfaces present at level 0" - } else { - foreach IFID $interfaces { - set iface ::p::ifaces::>$IFID - puts stderr "$iface : [$iface --]" - puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" - set variables [set ::p::${IFID}::_iface::o_variables] - puts stderr "\tvariables: $variables" - } - } - + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + } @@ -6249,81 +6166,81 @@ proc ::p::-1::IFINFO {_ID_} { dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} proc ::p::-1::INVOCANTDATA {_ID_} { - #same as a call to: >object .. - return $_ID_ + #same as a call to: >object .. + return $_ID_ } #obsolete? dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { - set updated_ID_ $_ID_ - array set updated_roles [list] - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - foreach role $invocant_roles { - - set role_members [dict get $invocants $role] - foreach member [dict get $invocants $role] { - #each member is a 2-element list consisting of the OID and a dictionary - #each member is a 5-element list - #set OID [lindex $member 0] - #set object_dict [lindex $member 1] - lassign $member OID alias itemcmd cmd wrapped - - set MAP [set ::p::${OID}::_meta::map] - #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} - - if {[dict get $MAP invocantdata] eq $member} - #same - nothing to do - - } else { - package require overtype - puts stderr "---------------------------------------------------------" - puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" - set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] - puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" - puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" - puts stderr "---------------------------------------------------------" - #take _meta::map version - lappend updated_roles($role) [dict get $MAP invocantdata] - } - - } - - #overwrite changed roles only - foreach role [array names updated_roles] { - dict set updated_ID_ i $role [set updated_roles($role)] - } - - return $updated_ID_ + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ } - + dict set ::p::-1::_iface::o_methods INFO {arglist {}} proc ::p::-1::INFO {_ID_} { - set result "" - append result "_ID_: $_ID_\n" - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - append result "invocant roles: $invocant_roles\n" - set total_invocants 0 - foreach key $invocant_roles { - incr total_invocants [llength [dict get $invocants $key]] - } - - append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" - foreach key $invocant_roles { - append result "\t-------------------------------\n" - append result "\trole: $key\n" - set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants - append result "\t Raw data for this role: $role_members\n" - append result "\t Number of invocants in this role: [llength $role_members]\n" - foreach member $role_members { - #set OID [lindex [dict get $invocants $key] 0 0] - set OID [lindex $member 0] + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] append result "\t\tOID: $OID\n" if {$OID ne "null"} { upvar #0 ::p::${OID}::_meta::map MAP @@ -6344,16 +6261,16 @@ proc ::p::-1::INFO {_ID_} { lassign $member _OID namespace default_method stackvalue _wrapped append result "\t\t last item on the predator stack is a value not an object" append result "\t\t Value is: $stackvalue" - + } - } - append result "\n" - append result "\t-------------------------------\n" - } - - - - return $result + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result } @@ -6371,52 +6288,52 @@ proc ::p::-1::Rename {_ID_ args} { - #puts ">>.>> Rename. _ID_: $_ID_" + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" - if {[catch { + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata - if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { - - #appears to be a 'trace command rename' firing - #puts "\t>>>> rename trace fired $MAP $args <<<" - lassign $args oldcmd newcmd - set extracted_invocantdata [dict get $MAP invocantdata] - lset extracted_invocantdata 3 $newcmd - dict set MAP invocantdata $extracted_invocantdata + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped - - lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - #Write the same info into the _ID_ value of the alias - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - - - - #! $object_command was initially created as the renamed alias - so we have to do it again - uplevel 1 [list rename $alias $object_command] - trace add command $object_command rename [list $object_command .. Rename] - } elseif {[llength $args] == 1} { - #let the rename trace fire and we will be called again to do the remap! - uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] - } else { - error "Rename expected \$newname argument ." - } - } errM]} { - puts stderr "\t@@@@@@ rename error" - set ruler "\t[string repeat - 80]" - puts stderr $ruler - puts stderr $errM - puts stderr $ruler - - } + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return - return - } proc ::p::obj_get_invocants {_ID_} { diff --git a/src/vfs/_vfscommon.vfs/modules/patterncipher-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/patterncipher-0.1.1.tm new file mode 100644 index 00000000..62b03cbc --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/patterncipher-0.1.1.tm @@ -0,0 +1,1459 @@ +#JMN 2021 +#public domain + + +#--------------------------------------------------------- +#todo - see if we can include twofish https://wiki.tcl-lang.org/page/Twofish+in+Tcl +# - that twofish implementation relies on Itcl. todo - create .tm package for it. (change oo system?) +#--------------------------------------------------------- +# +# encryption decryption howto + +# patternciper::>AES .. Create >obj +# set [>obj . cipherkey .] $16bytes +# >obj . encrypt $arbitray_data_of_any_length +# (returns number of bytes stored) +# +# >obj . encrypt $any_size_string -last 1 +# (the -last flag will make the encryption system pad the last chunk) +# >obj . ciphertext .. As my_encrypted_data_variable +# set checkplaintext [>obj . decrypt] +# (this can be used to verify decryption and resets the cbc encryption ready for another round) +# +# + + +package provide patterncipher [namespace eval patterncipher { + variable version + set version 0.1.1 +}] + + + +#Change History +#------------------------------------------------------------------------------- +# 2021 - start out with blowfish as although it's outdated, it's easily available in tcllib. Todo - add twofish, AES +#------------------------------------------------------------------------------- + +package require ascii85 ;#tcllib +package require pattern +::pattern::init ;# initialises (if not already) + +namespace eval ::patterncipher { + namespace eval algo::txt { + set tokenid 0 + set tokendata [dict create] + set data_block_bytes 0 ;#means don't care + set iv_bytes 16 + set key_byte_sizes [list 8 16] + + + proc Init {mode keydata iv} { + variable tokenid + variable tokendata + if {[string length $iv] != 16} { + error "[namespace::current] Init IV must be 16 bytes long" + } + + dict set tokendata $tokenid [list mode $mode key $keydata iv $iv lastblock "" ] + return [lindex [list [namespace current]::$tokenid [incr tokenid]] 0] ;#post increment via inline K combinator + } + proc Encrypt {token data} { + variable tokendata + variable data_block_bytes + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Encrypt) invalid tokenid $tokenid token:$token" + } + if {$data_block_bytes != 0} { + if {([string length $data] % $data_block_bytes) != 0} { + error "([namespace current]::Encrypt) invalid block size for data. Must be $data_block_bytes bytes." + } + set idx [expr {$data_block_bytes - 1}] + dict set tokendata $tokenid lastblock [string range $data end-$idx end] + } + set client_mode [dict get $tokendata $tokenid mode] + set iv_as_mode [string trim [dict get $tokendata $tokenid iv] _] + + + + if {$iv_as_mode ne $client_mode} { + set enc [encoding convertto $iv_as_mode [encoding convertfrom $client_mode $data]] + } else { + set enc [encoding convertfrom $client_mode $data] + } + + return $enc + } + proc Decrypt {token data} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Decrypt) invalid tokenid $tokenid token:$token" + } + set client_mode [dict get $tokendata $tokenid mode] + set iv_mode [string trim [dict get $tokendata $tokenid iv] _] + + if {$iv_mode ne $client_mode} { + set dec [encoding convertfrom $iv_mode $data] + } else { + set dec $data + } + set dec [encoding convertto $client_mode $dec] + + return $dec + } + proc Reset {token iv} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Reset) invalid tokenid $tokenid token:$token" + } + dict set tokendata $tokenid lastblock "" + + } + proc Final {token} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Final) invalid tokenid $tokenid token:$token" + } + dict unset tokendata $tokenid + } + } + +} + +namespace eval ::patterncipher { + #namespace export {[a-z]*} + #namespace export {[>]*} + proc help {} { + set cipherlib ::patterncipher::libs::>lib_standard + set definitions [$cipherlib . cipher_definitions] + set m "" + append m "\n" + append m "Create cipher-specific objects with name of your choosing for encryption and decryption:\n" + + foreach cn [$cipherlib . ciphernames] { + append m "patterncipher::>$cn .. Create >my-[dict get $definitions $cn cipherid]-encryptor\n" + } + + append m "\n" + append m "--------------------------------------------------------------------------------------------------\n" + append m "Get cipher specific help e.g patterncipher::>blowfish, patterncipher::>AES etc :\n" + append m "patterncipher::>AES . help ;#patterncipher::>AES is the prototype from which we create objects.\n" + append m " ;# The prototype itself has a help method which is not inherited by objects created from it\n" + } + + + + namespace eval libs {} ;#namespace for >lib instances + + + patternlib::>collection .. Create >libs + + >pattern .. Create >lib + >lib .. Method help {} { + set help { + To create a custom library: +::patterncipher::>lib .. Create ::patterncipher::libs::>my-lib -name "mylib" .. As mylib + or +set mylib [::patterncipher::>lib .. Create ::patterncipher::libs::>my-lib -name "mylib"] + + The object will automatically be added to the collection ::patterncipher::>libs + The latest element added to this collection will be the one used by new cipher instances. + To create a cipher using a specific >lib instance, use -patterncipherlib when constructing instances + + } + return $help + } + + >lib .. PatternProperty name + >lib .. PatternPropertyWrite name {newname} { + var o_name + if {$o_name eq "standard"} { + #!todo - allow -force option in case caller knows what they're doing? + error "(>lib-instance . name (write)) ERROR: cannot rename 'standard' library." + } + ::patterncipher::>libs . reKey $o_name $newname + set o_name $newname + } + + >lib .. Constructor {args} { + var this o_name o_padding_schemes o_bucketsize_by_hex1 o_ascii85_wraplen + var o_frame_boundaries o_hex1_by_bucketsize o_bucketsize_by_hex4 o_hex4_by_bucketsize + var o_cipher_definitions o_cipherids + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -name] + dict set default -name "" + if {([llength $args] % 2) != 0} { + error "(>lib-instance .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((>lib-instance .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_name [dict get $opts -name] + #---------------------------------------------------------------------------- + if {![string length $o_name]} { + error "((>lib-instance .. Constructor) ERROR: -name value is required." + } + + if {[::patterncipher::>libs . hasKey $o_name]} { + error "((>lib-instance .. Constructor) ERROR: -name value is already in the ::patterncipher::>libs collection - choose another name." + } + + ::patterncipher::>libs . add ::patterncipher::libs::>lib_standard $o_name ;# now avail as '::patterncipher::>libs $o_name' + + #Once the standard lib is in the collection, overlay a >keayvalprotector on >libs to stop the standard lib being removed too easily + if {$o_name eq "standard"} { + ::patternlib::>keyvalprotector .. Create ::patterncipher::>libs -keys [list standard] -vals [list $this] + } + + #----------------------------------------------------------------------------------------------------- + #set up stream chunk boundaries + #64 bytes selected as the smallest chunk size. Obfuscates lengths for small pieces of data - plus 5Byte header overhead not too bad. + ## starting data - redistributed + ##set block1 [list 512 512 512 512 512 512 512 512] + ##set block2 [list 1024 1024 1024 1024] + ##set block3 [list 2048 2048] + set block1 [list 64 192 320 448 576 704 832 960 ] ; #128 spacing + set block2 [list 976 1008 1040 1072] ;# 32 spacing + set block3 [list 1984 2112] ;#128 spacing + set block4 [list 4096] + # 4096 4096 4096 ... repeated until final chunk detected. + #This gives 15 values. Hex 1 to F, leaving 0 for the final arbitrary length rest-of-stream. + # ie 64 = 1 192 = 2 ... 1040 = B 4096 = F + + #If the blocks above are played with - streaming incompatibilities/inefficiences will occur with previous/other versions of patterncipher. + set code_check 1 + if $code_check { + set o_frame_boundaries [concat $block1 $block2 $block3 $block4] + foreach l [list $block1 $block2 $block3 ] { + if {[expr [join $l +]] != 4096} { + error "frame_boundaries list is not configured as a 4096 multiple" + } + } + if {![expr [join $o_frame_boundaries +]] == 16384} { + #This boundary sequence that should be a multiple of 4K. + error "frame_boundaries list is not configured as a 4096 multiple" + } + foreach len $o_frame_boundaries { + if {($len % 8) != 0} { + error "stream boundary '$len' is not a multiple of 8 bytes" + } + } + } + #set up bucketids + set bucket_hex4 [list] + foreach len $o_frame_boundaries { + lappend bucket_hex4 [format %04x $len] ;# e.g 192 = 00c0 4096 = 1000 + } + + set o_bucketsize_by_hex1 [concat {*}[lmap c {1 2 3 4 5 6 7 8 9 A B C D E F} s $o_frame_boundaries {list $c $s}]] ;#dict + set o_bucketsize_by_hex4 [concat {*}[lmap h $bucket_hex4 s $o_frame_boundaries {list $h $s}]] ;#dict + + set o_hex1_by_bucketsize [concat {*}[lmap s $o_frame_boundaries c {1 2 3 4 5 6 7 8 9 A B C D E F} {list $s $c}]] ;#dict + set o_hex4_by_bucketsize [concat {*}[lmap s $o_frame_boundaries h $bucket_hex4 {list $s $h}]] ;#dict + + + set o_padding_schemes [list 0 text-minpad 1 text-buckets 2 binary-minpad 3 binary-buckets] + #whichever padding_scheme is used, the frame_boundaries will still be used to determine where to split the data + set o_ascii85_wraplen 120 + + + #------------------ + #For cipherid "TXT" + #pull out desired default encoding and put it at the front of the list + set encnames [encoding names] + set default "utf-8" ;#must be one that's in the list + set idx [lsearch $encnames $default] + set encnames [lreplace $encnames $idx $idx] + set encnames [concat $default $encnames] + #------------------ + + #---------------------------------------------------- + #iv_static should only be 1 for testing, or for specific definitions such as 'TXT' which use IV to carry the text encoding hint. + # + #notes: + #- always list the default mode first in modes + #- iv_method is a method with arguments of the patterncipher library. + # New methods can be grafted onto the lib as necessary. + # The argument %ivb will be substituted with iv_bytes value + # The argument %cn will be substituted with the key used in o_cipher_definitions + # (this could then be used in a method to retrieve any of the other defined values) + # The iv_method must be able to handle -userdata user-supplied IV data (or empty string if none). + # Can be verified/ignored etc. + #- cipherid must be 3 bytes long and is used in the default header building mechanism + # !todo - add a member such as 'hdr_method' to allow the lib to define a totally different header system. + #- pkgrequire & algocommand together define the underlying encryption library command. + # This must provide the API as used by various tcllib encryption functions such as AES & blowfish + # A custom algocommand e.g some commands placed in '::patterncipher::algo::' may be able to wrap other + # libraries/functionalities if the semantics are not too dissimilar. + # The API used by the tcllib encryption functions has commands: Init,Encrypt,Decrypt,Reset,Final. + # + set o_cipher_definitions [dict create] + dict set o_cipher_definitions "text" [list \ + enabled 1\ + cipherid "TXT" \ + pkgrequire patterncipher\ + algocommand ::patterncipher::algo::txt\ + data_block_bytes 0\ + iv_bytes 16\ + iv_static 1\ + iv_method [list get_iv_for_ciphername %cn]\ + key_byte_sizes [list 8]\ + modes $encnames\ + ] + + dict set o_cipher_definitions "blowfish" [list \ + enabled 1\ + cipherid "BFS" \ + pkgrequire blowfish\ + algocommand ::blowfish\ + data_block_bytes 8\ + iv_bytes 8\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic ]\ + key_byte_sizes [list 8]\ + modes [list cbc ecb]\ + ] + + dict set o_cipher_definitions "AES" [list \ + enabled 1\ + cipherid "AES"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 16 24 32]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-128" [list \ + enabled 1\ + cipherid "A16"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 16]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-192" [list \ + enabled 1\ + cipherid "A24"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 24]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-256" [list \ + enabled 1\ + cipherid "A32"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 32]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "DES" [list \ + enabled 1\ + cipherid "DES"\ + pkgrequire des\ + algocommand ::DES\ + data_block_bytes 8\ + iv_bytes 8\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 8 32]\ + modes [list cbc ecb cfb ofb]\ + ] + + $this . rebuild_cipher_ids_and_names + + puts stdout "padding_buckets hex1code: $o_bucketsize_by_hex1" + puts stdout "padding_buckets hex4code: $o_bucketsize_by_hex4" + #----------------------------------------------------------------------------------------------------- + } + + >lib .. PatternMethod cipher_disable {ciphername} { + var this o_cipher_definitions + if {$ciphername ni [dict keys $o_cipher_definitions]} { + error "(>lib . cipher_disable) ciphername $ciphername not in list of defined ciphers: [dict keys $o_cipher_definitions]" + } + dict set o_cipher_definitions $ciphername enabled 0 + $this . rebuild_cipher_ids_and_names + return 1 + } + + >lib .. PatternMethod cipher_enable {ciphername} { + var o_cipher_definitions + if {$ciphername ni [dict keys $o_cipher_definitions]} { + error "(>lib . cipher_enable) ciphername $ciphername not in list of defined ciphers: [dict keys $o_cipher_definitions]" + } + dict set o_cipher_definitions $ciphername enabled 1 + $this . rebuild_cipher_ids_and_names + return 1 + } + >lib .. PatternMethod rebuild_cipher_ids_and_names {} { + var o_cipherids o_ciphernames o_cipher_definitions + set o_cipherids [list] + set o_ciphernames [list] + foreach k [dict keys $o_cipher_definitions] { + if {[dict get $o_cipher_definitions $k enabled]} { + lappend o_cipherids [dict get $o_cipher_definitions $k cipherid] + lappend o_ciphernames $k + } + } + return $o_cipherids + } + + >lib .. PatternProperty cipher_definitions [dict create] + + #the cipherids must be 3 bytes - to form part of the ciphertexts 8byte header. e.g BFS = blowfish has headers like 1BFSC42E + >lib .. PatternProperty cipherids [list] + >lib .. PatternProperty ciphernames [list] + + >lib .. PatternProperty padding_schemes + >lib .. PatternProperty ascii85_wraplen + + >lib .. PatternProperty frame_boundaries + >lib .. PatternPropertyWrite frame_boundaries {boundarylist} { + var o_name o_frame_boundaries + if {$o_name eq "standard"} { + error "(>lib-instance . frame_boundaries (write)) ERROR: frame_boundaries is read-only. Create a new patterncipher::>lib object for different behaviour" + } + set o_frame_boundaries $boundarylist + } + >lib .. PatternProperty hex1_by_bucketsize + >lib .. PatternPropertyWrite hex1_by_bucketsize {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . hex1_by_bucketsize (write)) ERROR: hex1_by_bucketsize is read-only." + } + >lib .. PatternProperty bucketsize_by_hex1 + >lib .. PatternPropertyWrite bucketsize_by_hex1 {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . bucketsize_by_hex1 (write)) ERROR: hex1_by_bucketsize is read-only." + } + + >lib .. PatternProperty hex4_by_bucketsize + >lib .. PatternPropertyWrite hex4_by_bucketsize {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . hex4_by_bucketsize (write)) ERROR: hex4_by_bucketsize is read-only." + } + >lib .. PatternProperty bucketsize_by_hex4 + >lib .. PatternPropertyWrite bucketsize_by_hex4 {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . bucketsize_by_hex4 (write)) ERROR: hex4_by_bucketsize is read-only." + } + + #K can be used by some cipher_definitions to set the iv to a string - alternatively - lindex [list "value" _dontcare] 0 + #also it is known as the K combinator + >lib .. PatternMethod K {a args} {set a} + + + >lib .. PatternMethod get_iv_for_ciphername {cname args} { + #any specific customizations we need to get an IV for a specific cipher + var this o_cipher_definitions + #---------------------------------------------------------------------------- + set known_args [list -userdata] + if {([llength $args] % 2) != 0} { + error "(get_iv_for_ciphername) ERROR: odd number of options supplied. Usage: '. get_iv_for_ciphername \$ciphername \[-option val\]*' where -option one of '$known_args' " + } + if {[llength $args]} { + foreach {a b} $args { + if {$a ni $known_args} { + error "(get_random_bytes) ERROR: unknown option '$a'. Usage: '. get_iv_for_ciphername \$ciphername \[-option val\]*' where -option one of '$known_args' " + } + } + } + dict set default -userdata "" + set opts [dict merge $default $args] + set userdata [dict get $opts -userdata] + #---------------------------------------------------------------------------- + + + set ivb [dict get $o_cipher_definitions $cname iv_bytes] + switch $cname { + "text" { + if {![string length $userdata]} { + set m [lindex [dict get $o_cipher_definitions $cname modes] 0] + if {![string length $m]} { + error "($this get_iv_for_ciphername) Error: can't calculate IV" + } + set iv "$m[string repeat _ $ivb]" + set iv [string range $iv 0 $ivb-1] + # e.g "utf-8___________" + return $iv + } else { + if {[string length $userdata] == $ivb} { + #assume they know what they're doing if length exactly right and pass through as is + return $userdata + } else { + #It's valid to supply an encoding name such as utf-8 or unicode - check that the system knows it first though + if {$userdata in [dict get $o_cipher_definitions $cname modes]} { + set iv "$userdata[string repeat _ $ivb]" + return [string range $iv 0 $ivb-1] + } else { + error "($this get_iv_for_ciphername) Error: can't calculate IV from user supplied data '$userdata'" + } + } + } + } + default { + return [$this . get_random_bytes $ivb -userdata $userdata] + } + } + } + + >lib .. PatternVariable o_get_random_bytes_calls 0 ;#additional data for random seed values - ensure no two calls have same seed even if called in quick succession. + >lib .. PatternMethod get_random_bytes {len args} { + var o_get_random_bytes_calls + incr o_get_random_bytes_calls + #puts stdout "get_random_bytes call:$o_get_random_bytes_calls" + + #---------------------------------------------------------------------------- + set known_args [list -method -ascii85 -userdata] + if {([llength $args] % 2) != 0} { + error "(get_random_bytes) ERROR: odd number of options supplied. Usage: '. get_random_bytes \$numbytes \[-option val\]*' where -option one of '$known_args' " + } + if {[llength $args]} { + foreach {a b} $args { + if {$a ni $known_args} { + error "(get_random_bytes) ERROR: unknown option '$a'. Usage: '. get_random_bytes \$numbytes \[-option val\]*' where -option one of '$known_args' " + } + } + } + dict set default -method basic + dict set default -ascii85 0 + dict set default -userdata "" + set opts [dict merge $default $args] + set method [dict get $opts -method] + set ascii85 [dict get $opts -ascii85] + set userdata [dict get $opts -userdata] + #---------------------------------------------------------------------------- + + + set known_methods [list basic] + switch [string tolower $method] { + "basic" { + #considered cryptographically insecure. + #pick $len numbers 0 to 255 + set seed [clock seconds] + append seed [clock clicks] $o_get_random_bytes_calls [pid] + #!todo - add some unpredictable things to the seed. + expr {srand($seed)} ;#srand seems to be able to handle artibrarily large numbers + set bytelist [list] + for {set i 0} {$i < $len} {incr i} { + lappend bytelist [expr {int(rand()*256)}] ;# 0 to 255 + } + #puts stdout ">>bytelist $bytelist" + if {$ascii85} { + #Note. Do not wrap here. (e.g do not use o_ascii85_wraplen). Manually do it later so linebreaks in final result are consistent. + # - also, ascii85::encode uses regular expressions where maxlen can't be > 256 + set random_binstr [binary format c$len $bytelist] + #always truncate to proper length before encoding.. + set combined [string range $userdata$random_binstr 0 $len-1] + + set text [ascii85::encode -maxlen 0 $combined] + return [string range $text 0 $len-1] ;#truncate again in case it grew + } else { + + set random_binstr [binary format c${len} $bytelist] + + return [string range $userdata$random_binstr 0 $len-1] + } + } + default { + error "(get_random_bytes) ERROR: Unknown randomisation method '$method'. Expected one of '$known_methods'" + } + } + } + >lib .. PatternMethod get_bucket_info {size_of_ascii85} { + var o_frame_boundaries o_hex1_by_bucketsize o_hex4_by_bucketsize + set hex1 F ;#default if no other code matched - means 'Final' and payload limit of 4080 + set hex4 00 ;#Final - and payload limit of 65535 + set size 0 ;#indicates unspecified/unlimited + foreach bucketsize $o_frame_boundaries { + if {$size_of_ascii85 < $bucketsize} { + set hex1 [dict get $o_hex1_by_bucketsize $bucketsize] + set hex4 [dict get $o_hex4_by_bucketsize $bucketsize] + set size $bucketsize + break + } + } + puts stdout "... get_bucket_info [list hex1 $hex1 hex4 $hex4 size $size]" + return [list hex1 $hex1 hex4 $hex4 size $size] + } + >lib .. Create ::patterncipher::libs::>lib_standard -name "standard" + +} + + +namespace eval ::patterncipher { + +#--------------------------------------------------------------------------- + #overlay/mixin - (created in constructor) these also become properties on the >blowfish/>aes instances + # - + # - These are cipher-specific settings not intended to be user configurable. + >pattern .. Create >cipher_bytesizes + >cipher_bytesizes .. Constructor {args} { + var this o_data_block_bytes o_iv_bytes o_key_byte_sizes o_spud + set this @this@ + puts stdout "---->cipher_bytesizes Constructor running with args $args creating $this" + #---------------------------------------------------------------------------- + set known_opts [list] + set required_opts [list] + set default [dict create] + #dict set default -something etc + if {([llength $args] % 2) != 0} { + error "($this . Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(($this . Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + foreach o $required_opts { + if {$o ni $args} { + error "(($this . Constructor) ERROR: the following options are not actually optional: '$required_opts'" + } + } + set opts [dict merge $default $args] + #---------------------------------------------------------------------------- + + } + #Hidden - variables with PropertyRead and/or PropertyWrite become a hidden property + # readonly & hidden + >cipher_bytesizes .. PatternVariable o_data_block_bytes + >cipher_bytesizes .. PatternPropertyRead data_block_bytes {} { + var o_data_block_bytes + return $o_data_block_bytes + } + + #readonly & hidden + >cipher_bytesizes .. PatternVariable o_iv_bytes + >cipher_bytesizes .. PatternPropertyRead iv_bytes {} { + var o_iv_bytes + return $o_iv_bytes + } + + #readonly and visible + >cipher_bytesizes .. PatternProperty key_byte_sizes + >cipher_bytesizes .. PatternPropertyWrite key_byte_sizes {not_writable} { + var this + error "($this . key_byte_sizes (write)) ERROR: property key_byte_sizes is read only." + } + + #--------------------------------------------------------------------------- + + + +} + + +namespace eval ::patterncipher { + + + #mixin via Clone mechanism to the >cipher prototype + ::patterncipher::>cipher_bytesizes .. Clone [namespace current]::>ciphermaster + + + >ciphermaster .. Construct {} { + var this + set this @this@ + } + >ciphermaster .. Method help {} { + var this o_ciphername + set this @this@ + #o_data_block_bytes o_iv_bytes o_key_byte_sizes + set cipherlib ::patterncipher::libs::>lib_standard + set cipherdefs [$cipherlib . cipher_definitions] + set key_byte_sizes [dict get $cipherdefs $o_ciphername key_byte_sizes] + set data_block_bytes [dict get $cipherdefs $o_ciphername data_block_bytes] + + #a sample key of correct length for first key size in $key_byte_sizes + set longkey "8BYTES1\]8BYTES2\]8BYTES3\]8BYTES4\]8BYTES5\]8BYTES6\]8BYTES7\]8BYTES8\]" + set keysample [string range $longkey 0 [lindex $key_byte_sizes 0]-1] + + set help { + + patterncipher::>object .. Create >b1 + set [>b1 . key .] %kb1 ;#encipherment key. Allowed number of bytes: '%kbs%' + >b1 . encrypt \$something ;#chunks added don't have to be multiple of %dbs% bytes + >b1 . encrypt \"some-data-123\" ;# - they will be buffered,concatenated and finally padded. + >b1 . encrypt "\[command yielding data\]" -last 1 ;# '. encrypt -last 1' can take empty string if needed + ;# - alternatively you can call '. encryptlast' or '. encryptlast $lastchunk' instead + set encrypted_data [>b1 . ciphertext] ;# defaults to hex encoded + set raw_encrypted_data [>b1 . ciphertext -raw 1] ;# binary output + set verify [>b1 . decrypt_and_reset] ;# Only after calling this ( or '. reset' ) + ;# - can we start a new encrypting/decrypting cycle + + -------------------------------------------------------------------------------------------------------- + #To decrypt: + set [>b1 . ciphertext .] $encrypted_data ;# expects hex encoded, with 8-char header e.g '0BFS0FFF' + set plaintext [>b1 . decrypt_and_reset] + + } + set help [string map [list ">object" >$o_ciphername ">b1" >${o_ciphername}-instance %kb1 $keysample %kbs% $key_byte_sizes %dbs% $data_block_bytes] $help] + } + + + >ciphermaster .. Constructor {args} { + var this o_patterncipherlib o_ciphername + set this @this@ + puts stdout "(>cipher $this .. Constructor) running with args $args creating $this vars:[info vars]" + #---------------------------------------------------------------------------- + set known_opts [list -patterncipherlib] + dict set default -patterncipherlib [::patterncipher::>libs -1 ] ;#last item added to the >libs collection + if {([llength $args] % 2) != 0} { + error "(>cipher $this .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((>cipher $this .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_patterncipherlib [dict get $opts -patterncipherlib] + #---------------------------------------------------------------------------- + + $this . _init_cipher_from_definitions $o_ciphername + #set [$this . ciphername .] $o_ciphername + + + #run the next constructor (from object cloned onto this one) + #var o_data_block_bytes o_iv_bytes o_key_byte_sizes + puts stderr ">>>>>> here <<<" + #@next@ -data_block_bytes $o_data_block_bytes -iv_bytes $o_iv_bytes -key_byte_sizes $o_key_byte_sizes + #mixin + #$this .. PatternExpand + #::patterncipher::>cipher_bytesizes .. Create $this -data_block_bytes 8 -iv_bytes 8 -key_byte_sizes [list 8] + } + + + #We won't have private methods until the interface mechanism of patternpunk is settled. :/ + >ciphermaster .. PatternMethod _init_cipher_from_definitions {name} { + #don't declare any vars - so we get them all (?) + set definitions [$o_patterncipherlib . cipher_definitions] + set pkgname [dict get $definitions $name pkgrequire] + #! todo - add option to require exact version? + if {[catch {package require $pkgname} errMsg]} { + error "($this . ciphername (prop write)) unable to load package '$pkgname' for ciphername '$name' err: $errMsg" + } + set o_algocommand [dict get $definitions $name algocommand] + set o_cipherid [dict get $definitions $name cipherid] + set o_data_block_bytes [dict get $definitions $name data_block_bytes] + set o_iv_bytes [dict get $definitions $name iv_bytes] + set o_iv_static [dict get $definitions $name iv_static] + set o_iv_method [string map [list %ivb $o_iv_bytes %cn $name] [dict get $definitions $name iv_method]] + set o_key_byte_sizes [dict get $definitions $name key_byte_sizes] + set o_ciphermodes [dict get $definitions $name modes] + set o_mode [lindex $o_ciphermodes 0] + set o_ciphername $name + puts stdout "init_cipher_from_definitions running in [namespace current]" + } + + + >ciphermaster .. PatternProperty ciphername + >ciphermaster .. PatternPropertyWrite ciphername {name} { + var this o_patterncipherlib o_ciphername o_cipherid o_mode o_ciphertoken o_cipherbin + var o_data_block_bytes o_iv_bytes o_iv_static o_iv_method o_key_byte_sizes o_algocommand o_ciphermodes + + set definitions [$o_patterncipherlib . cipher_definitions] + + if {$name ni [dict keys $definitions]} { + puts stdout "known ciphernames: [dict keys $definitions]" + error "($this . ciphername (prop write)) cipher '$name' not known in this patterncipherlib: $o_patterncipherlib" + } + + if {[string length $o_cipherbin]} { + $this . ciphertext_header_info [string range $o_cipherbin 0 9] .. As header_info + if {[dict get $header_info status] != 1} { + error "($this . reset) Cannot reset IV while there is unfinalised ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + } + + + if {[string length $o_ciphername]} { + if {$name ne $o_ciphername} { + #changing from one cipher to another + + + if {[string length $o_ciphertoken]} { + $this . abandon + + #if {[catch {${o_algocommand}::Final $o_ciphertoken} errMsg]} { + # puts stderr "($this . ciphername (prop write)) changing ciphername $o_ciphername to $name . err calling Final with previous token $o_ciphertoken. Err: $errMsg" + #} + } + + } else { + #same name as before - warning because this is the wrong way to reset - if that's what was intended. + #puts stderr "($this . ciphername (prop write)) WARNING ciphername is already '$name'" + # constructor legitimately does this though - and in that case we need to run the reset operations below + + } + } + + #loads packages and sets vars + $this . _init_cipher_from_definitions $name + + + set o_ciphername $name + + #$this . reset + return $name + } + + #vars need to be declared as a PatternVariable or PatternProperty if we ever want them auto-declared + >ciphermaster .. PatternVariable o_algocommand + >ciphermaster .. PatternVariable o_iv_method + >ciphermaster .. PatternVariable o_ciphermodes + >ciphermaster .. PatternVariable o_iv_manually_set 0;#bool indicates was set via '. iv'. Resets each round unless o_iv_static is true. + >ciphermaster .. PatternVariable o_tailbuffer "" ;#remaining 1 to ($data_block_bytes -1) characters from when encrypt called with data not a multiple of $data_block_bytes bytes + >ciphermaster .. PatternVariable o_cipherpadding_numbytes 0 + + + + #NOTE - other properties are overlayed/mixed in during object construction in the Constructor + # e.g from >cipher_bytesizes + >ciphermaster .. PatternProperty patterncipherlib + >ciphermaster .. PatternProperty key "" ;# encryption key of size in $key_byte_sizes + >ciphermaster .. PatternProperty iv "" ;#$iv_bytes initialisation vector. Will be randomly created each round unless explicitly set. + >ciphermaster .. PatternProperty mode + >ciphermaster .. PatternProperty padschemeid 0;#1 = text based, ascii85 encoded, with paddingsize buckets + >ciphermaster .. PatternProperty padschemename ;# + >ciphermaster .. PatternProperty iv_static ;#whether or not random IV used each reset/init + + + >ciphermaster .. PatternProperty cipherid BFS ;#default - will only be used if cipherkey is not empty string + >ciphermaster .. PatternPropertyWrite cipherid {id} { + var o_cipherid o_patterncipherlib + if {$id ni [$o_patterncipherlib . cipherids]} { + error "($this . cipherid (property write)) cipherid '$id' not in list of known ciphers '[$o_patterncipherlib . cipherids]'" + } + error "not safe" + set o_cipherid $id + } + + >ciphermaster .. PatternVariable o_ciphertoken "" + >ciphermaster .. PatternPropertyRead ciphertoken "" { + var o_ciphertoken + return $o_ciphertoken + } + >ciphermaster .. PatternProperty cipherbin "" + + >ciphermaster .. PatternVariable o_chunknum 0 ;# + >ciphermaster .. PatternPropertyRead chunknum {} { + var o_chunknum + return o_chunknum + } + >ciphermaster .. PatternVariable o_chunklist [list] ;#no need for chunknum? + + >ciphermaster .. PatternProperty ciphertext ;#leave unset - underlying variable should never have a value. ciphertext is a dynamic property based on cipherbin + + + >ciphermaster .. PatternMethod padschemeinfo {{schemeid ""}} { + switch $schemeid { + "0" { + return [list scheme "text-minpad" notes "ascii85 encoded, minimum padding - at least 1 at most $o_data_block_bytes"] + } + "1" { + return [list scheme "text-buckets" notes "ascii85 encoded"] + } + "2" { + return [list scheme "binary-minpad" notes ""] + } + "3" { + return [list scheme "binary-buckets" notes ""] + } + default { + return [list scheme "unknown" notes "implemented padding schemes are [$o_patterncipherlib . padding_schemes]"] + } + } + } + + >ciphermaster .. PatternPropertyRead token {} { + var o_ciphertoken + return $o_ciphertoken + } + >ciphermaster .. PatternPropertyWrite mode {m} { + var this o_mode o_ciphermodes + if {$m ni $o_ciphermodes} { + error "($this . mode (write)) ERROR: supported modes are $o_ciphermodes" + } + set o_mode $m + } + >ciphermaster .. PatternPropertyRead ciphertext {args} { + var this o_cipherbin o_cipherpadding_numbytes o_cipherid o_patterncipherlib + if {$args eq [list -interim 1]} { + #allow bypassing header check for debug/test + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] $o_cipherbin] + return "INTERIM.$ascii85_payload" + } + + $this . ciphertext_header_info $o_cipherbin .. As header_info + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(cipherbin) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(cipherbin) Not yet retrievable - call '. encrypt -last 1' first." + } + } else { + set header [string range $o_cipherbin 0 7] + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] [string range $o_cipherbin 8 end]] + return $header$ascii85_payload ;#cyphertext with header + } + } + >ciphermaster .. PatternPropertyWrite ciphertext {frame_of_encrypted_data} { + var this o_patterncipherlib o_cipherbin o_cipherpadding_numbytes o_cipherid o_ciphertoken + if {[string length $o_cipherbin]} { + error "(cipherbin property write) There already seems to be an encryption operation underway - call decrypt to retrieve it." + } + #check header + $this . ciphertext_header_info $frame_of_encrypted_data .. As header_info + if {[dict get $header_info status] == 1} { + if {[dict get $header_info hdr_cipherid] ne $o_cipherid } { + error "(cipherbin property write) cipher in ciphertext [dict get $header_info hdr_cipherid] doesn't match currently configured cipher $o_cipherid" + } + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + set schemeid [dict get $header_info hdr_schemeid] + set bucketid [dict get $header_info hdr_bucketid] + set paybytes [dict get $header_info hdr_paybytes] + set paylen [dict get $header_info paylen] + set padlen [dict get $header_info padlen] + set o_cipherpadding_numbytes $padlen + if {$schemeid in {0 1}} { + #text based ascii85 + set head [string range $frame_of_encrypted_data 0 7] + set binary [::ascii85::decode [string range $frame_of_encrypted_data 8 end]] + set o_cipherbin $head$binary + } else { + #already binary + set o_cipherbin $frame_of_encrypted_data + } + + } else { + error "(ciphertext property write) ciphertext doesn't have proper header e.g 0BFS0FFF" + } + + } + >ciphermaster .. PatternPropertyRead cipherbin {args} { + var this o_cipherbin o_cipherpadding_numbytes o_cipherid + if {$args eq [list -interim 1]} { + #allow bypassing header check for debug/test + return $o_cipherbin + } + + + #check for #AAA0XXX header where # is a number from 1 to 8 and AAA is a cipher hint such as BFS or AES - this indicates --last has been called on encrypt and the ciphertext is ready to retrieve. + $this . ciphertext_header_info $o_cipherbin .. As header_info + + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(cipherbin) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(cipherbin) Not yet retrievable - call '. encrypt -last 1' first." + } + } else { + return $o_cipherbin ;#cyphertext with header + } + } + >ciphermaster .. PatternPropertyWrite cipherbin {encrypted_data} { + var this o_patterncipherlib o_cipherbin o_cipherpadding_numbytes o_cipherid o_ciphertoken + if {[string length $o_cipherbin]} { + error "(cipherbin property write) There already seems to be an encryption operation underway - call decrypt to retrieve it." + } + + #check header + $this . ciphertext_header_info $encrypted_data .. As header_info + if {[dict get $header_info status] == 1} { + if {[dict get $header_info hdr_cipherid] ne $o_cipherid } { + error "(cipherbin property write) cipher in ciphertext [dict get $header_info hdr_cipher] doesn't match currently configured cipher $o_cipherid" + } + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + set schemeid [dict get $header_info hdr_schemeid] + set bucketid [dict get $header_info hdr_bucketid] + set paybytes [dict get $header_info hdr_paybytes] + set paylen [dict get $header_info paylen] + set padlen [dict get $header_info padlen] + set o_cipherpadding_numbytes $padlen + + + set o_cipherbin $encrypted_data + } else { + error "(cipherbin property write) ciphertext doesn't have proper header e.g 0BFS0FFF" + } + } + >ciphermaster .. PatternPropertyUnset cipherbin {keypattern} { + var o_cipherbin + if {[string length $o_cipherbin]} { + error "($this . cipherbin (unset)) ERROR: cannot unset cipherbin - currently contains [string length $o_cipherbin] bytes." + } + } + >ciphermaster .. PatternPropertyWrite key {key_or_emptystring} { + var this o_data_block_bytes o_key o_ciphername o_key_byte_sizes + set datalen [string length $key_or_emptystring] + if {$datalen} { + if {($datalen ni $o_key_byte_sizes)} { + error "($this . key (write)) ERROR: bad key. $o_ciphername valid keylengths: '$o_key_byte_sizes'. Received $datalen bytes." + } + set newkey $key_or_emptystring + set oldkey $o_key + if {[string length $oldkey]} { + if {$newkey ne $oldkey} { + puts stderr "($this . key (write)) WARNING: changing $o_ciphername encipherment key '$oldkey' -> $newkey" + } + } + + } + set o_key $key_or_emptystring + } + + >ciphermaster .. PatternPropertyWrite iv {new_iv} { + var this o_ciphertoken o_iv o_iv_bytes o_iv_manually_set o_cipherbin o_algocommand + var o_iv_method o_patterncipherlib + + #puts "----> o_iv_method: $o_iv_method" + if {[string length $o_cipherbin]} { + error "($this . iv (write)) Cannot set IV while there is active cipher ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + + set library_passed_iv [{*}[concat $o_patterncipherlib . $o_iv_method -userdata $new_iv]] + + if {[string length $library_passed_iv] != $o_iv_bytes} { + error "($this . iv (write))IV returned by '[concat $o_patterncipherlib . $o_iv_method -userdata $new_iv]' was not $o_iv_bytes bytes long. Cipher configuration/library error?" + } + set o_iv $library_passed_iv + set o_iv_manually_set 1 + if {[string length $o_ciphertoken]} { + ${o_algocommand}::Reset $o_ciphertoken $o_iv + } + } + + + >ciphermaster .. PatternMethod reset {} { + var this o_ciphertoken o_iv o_iv_static o_iv_manually_set o_iv_bytes o_iv_method o_cipherbin + var o_tailbuffer o_cipherpadding_numbytes o_patterncipherlib o_algocommand + if {[string length $o_cipherbin]} { + $this . ciphertext_header_info [string range $o_cipherbin 0 9] .. As header_info + if {[dict get $header_info status] != 1} { + error "($this . reset) Cannot reset IV while there is unfinalised ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + } + if {$o_iv_static} { + #leave state of o_iv and o_iv_manually set as is + } else { + set o_iv_manually_set 0 + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + set o_cipherbin "" + set o_tailbuffer "" + set o_cipherpadding_numbytes 0 + if {[string length $o_ciphertoken]} { + ${o_algocommand}::Reset $o_ciphertoken $o_iv + } + } + >ciphermaster .. PatternMethod initcipher {} { + var this o_key o_key_byte_sizes o_iv o_iv_bytes o_iv_static o_iv_method o_iv_manually_set o_iv_previous + var o_ciphertoken o_mode o_cipherbin o_patterncipherlib o_algocommand + if {[string length $o_cipherbin]} { + error "($this . init) Cannot init while there is active cipher ciphertext. call 'decrypt_and_reset' or 'abandon' first or 'reset' if ciphertext has been finalised" + } + + + if {!$o_iv_manually_set} { + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + + } else { + if {$o_iv_static} { + #leave state of o_iv because it was manually configured and static + } else { + if {$o_iv eq $o_iv_previous} { + #change because not meant to be static + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + } + } + set o_iv_previous $o_iv + + if {[string length $o_key] ni $o_key_byte_sizes} { + error "(initcipher) '$this . key' current keylength:[string length $o_key] is wrong. Allowed lengths in bytes: '$o_key_byte_sizes'" + } + + set o_ciphertoken [${o_algocommand}::Init $o_mode $o_key $o_iv] + } + + >ciphermaster .. PatternMethod encryptlast {{newdata ""}} { + tailcall encrypt $_ID_ $newdata -last 1 + } + >ciphermaster .. PatternMethod encrypt {newdata args} { + var this o_ciphertoken o_cipherbin o_data_block_bytes o_key o_iv o_iv_bytes o_cipherpadding_numbytes o_tailbuffer o_patterncipherlib o_padschemeid o_cipherid o_algocommand + + #---------------------------------------------------------------------------- + set known_opts [list -last -show -key -iv] + dict set default -last 0 ;#when -last 1 do padding + dict set default -show 0 ;#echo $o_cipherbin to stdout + dict set default -reopen 0 ;#todo add -reopen by adding another bucket? + if {([llength $args] % 2) != 0} { + error "($this . encrypt) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(($this . encrypt) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set option_last [dict get $opts -last] + set option_show [dict get $opts -show] + set option_reopen [dict get $opts -reopen] + #---------------------------------------------------------------------------- + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + if {$o_cipherpadding_numbytes > 0} { + #once there is padding in the ciphertext data - we know this encrypt round is at an end. + error "($this . encrypt) Ciphertext is already finalised. Retrieve with '. ciphertext' and verify with '. decrypt_and_reset' before retrying." + } + + set newdata "$o_tailbuffer$newdata" ;#data we're adding in this method call + set o_tailbuffer "" + + if {$o_data_block_bytes > 0} { + set last_data_block_size [expr {[string length $newdata] % $o_data_block_bytes}] ;#if 0, newdata was a multiple of $o_data_block_bytes bytes + set blocksize $o_data_block_bytes + } else { + #non 'block-based' data - we'll never need padding + set blocksize [string length $newdata] + set last_data_block_size [string length $newdata] + } + set padding "" + + + if {![string length $o_cipherbin]} { + #first chunk to store in ciphertext. ciphertext requires 8 byte iv prepended + set o_cipherbin $o_iv ;# IV required for decryption + } + #o_cipherbin always has iv data at start now. + set iv_plus_content_size [expr {[string length $o_cipherbin ] + [string length $newdata]}] ;#iv + data is the payload the encrypter operates on + + if {$option_last} { + #treat as full bucket + set end_of_bucket 1 + } else { + #detect if we've filled a bucket + set end_of_bucket 0 + } + + + if {$end_of_bucket} { + #if we're already at a multiple of data_block_bytes bytes, still add padding so we can use o_cipherpadding_numbytes = 0 as a flag + + #New header of form #BFSHXLl where # is padding scheme X, BFSH is cipher, X is bucket code and Ll is the payload size (not including header) + #calculate size of the bucket needed for ascii85 encoded version of the payload + 8byte header + $blocksize bytes of minpadding + + #!todo - lookup text/vs binary from schemeinfo + if {$o_padschemeid in {0 1}} { + #text schemes + set hex_pay_len [format %04x $iv_plus_content_size] + set possible_newlines [expr {entier($iv_plus_content_size / [$o_patterncipherlib . ascii85_wraplen])}] + #review - guess vs redundant ascii85 encoding work? + set ascii85_content_size_guess [expr {entier(ceil(($iv_plus_content_size/4.0)*5)) + $possible_newlines}] ;#why guess? + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] $o_cipherbin$newdata] + + if {$ascii85_content_size_guess != [string length $ascii85_payload]} { + puts stdout "(encrypt) WARNING: ascii85 guess: '$ascii85_content_size_guess' vs ascii85 actual: '[string length $ascii85_payload]'" + } + + set bucket_info [$o_patterncipherlib . get_bucket_info $ascii85_content_size_guess] + set bucket_hex1 [dict get $bucket_info hex1] ; #1 byte hex + set bucket_size [dict get $bucket_info size] + + if {$o_padschemeid eq "0"} { + #text-minpad + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1 to $o_data_block_bytes + set needed_bytes $data_needed_bytes + set padding [string repeat * $needed_bytes] ;#primitive padding - #!todo review. + + set header "0${o_cipherid}0[string range ${hex_pay_len} 1 end]" + } elseif {$o_padschemeid eq "1"} { + #text-buckets + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] + puts stdout ">> data_needed_bytes: $data_needed_bytes" + set needed_bytes [expr {$bucket_size - 8 - $iv_plus_content_size}] + if {(8 + $iv_plus_content_size + $needed_bytes) != $bucket_size} { + error "(encrypt) ERROR: sanity_check 8 + iv&content ($iv_plus_content_size) + padding ($needed_bytes) != bucket_size ($bucket_size) - programming bug!" + } + + puts stdout ">> needed_bytes: $needed_bytes" + puts stdout ">>bucket_size: $bucket_size iv_plus_content_size: $iv_plus_content_size" + set padding [string repeat * $needed_bytes] + set header "1${o_cipherid}${bucket_hex1}[string range ${hex_pay_len} 1 end]" + } + + } elseif {$o_padschemeid in {2 3}} { + set hex_pay_len [format %04x $iv_plus_content_size] + + set bucket_info [$o_patterncipherlib . get_bucket_info $iv_plus_content_size] + set bucket_hex1 [dict get $bucket_info hex1] + set bucket_size [dict get $bucket_info size] + + set msb [string range $hex_pay_len 0 1] + set lsb [string range $hex_pay_len 2 3] + set bin_pay_len [binary format c2 [list "0x$msb" "0x$lsb"] + if {$o_padschemeid eq "2"} { + #binary-minpad + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1-$o_data_block_bytes + set needed_bytes $data_needed_bytes + set padding [$o_patterncipherlib . get_random_bytes $needed_bytes] + + set header "2${o_cipherid}${bucket_hex1}$bin_pay_len" + } elseif {$o_padschemeid eq "3"} { + #binary-buckets + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1-$o_data_block_bytes + set needed_bytes [expr {$bucket_size - 8 - $iv_plus_content_size}] + if {(8 + $iv_plus_content_size + $needed_bytes) != $bucket_size} { + error "(encrypt) ERROR: sanity_check 8 + iv&content ($iv_plus_content_size) + padding ($needed_bytes) != bucket_size ($bucket_size) - programming bug!" + } + set padding [$o_patterncipherlib . get_random_bytes $needed_bytes] + set header "3${o_cipherid}${bucket_hex1}$bin_pay_len" + } + } + + set o_cipherpadding_numbytes [string length $padding] ;#assertion: always non zero here + + set padded_data "$newdata$padding" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $padded_data] + + set o_cipherbin ${header}$o_cipherbin ;#header will make the '. ciphertext' property readable + + puts stdout "ciphertext final: >>> $o_cipherbin <<<" + #puts stderr ">>$padded_data<< [string length $padded_data] bytes" + set payload_bytes [expr [string length $o_cipherbin] - 8 - [string length $padding] - $o_iv_bytes] ;#account for IV and padding bytes to give caller an indication of + if {($payload_bytes + $o_iv_bytes) != $iv_plus_content_size} { + puts stderr "(encrypt) WARNING payloadbytes $payload_bytes != iv_plus_content_size $iv_plus_content_size" + } + + return [list payload_bytes $payload_bytes padding_bytes [string length $padding] header $header buffer_bytes [string length $o_tailbuffer] final 1] + } else { + if {$blocksize > 0} { + if {([string length $newdata] % $blocksize) != 0} { + #error "($this . encrypt) data chunk must be a multiple of $data_block_bytes bytes - call decrypt after one or more calls to encrypt, and/or call '. encrypt data_or_empty_string -last 1" + if {$last_data_block_size != 0} { + set o_tailbuffer [string range $newdata end-[expr {$last_data_block_size -1}] end] + set newdata [string range $newdata 0 end-$last_data_block_size] + } + + if {[string length $newdata]} { + puts stdout "1encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + } else { + puts stdout "2encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + } else { + puts stdout "3encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + set payload_bytes [expr [string length $o_cipherbin] - $o_iv_bytes] ;#account for IV to give caller an indication of payload bytes + + puts stdout "ciphertext: >>> $o_cipherbin padding:$padding should still be 0<<<" + return [list payload_bytes $payload_bytes padding_bytes [string length $padding] buffer_bytes [string length $o_tailbuffer] final 0] + } + + } + + + #abandon any currently-building ciphertext - drop the token + >ciphermaster .. PatternMethod abandon {} { + var this o_ciphertoken o_cipherbin o_cipherpadding_numbytes o_algocommand o_tailbuffer o_iv o_iv_manually_set + puts stdout "($this . abandon) Abandoning any active ciphertext. Encipherment key unchanged. Key-schedule will be regenerated (previous token Finalised)" + + catch {${o_algocommand}::Final $o_ciphertoken} + + set o_ciphertoken "" + set o_cipherbin "" + set o_tailbuffer "" + set o_iv "" + set o_iv_manually_set 0 + set o_cipherpadding_numbytes 0 + } + + #for some schemes - the info returned by ciphertext_header_info is only accurate if the full ciphertext is supplied - not just the header + # hdr_ fields can be trusted if an appropriately truncated ciphertext is supplied, but fields such as padlen may require the complete bucket. + >ciphermaster .. PatternMethod ciphertext_header_info {ciphertext} { + set schemeid [string range $ciphertext 0 0] ;#e.g 0, 1, 2 + set cipherid [string range $ciphertext 1 3] ;#e.g BFS, AES + set bucketid [string range $ciphertext 4 4] ;#hexchar 0-F + set paybytes [string range $ciphertext 5 7] ;#3bytes hex or binary payload length + set endiv [expr {(8 + $o_iv_bytes) -1}] + set cipheriv [string range $ciphertext 8 $endiv] ;# Initialisation vector + set errors [list] + #8 byte header for all schemeids for now + + if {(![string is integer -strict $schemeid]) || ($cipherid ni [$o_patterncipherlib . cipherids]) || (![string is xdigit -strict $bucketid]) || ([string length $paybytes] != 3)} { + lappend errors [expr {(![string is integer -strict $schemeid]) ? "bad schemeid" : ""}] + lappend errors [expr {($cipherid ni [$o_patterncipherlib . cipherids]) ? "cipherid '$cipherid' unknown" : ""}] + lappend errors [expr {(![string is xdigit -strict $bucketid]) ? "non-hex bucketid" : ""}] + lappend errors [expr {([string length $paybytes] != 3) ? "paybytes len != 3" : ""}] + set errors [lsearch -all -inline -not -exact $errors ""] ;#strip empty strings from error list + return [list status 0 hdr_schemeid $schemeid hdr_cipherid $cipherid hdr_bucketid $bucketid hdr_paybytes $paybytes iv $cipheriv errors $errors] + } + + #calculate payload length from paybytes + #for now - hard code the schemes here + set paylen_is_hex 0 + set paylen_is_binary 0 + if {$schemeid in {0 1}} { + set paylen_is_hex 1 + } elseif {$schemeid in {2 3}} { + set paylen_is_binary 1 + } else { + error "schemeid $schemeid unimplemented" + } + + if {$paylen_is_hex} { + set paylen [scan $paybytes %x] + } elseif {$paylen_is_binary} { + #test create a paylen with something like: set bin [binary format c3 {0x00 0x01 0x0A} + #H bigendian h smallendian + binary scan $paylen H3 v ;# turn to hex such as 00010a + set paylen [scan $v %x] ;# back to decimal + } + + if {$bucketid != 0} { + set bucketsize [dict get [$o_patterncipherlib . bucketsize_by_hex1] $bucketid] + set padlen [expr {$bucketsize - 8 - $paylen}] + } else { + set bucketsize 0 + set padlen [expr {[string length $ciphertext] - 8 - $paylen}] + } + + return [list status 1 hdr_schemeid $schemeid hdr_cipherid $cipherid hdr_bucketid $bucketid hdr_paybytes $paybytes iv $cipheriv bucketsize $bucketsize paylen $paylen padlen $padlen errors [list]] ;#always return errors member even if empty + + } + + #todo - detect if ciphertext hasn't been retrieved + >ciphermaster .. PatternMethod decrypt {} { + error "(decrypt) Call decrypt_and_reset to verify after retrieving encrypted data with '. ciphertext'" + } + + >ciphermaster .. PatternMethod decrypt_and_reset {} { + var this o_ciphertoken o_cipherbin o_tailbuffer o_cipherpadding_numbytes + var o_iv o_iv_bytes o_iv_static o_iv_method o_patterncipherlib o_cipherid o_algocommand + + if {![string length $o_cipherbin]} { + error "No data to decrypt - call encrypt first. After one or more calls to encrypt ending with '. encrypt -last', retrieve '. ciphertext' and call decrypt_and_reset to retrieve/verify plaintext chunk." + } + $this . ciphertext_header_info $o_cipherbin .. As header_info + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(decrypt_and_reset) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(decrypt_and_reset) Not yet retrievable - call '. encrypt -last 1' first." + } + } + + set bucketid [dict get $header_info hdr_bucketid] + set bucketsize [dict get $header_info bucketsize] + + set padlen [dict get $header_info padlen] + set paylen [dict get $header_info paylen] + #sanity checks + if {$o_cipherpadding_numbytes != $padlen} { + puts stderr "WARNING!! stored o_cipherpadding_numbytes '$o_cipherpadding_numbytes' != '. ciphertext_header_info' padlen '$padlen'" + } + if {([string length $o_cipherbin] -8 -$padlen) != $paylen} { + puts stderr "WARNING!! length of stored o_cipherbin - 8 '[expr {[string length $o_cipherbin] -8}]' != '.ciphertext_header_info' paylen '$paylen'" + } + + puts stdout "------------------------------------------------------" + puts stdout "About to decrypt: IV+encdata '[string range $o_cipherbin 8 80]...' with token $o_ciphertoken" + puts stdout "------------------------------------------------------" + set plaintext [${o_algocommand}::Decrypt $o_ciphertoken [string range $o_cipherbin 8 end]] ;#don't pass our #BFSXXXX- header to the ${o_algocommand} library + puts stdout "full decrypted plaintext [string length $plaintext] bytes including iv and padding (padlen:$padlen paylen $paylen bucketsize: $bucketsize) :" + puts stdout "------------------------------------------------------" + puts stdout "$plaintext" + puts stdout "------------------------------------------------------" + + #set padlength $o_cipherpadding_numbytes + #reset + + #${o_algocommand}::Final $o_ciphertoken + #set o_ciphertoken "" + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + if {!$o_iv_static} { + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + + ${o_algocommand}::Reset $o_ciphertoken $o_iv + + set o_cipherbin "" + set o_tailbuffer "" + set o_cipherpadding_numbytes 0 ;#important to reset this + #strip iv and padding to recover original data + return [string range $plaintext $o_iv_bytes end-$padlen] + } + + >ciphermaster .. Destructor {} { + var o_ciphertoken o_algocommand + ${o_algocommand}::Final $o_ciphertoken + } + +} + + +namespace eval ::patterncipher { + + set created_cipherpatterns [list] + foreach ciphername [::patterncipher::libs::>lib_standard . ciphernames] { + >pattern .. Create >cipher1 + >cipher1 .. Variable o_ciphername $ciphername ;#for help method on the prototype object + >cipher1 .. PatternVariable o_ciphername $ciphername + >cipher1 .. Clone >$ciphername ;#clone brings along its default values + >cipher1 .. Destroy + + >ciphermaster .. Clone >$ciphername + lappend created_cipherpatterns [namespace current]::>$ciphername + } + puts stdout "Created patterncipher cipherpattern objects: $created_cipherpatterns" + +} + + + + + + + + + diff --git a/src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm b/src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm new file mode 100644 index 00000000..8008673a --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm @@ -0,0 +1,639 @@ +package provide patterncmd [namespace eval patterncmd { + variable version + set version 0.1 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } +} + +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} + +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + error "PatternCompile ????" + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + +} \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.8.tm b/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.8.tm new file mode 100644 index 00000000..76ade79f --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.8.tm @@ -0,0 +1,639 @@ +package provide patterncmd [namespace eval patterncmd { + variable version + set version 1.2.8 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } +} + +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} + +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + error "PatternCompile ????" + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + +} \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/patternlib-1.2.8.tm b/src/vfs/_vfscommon.vfs/modules/patternlib-1.2.8.tm new file mode 100644 index 00000000..67a7cba9 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/patternlib-1.2.8.tm @@ -0,0 +1,2588 @@ +#JMN 2004 +#public domain + + +package provide patternlib [namespace eval patternlib { + variable version + set version 1.2.8 +}] + + + +#Change History +#------------------------------------------------------------------------------- +# 2022-05 +# added . search and . itemKeys methods to >collection to enable lookups by value +# 2021-09 +# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. +# +# 2006-05 +# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. +# +# 2005-04 +# remove 'name' method - incorporate indexed retrieval into 'names' method +# !todo? - adjust key/keys methods for consistency? +# +# 2004-10 +# initial key aliases support +# fix negative index support on some methods e.g remove +# 2004-08 +# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection +# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value +# +# 2004-06-05 +# added 'sort' method to sort on values. +# fixed 'keySort' method to accept multiple sort options +# added predicate methods 'all' 'allKeys' 'collectAll' +# 2004-06-01 +# '>collection . names' method now accepts optional 'glob' parameter to filter result +# 2004-05-19 +#fix '>collection . clear' method so consecutive calls don't raise an error +#------------------------------------------------------------------------------- + +namespace eval ::patternlib::util { + 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" + } + } + + #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter + # k-hashes + # m-bits + # n-elements + # optimal value of k: (m/n)ln(2) + #proc bloom_optimalNumHashes {capacity_n bitsize_m} { + # expr { round((double($bitsize_m) / $capacity_n) * log(2))} + #} + #proc bloom_optimalNumBits {capacity fpp} { + # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} + #} + +} +::patternlib::util::package_require_min pattern 1.2.4 +#package require pattern +::pattern::init ;# initialises (if not already) + + +namespace eval ::patternlib {namespace export {[a-z]*} + namespace export {[>]*} + + variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified + proc uniqueKey {} { + return [incr ::patternlib::keyCounter] + } + +#!todo - multidimensional collection +# - o_list as nested list +# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? +# - perhaps a key is always a list length n where n is the number of dimensions? +# - therefore we'll need an extra level of nesting for the current base case n=1 +# +# - how about a nested dict for each key-structure (o_list & o_array) ? + +#COLLECTION +# +#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names +# - consider array-style access using traced var named same as collection. +# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? +#!todo - add boolean property to force unique values as well as keys + + +#::pattern::create >collection + + + + +::>pattern .. Create >collection +set COL >collection +#process_pattern_aliases [namespace origin >collection] +#process_pattern_aliases ::patternlib::>collection +$COL .. Property version 1.0 +$COL .. PatternDefaultMethod item + +set PV [$COL .. PatternVariable .] + +$PV o_data +#$PV o_array +#$PV o_list +$PV o_alias +$PV this + +#for invert method +$PV o_dupes 0 + + +$COL .. PatternProperty bgEnum + + +#PV o_ns + +$PV m_i_filteredCollection + +#set ID [lindex [set >collection] 0 0] ;#context ID +#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID + +$COL .. Constructor {args} { + var o_data m_i_filteredCollection o_count o_bgEnum + + var this + set this @this@ + + set m_i_filteredCollection 0 + if {![llength $args]} { + set o_data [dict create] + #array set o_array [list] + #set o_list [list] + set o_count 0 + } elseif {[llength $args] == 1} { + set o_data [dict create] + set pairs [lindex $args 0] + if {[llength $pairs] % 2} { + error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" + } + set keys_seen [list] + foreach key [dict keys $pairs] { + if {[string is integer -strict $key] } { + error ">collection key must be non-integer. Bad key: $key. No items added." + } + if {$key in $keys_seen} { + error "key '$key' already exists in this collection. No items added." + } + lappend keys_seen $key + } + unset keys_seen + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $pairs] + set o_count [dict size $o_data] + } else { + error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." + } + array set o_alias [list] + + array set o_bgEnum [list] + @next@ +} +#comment block snipped from collection Constructor + #--------------------------------------------- + #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway + # + #### OBSOLETE - left as example of an approach + #make count property traceable (e.g so property ref can be bound to Tk widgets) + #!todo - manually update o_count in relevant methods faster?? + # should avoid trace calls for addList methods, shuffle etc + # + #set handler ::p::${_ID_}::___count_TraceHandler + #proc $handler {_ID_ vname vidx op} { + # #foreach {vname vidx op} [lrange $args end-2 end] {break} + # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name + # + # #this is only a 'write' handler + # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] + # return + #} + #trace add variable o_list {write} [list $handler $_ID_] + #### + # + # + #puts "--->collection constructor id: $_ID_" + + + + +set PM [$COL .. PatternMethod .] + + +#!review - why do we need the count method as well as the property? +#if needed - document why. +# read traces on count property can be bypassed by method call... shouldn't we avoid that? +# 2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. +# +$COL .. PatternMethod count {} { + #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. + #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. + var o_data + dict size $o_data +} + +$COL .. PatternProperty count +$COL .. PatternPropertyWrite count {_val} { + var + error "count property is read-only" +} + +$COL .. PatternPropertyUnset count {} { + var +} ;#cannot raise error's in unset trace handlers - simply fail to unset silently + +$COL .. PatternMethod isEmpty {} { + #var o_list + #return [expr {[llength $o_list] == 0}] + var o_data + expr {[dict size $o_data] == 0} +} + +$COL .. PatternProperty inverted 0 + + + +###### +# item +###### +#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? +# i.e [>obj . item] returns the 1st element in the list +#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) +#[>obj . item -2] returns 2nd last element (equiv to "end-1") + + +$COL .. PatternMethod item {{idx 0}} { + #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) + # (still at least 20 times slower than a plain array... at <5us) + var o_data o_alias + + #!todo - review 'string is digit' vs 'string is integer' ?? + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set keys [dict keys $o_data] + if {[catch {dict get $o_data [lindex $keys $idx]} result]} { + var this + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {dict get $o_data $idx} result]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + var this + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + #tailcall? + #item $_ID_ $nextIdx + #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" + tailcall item $_ID_ $nextIdx + } + } else { + return $result + } + } +} + + + +if {0} { +#leave this here for comparison. +$COL .. PatternMethod item2 {{idx 0}} { + var o_array o_list o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + item $_ID_ $nextIdx + } + } else { + return $result + } + } + +} +} + +#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) +$COL .. PatternMethod itemNamed {idx} { + var o_data + dict get $o_data $idx +} +$COL .. PatternMethod in {idx} { + var o_data + dict get $o_data $idx +} + +$COL .. PatternMethod itemAt {idx} { + var o_data + dict get $o_data [lindex [dict keys $o_data] $idx] +} + +$COL .. PatternMethod replace {idx val} { + var o_data o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { + error "no such index: '$idx' in collection: $this" + } else { + return $val + } + } else { + if {[catch {dict set o_data $idx $val}]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + tailcall replace $_ID_ $nextIdx $val + } + + } else { + return $val + } + } +} + +#if the supplied index is an alias, return the underlying key; else return the index supplied. +$COL .. PatternMethod realKey {idx} { + var o_alias + + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } +} + +#note alias feature is possibly ill-considered. +#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. +$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { + var o_alias + + #set existingKey [realKey $_ID_ $existingKeyOrAlias] + #alias to the supplied KeyOrAlias - not the underlying key + + if {[string is integer -strict $newAlias]} { + error "collection key alias cannot be integer" + } + + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } +} +$COL .. PatternMethod aliases {{key ""}} { + var o_alias + + if {[string length $key]} { + set result [list] + #lsearch -stride? + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + + return $result + } else { + return [array get o_alias] + } +} + +#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied + +#default to removing item from the end, otherwise from supplied index (position or key) +#!todo - accept alias indices +#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) +#!todo - review.. for performance.. shouldn't pop NOT accept an index? +#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? +$COL .. PatternMethod pop {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} +$COL .. PatternMethod poppair {} { + var o_data o_count + set key [lindex [dict keys $o_data] end] + set val [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return [list $key $val] +} + + + +#!todo - add 'push' method... (basically specialized versions of 'add') +#push - add at end (effectively an alias for add) +#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. +#add - add at end + +#ordered +$COL .. PatternMethod items {} { + var o_data + + dict values $o_data +} + + + + +#### +#pair +#### +#fifo-style accesss when no idx supplied (likewise with 'add' method) +$COL .. PatternMethod pair {{idx 0}} { + var o_data + + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + + if {[catch {dict get $o_data $key} val]} { + error "no such index: '$idx'" + } else { + return [list $key $val] + } +} +$COL .. PatternMethod pairs {} { + var o_data + set o_data +} + +$COL .. PatternMethod get {} { + var o_data + set o_data +} +#todo - fix >pattern so that methods don't collide with builtins +#may require change to use oo - or copy 'my' mechanism to call own methods +$COL .. PatternMethod Info {} { + var o_data + return [dict info $o_data] +} +#2006-05-21.. args to add really should be in key, value order? +# - this the natural order in array-like lists +# - however.. key should be optional. + +$COL .. PatternMethod add {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? +#what then of methods like 'count' which apply equally well to collections and stacks? + +#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? +$COL .. PatternMethod push {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#shift/unshift - roughly analogous to those found in Perl & PHP +#unshift adds 1 or more values to the beginning of the collection. +$COL .. PatternMethod unshift {values {keys ""}} { + var o_data o_count + + if {![llength $keys]} { + for {set i 0} {$i < [llength $values]} {incr i} { + lappend keys "_[::patternlib::uniqueKey]_" + } + } else { + #check keys before we insert any of them. + foreach newkey $keys { + if {[string is integer -strict $newkey]} { + error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + } + if {[llength $values] != [llength $keys]} { + error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" + } + + #separate loop through keys because we want to fail the whole operation if any are invalid. + + set existing_keys [dict keys $o_data] + foreach newkey $keys { + if {$newkey in $exisint_keys} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$newkey' already exists in this collection" + } + } + + + #ok - looks like entire set can be inserted. + set newpairs [list] + foreach val $values key $keys { + lappend newpairs $key $val + } + set o_data [concat $newpairs $o_data[set o_data {}]] + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#default to removing item from the beginning, otherwise from supplied index (position or key) +#!todo - accept alias indices +$COL .. PatternMethod shift {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] 0] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} + + +$COL .. PatternMethod peek {} { + var o_data + + #set o_array([lindex $o_list end]) + + #dict get $o_data [lindex [dict keys $o_data] end] + lindex $o_data end +} + +$COL .. PatternMethod peekKey {} { + var o_data + #lindex $o_list end + lindex $o_data end-1 +} + + +$COL .. PatternMethod insert {val args} { + var o_data o_count + + set idx 0 + set key "" + + if {[llength $args] <= 2} { + #standard arg (ordered) style: + #>obj . insert $value $position $key + + lassign $args idx key + } else { + #allow for literate programming style: + #e.g + # >obj . insert $value at $listPosition as $key + + if {[catch {array set iargs $args}]} { + error "insert did not understand argument list. +usage: +>obj . insert \$val \$position \$key +>obj . insert \$val at \$position as \$key" + } + if {[info exists iargs(at)]} { + set idx $iargs(at) + } + if {[info exists iargs(as)]} { + set key $iargs(as) + } + } + + if {![string length $key]} { + set key "_[::patternlib::uniqueKey]_" + } + + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + + + if {[dict exists $o_data $key]} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$key' already exists in this collection" + } + + if {$idx eq "end"} { + #lappend o_list $key + #standard dict set will add it to the end anyway + dict set o_data $key $val + + } else { + #set o_list [linsert $o_list $idx $key] + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] + } + + + #set o_array($key) $val + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#!todo - deprecate and give it a better name! addDict addPairs ? +$COL .. PatternMethod addArray {list} { + var + puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" + tailcall addPairs $_ID_ $list +} +$COL .. PatternMethod addPairs {list} { + var o_data o_alias o_count + if {[llength $list] % 2} { + error "must supply an even number of elements" + } + + set aliaslist [array names o_alias] + #set keylist [dict keys $o_data] + foreach newkey [dict keys $list] { + if {[string is integer -strict $newkey] } { + error ">collection key must be non-integer. Bad key: $newkey. No items added." + } + + #if {$newkey in $keylist} {} + #for small to medium collections - testing for newkey in $keylist is probably faster, + # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. + if {[dict exists $o_data $newkey]} { + error "key '$newkey' already exists in this collection. No items added." + } + #The assumption is that there are in general relatively few aliases - so a list test is appropriate + if {$newkey in $aliaslist} { + if {[dict exists $o_data $o_alias($newkey)]} { + error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " + } + } + #! check if $list contains dups? + #- slows method down - for little benefit? + } + #!todo - test? (but we need a loop to test for integer keys.. so what's the point?) + #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] + #if {[llength $intersection]} { + # error "keys '$intersection' already present in this collection. No items added." + #} + + + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $list] + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} +$COL .. PatternMethod addList {list} { + var o_data o_count + + foreach val $list { + dict set o_data "_[::patternlib::uniqueKey]_" $val + #!todo - test. Presumably lappend faster because we don't need to check existing keys.. + #..but.. is there shimmering involved in treating o_data as a list? + #lappend o_data _[::patternlib::uniqueKey]_ $val + + #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] + } + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#'del' is not a very good name... as we're not really 'deleting' anything. +# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. +#!todo - handle 'endRange' parameter for removing ranges of items. +$COL .. PatternMethod del {idx {endRange ""}} { + var + #!todo - emit a deprecation warning for 'del' + tailcall remove $_ID_ $idx $endRange +} + +$COL .. PatternMethod remove {idx {endRange ""}} { + var o_data o_count o_alias this + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#ordered +$COL .. PatternMethod names {{globOrIdx {}}} { + var o_data + + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + #Idx + set idx $globOrIdx + + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + + + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "no such index : '$idx'" + } else { + return $result + } + + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } +} + +#ordered +$COL .. PatternMethod keys {} { + #like 'names' but without globbing + var o_data + dict keys $o_data +} + +#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects +# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? +# - some sort of resolution order/interface-selection is clearly required anyway +# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. +# In the mean time however... we'll at least avoid 'name'! +# +#$PM name {{posn 0}} { +# var o_array o_list +# +# if {$posn < 0} { +# set posn "end-[expr {abs($posn + 1)}]" +# } +# +# if {[catch {lindex $o_list $posn} result]} { +# error "no such index : '$posn'" +# } else { +# return $result +# } +#} + +$COL .. PatternMethod key {{posn 0}} { + var o_data + + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "no such index : '$posn'" + } else { + return $result + } +} + + +#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. +$COL .. PatternMethod setPosn {idx to} { + var o_data + + if {![string is integer -strict $to]} { + error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" + } + + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set to [expr {$to % [dict size $o_data]}] + + + set val [dict get $o_data $key] + dict unset o_data $key + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] + + #set o_list [lreplace $o_list $posn $posn] + #set o_list [linsert $o_list $to $key] + + return $to +} +#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? +#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. +$COL .. PatternMethod incrPosn {idx {by 1}} { + var o_data + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set newPosn [expr {($posn + $by) % [dict size $o_data]}] + + setPosn $_ID_ $posn $newPosn + return $newPosn +} +$COL .. PatternMethod decrPosn {idx {by 1}} { + var + return [incrPosn $_ID_ $idx [expr {- $by}]] +} +$COL .. PatternMethod move {idx to} { + var + return [setPosn $_ID_ $idx $to] +} +$COL .. PatternMethod posn {key} { + var o_data + return [lsearch -exact [dict keys $o_data] $key] +} + +#!todo? - disallow numeric values for newKey so as to be consistent with add +#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything +# - this is ok. +$COL .. PatternMethod reKey {idx newKey} { + var o_data o_alias + + + if {[dict exists $o_data $newKey]} { + #puts stderr "==============> reKey collision, key $newKey already exists in this collection" + error "reKey collision, key '$newKey' already exists in this collection" + } + if {[info exists o_alias($newKey)]} { + if {[dict exists $o_data $o_alias($newKey)]} { + error "reKey collision, key '$newKey' already present as an alias in this collection" + } else { + set newKey $o_alias($newKey) + } + } + + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx'" + } else { + #try with next key in alias chain... + #return [reKey $_ID_ $nextKey $newKey] + tailcall reKey $_ID_ $nextKey $newKey + } + } + } + + #set o_list [lreplace $o_list $posn $posn $newKey] + ##atomic? (traces on array?) + #set o_array($newKey) $o_array($key) + #unset o_array($key) + + dict set o_data $newKey [dict get $o_data $key] + dict unset o_data $key + + return +} +$COL .. PatternMethod hasKey {key} { + var o_data + dict exists $o_data $key +} +$COL .. PatternMethod hasAlias {key} { + var o_alias + info exists o_alias($key) +} + +#either key or alias +$COL .. PatternMethod hasIndex {key} { + var o_data o_alias + if {[dict exists $o_data $key]} { + return 1 + } else { + return [info exists o_alias($key)] + } +} + + +#Shuffle methods from http://mini.net/tcl/941 +$COL .. PatternMethod shuffleFast {} { + #shuffle6 - fast, but some orders more likely than others. + + var o_data + + set keys [dict keys $o_data] + + set n [llength $keys] + for { set i 1 } { $i < $n } { incr i } { + set j [expr { int( rand() * $n ) }] + set temp [lindex $keys $i] + lset keys $i [lindex $keys $j] + lset keys $j $temp + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} +$COL .. PatternMethod shuffle {} { + #shuffle5a + + var o_data + + set n 1 + set keys [list] ;#sorted list of keys + foreach k [dict keys $o_data] { + #set index [expr {int(rand()*$n)}] + + #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] + + #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] + set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] + incr n + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} + + +#search is a somewhat specialised form of 'itemKeys' +$COL .. PatternMethod search {value args} { + var o_data + #only search on values as it's possible for keys to match - especially with options such as -glob + set matches [lsearch {*}$args [dict values $o_data] $value] + + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } +} + +#inverse lookup +$COL .. PatternMethod itemKeys {value} { + var o_data + #only search on values as it's possible for keys to match + set value_indices [lsearch -all [dict values $o_data] $value] + + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist +} + +#invert: +#change collection to be indexed by its values with the old keys as new values. +# - keys of duplicate values become a list keyed on the value. +#e.g the array equivalent is: +# arr(a) 1 +# arr(b) 2 +# arr(c) 2 +#becomes +# inv(1) a +# inv(2) {b c} +#where the order of duplicate-value keys is not defined. +# +#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. +# + + +#!todo - try just [lreverse $o_data] ?? + + +$COL .. PatternMethod invert {{splitvalues ""}} { + + var o_data o_count o_dupes o_inverted + + + if {$splitvalues eq ""} { + #not overridden - use o_dupes from last call to determine if values are actually keylists. + if {$o_dupes > 0} { + set splitvalues 1 + } else { + set splitvalues 0 + } + } + + + #set data [array get o_array] + set data $o_data + + if {$o_count > 500} { + #an arbitrary optimisation for 'larger' collections. + #- should theoretically keep the data size and save some reallocations. + #!todo - test & review + # + foreach nm [dict keys $o_data] { + dict unset o_data $nm + } + } else { + set o_data [dict create] + } + + if {!$splitvalues} { + dict for {k v} $data { + dict set o_data $v $k + } + } else { + dict for {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + dict set o_data $sub $k + #} + } + } + } + + + if {[dict size $o_data] != $o_count} { + #must have been some dupes + + set o_dupes [expr {$o_count - [dict size $o_data]}] + #update count to match inverted collection + set o_count [dict size $o_data] + } else { + set o_dupes 0 + } + + set o_inverted [expr {!$o_inverted}] + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $o_dupes +} + + + + + + +#NOTE: values are treated as lists and split into separate keys for inversion only if requested! +# To treat values as keylists - set splitvalues 1 +# To treat each value atomically - set splitvalues 0 +# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! +# +# +#Initially call invert with splitvalues = 0 +#To keep calling invert and get back where you started.. +# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. +# +$COL .. PatternMethod invert_manual {{splitvalues 0}} { + #NOTE - the list nesting here is *tricky* - It probably isn't broken. + + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + lappend o_array($v) $k + } + } else { + foreach {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + set o_array($sub) $k + #} + } + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + if {$splitvalues} { + #values are lists of length one. Take lindex 0 so list values aren't overnested. + foreach oldkey $o_list { + lset o_list [incr i] [lindex $prev($oldkey) 0] + } + } else { + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + } + + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + + + +#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys +# (keys that are lists) +$COL .. PatternMethod invert_lossy {{splitvalues 1}} { + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + #note! we must check for existence and use 'set' for first case. + #using 'lappend' only will result in deeper nestings on each invert! + #If you don't understand this - don't change it! + if {[info exists o_array($v)]} { + lappend o_array($v) $k + } else { + set o_array($v) $k + } + } + } else { + foreach {k v} $data { + #length test necessary to avoid incorrect 'un-nesting' + #if {[llength $v] > 1} { + foreach sub $v { + if {[info exists o_array($sub)]} { + lappend o_array($sub) $k + } else { + set o_array($sub) $k + } + } + #} else { + # if {[info exists o_array($v)]} { + # lappend o_array($v) $k + # } else { + # set o_array($v) $k + # } + #} + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + +$COL .. PatternMethod reverse {} { + var o_data + + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return +} + +$COL .. PatternMethod keySort {{options -ascii}} { + var o_data + + set keys [lsort {*}$options [dict keys $o_data]] + + set dictnew [dict create] + foreach k $keys { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + + return +} + +#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. +$COL .. PatternMethod sort {args} { + var o_data + + #defaults + set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. + + set options_simple [list] + + + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + switch -- $a { + -indices - + -ascii - + -dictionary - + -integer - + -real - + -increasing - + -decreasing { + #dict set options $a 1 + lappend options_simple $a + } + -unique { + #not a valid option + #this would stuff up the data... + #!todo? - remove dups from collection if this option used? - alias the keys? + } + -object { + #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing + #may be slow - but handy. Consider -indexed property to store/cache these values on first run + } + -command { + dict set options $a [lindex $args [incr i]] + } + -index { + #allow sorting on subindices of the value. + dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] + } + default { + #unrecognised option - print usage? + } + } + } + + + + if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { + + var o_array + + set slist [list] + foreach k [dict keys $o_data] { + lappend slist [list $k [dict get $o_data $k]] + } + return [lsort {*}$options_simple {*}$options $slist] + + + + #set options_simple [lreplace $options_simple $posn $posn] ;# + #set slist [list] + #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { + # lappend slist [list $n $v] + #} + #set slist [lsort {*}$options_simple {*}$options $slist] + #foreach i $slist { + # #determine the position in the collections list + # lappend result {*}[lsearch -exact $o_list [lindex $i 0]] + #} + #return $result + } else { + set slist [list] + dict for {k v} $o_data { + lappend slist [list $k $v] + } + #set slist [lsort {*}$options_simple {*}$options $slist] + set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency + + + #set o_list [lsearch -all -inline -subindices -index 0 $slist *] + + set o_data [dict create] + foreach pair $slist { + dict set o_data [lindex $pair 0] [lindex $pair 1] + } + + + + return + } + +} + + +$COL .. PatternMethod clear {} { + var o_data o_count + + set o_data [dict create] + set o_count 0 + #aliases? + return +} + +#see http://wiki.tcl.tk/15271 - A generic collection traversal interface +# +#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) +#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? +# - should this be an option? which mechanism should be the default? +# - currently only the keylist is treated in 'snapshot' fashion +# so values could be changed and the state could be invalidated by other code during an enumeration +# +$COL .. PatternMethod enumerate {args} { + #---------- + lassign [lrange $args end-1 end] cmd seed + set optionlist [list] + foreach a [lrange $args 0 end-2] { + lappend optionlist $a + } + set opt(-direction) left + set opt(-completioncommand) "" + array set opt $optionlist + #---------- + var o_data + + if {[string tolower [string index $opt(-direction) 0]] eq "r"} { + #'right' 'RIGHT' 'r' etc. + set list [lreverse [dict keys $o_data]] + } else { + #normal left-right order + set list [dict keys $o_data] + } + + if {![string length $opt(-completioncommand)]} { + #standard synchronous processing + foreach k $list { + set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] + } + return $seed + } else { + #ASYNCHRONOUS enumeration + var this o_bgEnum + #!todo - make id unique + #!todo - facility to abort running enumeration. + set enumID enum[array size o_bgEnum] + + set seedvar [$this . bgEnum $enumID .] + set $seedvar $seed + + after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] + return $enumID + } +} + +#!todo - make private? - put on a separate interface? +$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { + var this o_data + + + #Note that we don't post to the eventqueue using 'foreach s $slice' + # we only schedule another event after each item is processed + # - otherwise we would be spamming the eventqueue with items. + + #!todo? - accept a -granularity option to allow handling of n list-items per event? + + if {[llength $slice]} { + set slice [lassign $slice head] + + set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { + %cmd% [set %seedvar%] %val% + }] + + #post to eventqueue and re-enter _doBackgroundEnum + # + after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] + + } else { + #done. + + set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { + lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 + }] + + after idle [list after 0 [list uplevel #0 $script]] + } + + return +} + +$COL .. PatternMethod enumeratorstate {} { + var o_bgEnum + parray o_bgEnum +} + +#proc ::bgerror {args} { +# puts stderr "=bgerror===>$args" +#} + + +#map could be done in terms of the generic 'enumerate' method.. but it's slower. +# +#$PM map2 {proc} { +# var +# enumerate $_ID_ [list ::map-helper $proc] [list] +#} +#proc ::map-helper {proc accum item} { +# lappend accum [uplevel #0 [list {*}$proc $item]] +#} + +$COL .. PatternMethod map {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + + return $seed +} +$COL .. PatternMethod objectmap {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + + return $seed +} + + +#End core collection functionality. +#collection 'mixin' interfaces + +>pattern .. Create >keyvalprotector +>keyvalprotector .. PatternVariable o_protectedkeys +>keyvalprotector .. PatternVariable o_protectedvals + +#!todo - write test regarding errors in Constructors for mixins like this +# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args +>keyvalprotector .. Constructor {args} { + var this o_protectedkeys o_protectedvals + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -keys -vals ] + dict set default -keys [list] + dict set default -vals [list] + if {([llength $args] % 2) != 0} { + error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_protectedkeys [dict get $opts -keys] + set o_protectedvals [dict get $opts -vals] + #---------------------------------------------------------------------------- + set protections [concat $o_protectedkeys $o_protectedvals] + if {![llength $protections]} { + error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" + } + +} +>keyvalprotector .. PatternMethod clear {} { + error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" +} +>keyvalprotector .. PatternMethod pop {{idx ""}} { + var o_data o_count o_protectedkeys o_protectedvals + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." + } + set posn [lsearch -exact [dict keys $o_data] $key] + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + if {$result in $o_protectedvals} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." + } + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } + +} +>keyvalprotector .. PatternMethod remove {idx {endRange ""}} { + var this o_data o_count o_alias o_protectedkeys o_protectedvals + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" + } + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" + } + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#1) +#predicate methods (order preserving) +#usage: +# >collection .. Create >c1 +# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection + +#e.g >col1 . all {$val > 14} +#e.g >col1 . filterToCollection {$val > 19} . count +#e.g >col1 . filter {[string match "x*" $key]} +#!todo - fix. currying fails.. + +::>pattern .. Create >predicatedCollection +#process_pattern_aliases ::patternlib::>predicatedCollection + +set PM [>predicatedCollection .. PatternMethod .] + +>predicatedCollection .. PatternMethod filter {predicate} { + var this o_list o_array + set result [list] + + #!note (jmn 2004) how could we do smart filtering based on $posn? + #i.e it would make sense to lrange $o_list based on $posn... + #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? + #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. + #given this, is $posn even useful? + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToKeys {predicate} { + var this o_list o_array + set result [list] + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $key + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { + #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? + #!todo - implement as 'view' on current collection object.. extra o_list variables? + #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? + var this o_list o_array m_i_filteredCollection + + incr m_i_filteredCollection + if {![string length $destCollection]} { + #!todo? - implement 'one-shot' object (similar to RaTcl) + set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] + } else { + set result $destCollection + } + + #### + #externally manipulate new collection + #set ADD [$c . add .] + #foreach key $o_list { + # set val $o_array($key) + # if $predicate { + # $ADD $val $key + # } + #} + ### + + #internal manipulation faster + #set cID [lindex [set $result] 0] + set cID [lindex [$result --] 0] + + #use list to get keys so as to preserve order + set posn 0 + upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST + foreach key $o_list { + set val $o_array($key) + if $predicate { + if {[info exists cARRAY($key)]} { + error "key '$key' already exists in this collection" + } + lappend cLIST $key + set cARRAY($key) $val + } + incr posn + } + + return $result +} + +#NOTE! unbraced expr/if statements. We want to evaluate the predicate. +>predicatedCollection .. PatternMethod any {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + return 1 + } + incr posn + } + return 0 +} +>predicatedCollection .. PatternMethod all {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if !($predicate) { + return 0 + } + incr posn + } + return 1 +} +>predicatedCollection .. PatternMethod dropWhile {predicate} { + var this o_list o_array + set result [list] + set _idx 0 + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + incr _idx + } else { + break + } + incr posn + } + set remaining [lrange $o_list $_idx end] + foreach key $remaining { + set val $o_array($key) + lappend result $val + } + return $result +} +>predicatedCollection .. PatternMethod takeWhile {predicate} { + var this o_list o_array + set result [list] + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } else { + break + } + incr posn + } + set result +} + + + +#end >collection mixins +###################################### + + + + +#----------------------------------------------------------- +#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? +# Why do we need both? apart from the size variable, what is the use of hashMap? +#----------------------------------------------------------- +#::pattern::create >hashMap +::>pattern .. Create >hashMap + +>hashMap .. PatternVariable o_size +>hashMap .. PatternVariable o_array + +>hashMap .. Constructor {args} { + var o_array o_size + array set o_array [list] + set o_size 0 +} +>hashMap .. PatternDefaultMethod "item" +>hashMap .. PatternMethod item {key} { + var o_array + set o_array($key) +} +>hashMap .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>hashMap .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>hashMap .. PatternMethod add {val key} { + var o_array o_size + + set o_array($key) $val + incr o_size + return $key +} + +>hashMap .. PatternMethod del {key} { + var + puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>hashMap .. PatternMethod remove {key} { + var o_array o_size + unset o_array($key) + incr o_size -1 + return $key +} +>hashMap .. PatternMethod count {} { + var o_size + #array size o_array + return $o_size +} +>hashMap .. PatternMethod count2 {} { + var o_array + #array size o_array ;#slow, at least for TCLv8.4.4 + #even array statistics is faster than array size ! + #e.g return [lindex [array statistics o_array] 0] + #but.. apparently there are circumstances where array statistics doesn't report the correct size. + return [array size o_array] +} +>hashMap .. PatternMethod names {} { + var o_array + array names o_array +} +>hashMap .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>hashMap .. PatternMethod hasKey {key} { + var o_array + return [info exists o_array($key)] +} +>hashMap .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +#>hashMap .. Ready 1 + + + + + + + + + + + + + + + +#explicitly create metadata. Not required for user-defined patterns. +# this is only done here because this object is used for the metadata of all objects +# so the object must have all it's methods/props before its own metadata structure can be built. +#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" +#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" + + + + +if 0 { + + +#----------------------------------------------------------- +#::pattern::create >arrayHandle { +# variable o_arrayName +# variable this +#} +::>pattern .. Create >arrayHandle + +>arrayHandle .. PatternVariable o_arrayName +>arrayHandle .. PatternVariable this + +>arrayHandle .. Constructor {args} { + var o_arrayName this + set this @this@ + + + set o_arrayName [$this .. Namespace]::array + + upvar #0 $o_arrayName $this + #? how to automatically update this after a namespace import? + + array set $o_arrayName [list] + +} +>arrayHandle .. PatternMethod array {} { + var o_arrayName + return $o_arrayName +} + +#------------------------------------------------------- +#---- some experiments +>arrayHandle .. PatternMethod up {varname} { + var o_arrayName + + #is it dodgy to hard-code the calling depth? + #will it be different for different object systems? + #Will it even be consistent for the same object. + # Is this method necessary anyway? - + # - users can always instead do: + # upvar #0 [>instance . array] var + + uplevel 3 [list upvar 0 $o_arrayName $varname] + + return +} +>arrayHandle .. PatternMethod global {varname} { + var o_arrayName + # upvar #0 [>instance . array] var + + if {![string match ::* $varname]} { + set varname ::$varname + } + + upvar #0 $o_arrayName $varname + + return +} +>arrayHandle .. PatternMethod depth {} { + var o_arrayName + # + for {set i 0} {$i < [info level]} { + puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" + } + +} + # -------------------------------------------- + + +>arrayHandle .. PatternMethod item {key} { + var o_arrayName + set ${o_arrayName}($key) +} +>arrayHandle .. PatternMethod items {} { + var o_arrayName + + set result [list] + foreach nm [array names $o_arrayName] { + lappend result [set ${o_arrayName}($nm)] + } + return $result +} +>arrayHandle .. PatternMethod pairs {} { + var o_arrayName + + array get $o_arrayName +} +>arrayHandle .. PatternMethod add {val key} { + var o_arrayName + + set ${o_arrayName}($key) $val + return $key +} +>arrayHandle .. PatternMethod del {key} { + puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>arrayHandle .. PatternMethod remove {key} { + var o_arrayName + unset ${o_arrayName}($key) + return $key +} +>arrayHandle .. PatternMethod size {} { + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod count {} { + #alias for size + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod statistics {} { + var o_arrayName + return [array statistics $o_arrayName] +} +>arrayHandle .. PatternMethod names {} { + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod keys {} { + #synonym for names + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod hasKey {key} { + var o_arrayName + + return [info exists ${o_arrayName}($key)] +} +>arrayHandle .. PatternMethod clear {} { + var o_arrayName + unset $o_arrayName + array set $o_arrayName [list] + + return +} +#>arrayHandle .. Ready 1 + + + + +::>pattern .. Create >matrix + +>matrix .. PatternVariable o_array +>matrix .. PatternVariable o_size + +>matrix .. Constructor {args} { + var o_array o_size + + array set o_array [list] + set o_size 0 +} + + +#process_pattern_aliases ::patternlib::>matrix + +set PM [>matrix .. PatternMethod .] + +>matrix .. PatternMethod item {args} { + var o_array + + if {![llength $args]} { + error "indices required" + } else { + + } + if [info exists o_array($args)] { + return $o_array($args) + } else { + error "no such index: '$args'" + } +} +>matrix .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>matrix .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>matrix .. PatternMethod slice {args} { + var o_array + + if {"*" ni $args} { + lappend args * + } + + array get o_array $args +} +>matrix .. PatternMethod add {val args} { + var o_array o_size + + if {![llength $args]} { + error "indices required" + } + + set o_array($args) $val + incr o_size + + #return [array size o_array] + return $o_size +} +>matrix .. PatternMethod names {} { + var o_array + array names o_array +} +>matrix .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>matrix .. PatternMethod hasKey {args} { + var o_array + + return [info exists o_array($args)] +} +>matrix .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +>matrix .. PatternMethod count {} { + var o_size + return $o_size +} +>matrix .. PatternMethod count2 {} { + var o_array + #see comments for >hashMap count2 + return [array size o_array] +} +#>matrix .. Ready 1 + +#-------------------------------------------------------- +#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) +#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html +#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. +::>pattern .. Create >tree + +set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] +set _TREE_NODE $_NODE +#process_pattern_aliases $_TREE_NODE + +$_NODE .. PatternVariable o_treens ;#tree namespace +$_NODE .. PatternVariable o_idref +$_NODE .. PatternVariable o_nodePrototype + +#$_NODE .. PatternProperty data +$_NODE .. PatternProperty info + +$_NODE .. PatternProperty tree +$_NODE .. PatternProperty parent +$_NODE .. PatternProperty children +$_NODE .. PatternMethod addNode {} { + set nd_id [incr $o_idref] + set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] + @this@ . add $nd n-$nd_id + + return n-$nd_id +} +#flat list of all nodes below this +#!todo - something else? ad-hoc collections? +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod nodes {} { + set result [list] + + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + #eval lappend result $n [$o_array($n) . nodes] + #!todo - test + lappend result $n {*}[$o_array($n) . nodes] + } + return $result +} +#count of number of descendants +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod size {} { + set result 0 + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + incr result [expr {1 + [$o_array($n) . size]}] + } + return $result +} +$_NODE .. PatternMethod isLeaf {} { + #!todo - way to stop unused vars being uplevelled? + var o_tree + + #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? + tailcall [@this@ . isEmpty .] +} +$_NODE .. Constructor {args} { + array set A $args + + set o_tree $A(-tree) + set o_parent $A(-parent) + + #array set o_data [list] + array set o_info [list] + + set o_nodePrototype [::patternlib::>tree .. Namespace]::>node + set o_idref [$o_tree . nodeID .] + set o_treens [$o_tree .. Namespace] + #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] + + #overlay children collection directly on the node + set o_children [::patternlib::>collection .. Create @this@] + + return +} + +>tree .. PatternProperty test blah +>tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? +>tree .. PatternVariable o_ns +>tree .. Constructor {args} { + set o_ns [@this@ .. Namespace] + + #>tree is itself also a node (root node) + #overlay new 'root' node onto existing tree, pass tree to constructor + [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" +} + + + + +unset _NODE + + + + +#-------------------------------------------------------- +#a basic binary search tree experiment +# - todo - 'scheme' property to change behaviour? e.g balanced tree +::>pattern .. Create >bst +#process_pattern_aliases ::patternlib::>bst +>bst .. PatternVariable o_NS ;#namespace +>bst .. PatternVariable o_this ;#namespace +>bst .. PatternVariable o_nodeID + +>bst .. PatternProperty root "" +>bst .. Constructor {args} { + set o_this @this@ + set o_NS [$o_this .. Namespace] + namespace eval ${o_NS}::nodes {} + puts stdout ">bst constructor" + set o_nodeID 0 +} +>bst .. PatternMethod insert {key args} { + set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] + set [$newnode . key .] $key + if {[llength $args]} { + set [$newnode . value .] $args + } + if {![string length $o_root]} { + set o_root $newnode + set [$newnode . parent .] $o_this + } else { + set ipoint {} ;#insertion point + set tpoint $o_root ;#test point + set side {} + while {[string length $tpoint]} { + set ipoint $tpoint + if {[$newnode . key] < [$tpoint . key]} { + set tpoint [$tpoint . left] + set side left + } else { + set tpoint [$tpoint . right] + set side right + } + } + set [$newnode . parent .] $ipoint + set [$ipoint . $side .] $newnode + } + return $newnode +} +>bst .. PatternMethod item {key} { + if {![string length $o_root]} { + error "item $key not found" + } else { + set tpoint $o_root + while {[string length $tpoint]} { + if {[$tpoint . key] eq $key} { + return $tpoint + } else { + if {$key < [$tpoint . key]} { + set tpoint [$tpoint . left] + } else { + set tpoint [$tpoint . right] + } + } + } + error "item $key not found" + } +} +>bst .. PatternMethod inorder-walk {} { + if {[string length $o_root]} { + $o_root . inorder-walk + } + puts {} +} +>bst .. PatternMethod view {} { + array set result [list] + + if {[string length $o_root]} { + array set result [$o_root . view 0 [list]] + } + + foreach depth [lsort [array names result]] { + puts "$depth: $result($depth)" + } + +} +::>pattern .. Create >bstnode +#process_pattern_aliases ::patternlib::>bstnode +>bstnode .. PatternProperty parent +>bstnode .. PatternProperty left "" +>bstnode .. PatternProperty right "" +>bstnode .. PatternProperty key +>bstnode .. PatternProperty value + +>bstnode .. PatternMethod inorder-walk {} { + if {[string length $o_left]} { + $o_left . inorder-walk + } + + puts -nonewline "$o_key " + + if {[string length $o_right]} { + $o_right . inorder-walk + } + + return +} +>bstnode .. PatternMethod view {depth state} { + #!todo - show more useful representation of structure + set lower [incr depth] + + if {[string length $o_left]} { + set state [$o_left . view $lower $state] + } + + if {[string length $o_right]} { + set state [$o_right . view $lower $state] + } + + + array set s $state + lappend s($depth) $o_key + + return [array get s] +} + + +#-------------------------------------------------------- +#::pattern::create ::pattern::>metaObject +#::pattern::>metaObject PatternProperty methods +#::pattern::>metaObject PatternProperty properties +#::pattern::>metaObject PatternProperty PatternMethods +#::pattern::>metaObject PatternProperty patternProperties +#::pattern::>metaObject Constructor args { +# set this @this@ +# +# set [$this . methods .] [::>collection create [$this namespace]::methods] +# set [$this . properties .] [::>collection create [$this namespace]::properties] +# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] +# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] +# +#} + + + + #tidy up + unset PV + unset PM + + + +#-------------------------------------------------------- +::>pattern .. Create >enum +#process_pattern_aliases ::patternlib::>enum +>enum .. PatternMethod item {{idx 0}} { + var o_array o_list + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx'" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + error "no such index: '$idx'" + } else { + return $result + } + } +} + + + +#proc makeenum {type identifiers} { +# #!!todo - make generated procs import into whatever current system context? +# +# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 +# +# #obliterate any previous enum for this type +# catch {unset a1} +# catch {unset a2} +# +# set n 0 +# foreach id $identifiers { +# set a1($id) $n +# set a2($n) $id +# incr n +# } +# proc ::${type}_to_number key [string map [list @type@ $type] { +# upvar #0 wbpbenum_@type@_number ary +# if {[catch {set ary($key)} num]} { +# return -code error "unknown @type@ '$key'" +# } +# return $num +# }] +# +# proc ::number_to_${type} {number} [string map [list @type@ $type] { +# upvar #0 wbpbenum_number_@type@ ary +# if {[catch {set ary($number)} @type@]} { +# return -code error "no @type@ for '$number'" +# } +# return $@type@ +# }] +# +# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" +# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" +#} +# +#-------------------------------------------------------- +::>pattern .. Create >nest +>nest .. PatternVariable THIS +>nest .. PatternProperty data -autoclone +>nest .. Constructor {args} { + var o_data + var THIS + set THIS @this@ + array set o_data [list] +} +>nest .. PatternMethod item {args} { + set THIS @this@ + return [$THIS . data [join $args ,]] +} + +# +# e.g +# set [>nest a , b . data c .] blah +# >nest a , b , c +# +# set [>nest w x , y . data z .] etc +# >nest w x , y , z +#-------------------------------------------------------- + +} + +} + + +#package require patternlibtemp diff --git a/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.8.tm b/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.8.tm new file mode 100644 index 00000000..dd4f84c9 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.8.tm @@ -0,0 +1,755 @@ + +proc ::p::internals::jaws {OID _ID_ args} { + #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" + #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) + #upvar #0 ::p::${OID}::_meta::map MAP + set MAP [set ::p::${OID}::_meta::map] + } else { + # error "jaws - OID = 'null' ???" + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key + } + set invocantdata [dict get $MAP invocantdata] + lassign $invocantdata OID alias default_method object_command wrapped + + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + if {$word in $terminals} { + set reduction [list 0 $_ID_ {*}$stack ] + #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" + + + set _ID_ [yield $reduction] + set stack [list] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _ID_ instead of MAP + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command + #lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + set command ::p::${OID}::$nextword + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command ;#taken from the MAP + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set command ::p::-1::$nextword + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + set stack [list $command] ;#faster, and intent is clearer than lappend. + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + set stack [list $command] + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set command $object_command + set stack [list "_exec_" $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack [list $command] + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + + } + } ;#end while + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + + + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] + yieldto return [::p::internals::ref_to_object $_ID_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _ID_ changed in this proc - we have updated the $OID variable + yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] + error "assert: never gets here" + } + set operator . + + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" + #set reduction [list 0 $_ID_ {*}$stack] + yieldto return [yield [list 0 $_ID_ {*}$stack]] + } {#} { + set unsupported 1 + } {,} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + + #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] + } + yieldto return $MAP + } {!} { + #error "untested branch" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] + } + lassign [dict get $MAP invocantdata] OID alias default_command object_command + set command $object_command + set stack [list "_exec_" $command] + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + lassign [dict get $MAP invocantdata] OID alias default_command object_command + #set command ::p::${OID}::item + set command ::p::${OID}::$default_command + lappend stack $command + set operator , + + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + + } + + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + #} + incr w + } + } + + + #final = 1 + #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" + + return [list 1 $_ID_ {*}$stack] +} + + + +#trailing. directly after object +proc ::p::internals::ref_to_object {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set refname ::p::${OID}::_ref::__OBJECT + + array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces + + set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] + if {[list {array} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {array} $traceCmd + } + + set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] + if {[list {write} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {write} $traceCmd + } + + set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] + if {[list {unset} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { + #if {[lindex $fullstack 0] eq "_exec_"} { + # #strip it. This instruction isn't relevant for a reference. + # set commandstack [lrange $fullstack 1 end] + #} else { + # set commandstack $fullstack + #} + #set argstack [lassign $commandstack command] + #set field [string map {> __OBJECT_} [namespace tail $command]] + + + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + #puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + } else { + #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] + } + lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_ID_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + #set iflist [lindex $map 1 0] + set iflist [dict get $MAP interfaces level0] + #set iflist [dict get $MAP interfaces level0] + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_ID_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod object_command + #get fully qualified varspace + + # + set propdict [$object_command .. GetPropertyInfo $field] + if {[dict exists $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::p::${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::p::${OID} + } + + + + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::p::${OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + # 2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] + } +} + + + +#trailing. after command/property +proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { + if {[lindex $fullstack 0] eq "_exec_"} { + #strip it. This instruction isn't relevant for a reference. + set commandstack [lrange $fullstack 1 end] + } else { + set commandstack $fullstack + } + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + + + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + ::p::internals::create_or_update_reference $OID $_ID_ $refname $command + return $refname +} + + +namespace eval pp { + variable operators [list .. . -- - & @ # , !] + variable operators_notin_args "" + foreach op $operators { + append operators_notin_args "({$op} ni \$args) && " + } + set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands + #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} +interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! + + + + + +# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. +#each map is a 2 element list of lists. +# form: {$commandinfo $interfaceinfo} +# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} + +#2018 +#each map is a dict. +#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} + + +#OID = Object ID (integer for now - could in future be a uuid) +proc ::p::predator2 {_ID_ args} { + #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + + #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. + #set this_role_members [dict get $invocants this] + #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. + #lassign $this_invocant this_OID this_info_dict + + set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + + set cheat 1 ;# + #------- + #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) + #(it should be functionally equivalent to remove this shortcut block) + if {$cheat} { + if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { + + set remaining_args [lassign $args dot method_or_prop] + + #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? + set command ::p::${this_OID}::$method_or_prop + #REVIEW! + #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') + #if {[llength $command] > 1} { + # error "methods with spaces not included in test suites - todo fix!" + #} + #Dont use {*}$command - (so we can support methods with spaces) + #if {![llength [info commands $command]]} {} + if {[namespace which $command] eq ""} { + if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { + #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces + set command ::p::${this_OID}::(UNKNOWN) + #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + #tailcall {*}$command $_ID_ {*}$remaining_args + tailcall $command $_ID_ {*}$remaining_args + } + } + } + #------------ + + + if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { + return $_ID_ + } + + + #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" + + + + #puts stderr "this_info_dict: $this_info_dict" + + + + + if {![llength $args]} { + #should return some sort of public info.. i.e probably not the ID which is an implementation detail + #return cmd + return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID + + #return a dict keyed on object command name - (suitable as use for a .. Create 'target') + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped + #return [list $object_command [list -id $this_OID ]] + } elseif {[llength $args] == 1} { + #short-circuit the single index case for speed. + if {[lindex $args 0] ni {.. . -- - & @ # , !}} { + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method + lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method + + tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] + } elseif {[lindex $args 0] eq {--}} { + + #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. + # - combined with using UUIDs for $OID, and a secured/removed metaface on the object + # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) + # - this could effectively hide the object's namespaces,vars etc from the caller (?) + return [set ::p::${this_OID}::_meta::map] + } + } + + + + #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) + #incr c + #set reduce ::p::reducer${this_OID}_$c + set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] + #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" + coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args + + + set current_ID_ $_ID_ + + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] + #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" + #if {[string match *Destroy $command]} { + # puts stdout " calling Destroy reduction_args:'$reduction_args'" + #} + if {$final == 1} { + + if {[llength $command] == 1} { + if {$command eq "_exec_"} { + tailcall {*}$reduction_args + } + if {[llength [info commands $command]]} { + tailcall {*}$command $current_ID_ {*}$reduction_args + } + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + lset command 0 ::p::${this_OID}::(UNKNOWN) + tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}$reduction_args + } + + + } else { + if {[lindex $command 0] eq "_exec_"} { + set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] + + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + } else { + if {[llength $command] == 1} { + if {![llength [info commands $command]]} { + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + + lset command 0 ::p::${this_OID}::(UNKNOWN) + set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + } else { + #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + + } + } else { + set result [uplevel 1 [list {*}$command {*}$reduction_args]] + } + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set current_ID_ [$result .. INVOCANTDATA] + + + #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA + #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { + # set current_ID_ $result_invocantdata + #} else { + # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" + #} + } else { + #non-pattern command + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + + } + } + + } + } + error "Assert: Shouldn't get here (end of ::p::predator2)" + #return $result +} + +package provide patternpredator2 1.2.8 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 37244743..060e9517 100644 --- a/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/picalc-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_picalc 0 0.1.0] +#[manpage_begin punkshell_module_picalc 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/pipe-1.0.tm b/src/vfs/_vfscommon.vfs/modules/pipe-1.0.tm deleted file mode 100644 index 19222a85..00000000 --- a/src/vfs/_vfscommon.vfs/modules/pipe-1.0.tm +++ /dev/null @@ -1,305 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2025 -# -# @@ Meta Begin -# Application pipe 1.0 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_pipe 0 1.0] -#[copyright "2025"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require pipe] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of pipe -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by pipe -#[list_begin itemized] - -package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval pipe::class { - #*** !doctools - #[subsection {Namespace pipe::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 pipe { - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # Base namespace - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - #*** !doctools - #[subsection {Namespace pipe}] - #[para] Core API functions for pipe - #[list_begin definitions] - - - - #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" - #} - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace pipe ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval pipe::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace pipe::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace pipe::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval pipe::system { - #*** !doctools - #[subsection {Namespace pipe::system}] - #[para] Internal functions that are not part of the API - - - -#} - - -# == === === === === === === === === === === === === === === -# Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === -tcl::namespace::eval pipe { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - variable PUNKARGS - - lappend PUNKARGS [list { - @id -id "(package)pipe" - @package -name "pipe" -help\ - "Package - Description" - }] - - namespace eval pipe::argdoc { - #namespace for custom argument documentation - variable about_topics [list\ - license\ - version\ - contact\ - ] - proc about_topics {} { - variable about_topics - return $about_topics - } - proc get_topic_license {} { - return "%ver%" - } - proc get_topic_version {} { - return "%ver%" - } - proc get_topic_contact {} { - set authors {{Julian Noble } {test " - } - if {!$is_table} { - append about [format %-${widest_topic}s $topic] " " $topic_contents \n - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } -} -# end of sample 'about' function -# == === === === === === === === === === === === === === === - -if {![info exists ::punk::args::register::NAMESPACES]} { - namespace eval ::punk::args::register { - set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace - } -} -lappend ::punk::args::register::NAMESPACES pipe - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide pipe [tcl::namespace::eval pipe { - variable pkg pipe - variable version - set version 1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 55408253..90b3d334 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -8122,10 +8122,10 @@ namespace eval punk { interp alias {} mode {} punk::mode proc aliases {{glob *}} { - tailcall punk::lib::aliases $glob + tailcall punk::ns::aliases $glob } proc alias {{aliasorglob ""} args} { - tailcall punk::lib::alias $aliasorglob {*}$args + tailcall punk::ns::alias $aliasorglob {*}$args } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm index b8fada0b..0ab37079 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm @@ -108,8 +108,6 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - aliases ::punk::lib::aliases\ - alias ::punk::lib::alias\ tstr ::punk::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ @@ -138,6 +136,8 @@ tcl::namespace::eval punk::aliascore { config ::punk::config\ s ::punk::ns::synopsis\ eg ::punk::ns::eg\ + aliases ::punk::ns::aliases\ + alias ::punk::ns::alias\ ] #*** !doctools diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 15421402..64f3a0fd 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -147,14 +147,18 @@ tcl::namespace::eval punk::ansi::class { }] method render_to_input_line {args} { if {[llength $args] < 1} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + return } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + return } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -6076,12 +6080,13 @@ tcl::namespace::eval punk::ansi::ta { } #perl: ta_strip + punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip proc strip {text} { #*** !doctools #[call [fun strip] [arg text]] #[para]Return text stripped of Ansi codes #[para]This is a tailcall to punk::ansi::ansistrip - tailcall ansistrip $text + tailcall punk::ansi::ansistrip $text } lappend PUNKARGS [list { @@ -6113,7 +6118,7 @@ tcl::namespace::eval punk::ansi::ta { "Calculate length of text (excluding the ANSI codes) This is not the printing length of the string on screen." @values -min 1 - text -type string + text -type string } ] #perl: ta_length proc length {text} { @@ -6133,7 +6138,7 @@ tcl::namespace::eval punk::ansi::ta { #perl: ta_trunc #truncate $text to $width columns while still including all the ANSI colour codes. proc trunc {text width args} { - + error "unimplemented" } #not in perl ta diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.0.tm index 6e8e28e4..3f914682 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0] +#[manpage_begin punkshell_module_::punk::ansi::colourmap 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] 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 ef4765e1..47338954 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm @@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::register { if {![info exists scanned_info]} { set scanned_info [dict create] } - #some packages, e.g punk::args::tclcore document other namespaces. + #some packages, e.g punk::args::moduledoc::tclcore document other namespaces. #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources variable namespace_docpackages if {![info exists namespace_docpackages]} { @@ -466,6 +466,8 @@ tcl::namespace::eval punk::args { recognised types: any (unvalidated - accepts anything) + unknown + (unvalidated - accepts anything) none (used for flags/switches only. Indicates this is a 'solo' flag ie accepts no value) @@ -475,6 +477,8 @@ tcl::namespace::eval punk::args { number list indexexpression + indexset + (as accepted by punk::lib::is_indexset) dict double float @@ -632,7 +636,7 @@ tcl::namespace::eval punk::args { from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { punk::args::define { @id -id ::myns::myfunc @cmd -name myns::myfunc -help\ @@ -764,24 +768,25 @@ tcl::namespace::eval punk::args { if {[dict exists $rawdef_cache $args]} { return [dict get [dict get $rawdef_cache $args] -id] } else { - set id [rawdef_id $args] + set lvl 2 + set id [rawdef_id $args $lvl] if {[id_exists $id]} { #we seem to be re-creating a previously defined id... #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + undefine $id 0 - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id + ##dict unset argdata_cache $prevraw ;#silently does nothing if key not present + #dict for {k v} $argdata_cache { + # if {[dict get $v id] eq $id} { + # dict unset argdata_cache $k + # } + #} + #dict for {k v} $rawdef_cache { + # if {[dict get $v -id] eq $id} { + # dict unset rawdef_cache $k + # } + #} + #dict unset id_cache_rawdef $id } set is_dynamic [rawdef_is_dynamic $args] set defspace [uplevel 1 {::namespace current}] @@ -790,6 +795,35 @@ tcl::namespace::eval punk::args { return $id } } + proc undefine {id {quiet 0}} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[id_exists $id]} { + if {!$quiet} { + puts stderr "punk::args::undefine clearing existing data for id:$id" + } + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } else { + if {!$quiet} { + puts stderr "punk::args::undefine unable to find id: '$id'" + } + } + } + #'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated + # In this case we don't see the autoid in order to delete it + #proc undefine_deflist {deflist} { + #} proc idquery_info {id} { variable id_cache_rawdef @@ -889,7 +923,8 @@ tcl::namespace::eval punk::args { set textargs $args if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} + #punk::args::get_by_id ::punk::args::define {} + punk::args::parse {} -errorstyle minimal withid ::punk::args::define return } #if {[lindex $args 0] eq "-dynamic"} { @@ -1184,7 +1219,7 @@ tcl::namespace::eval punk::args { } ref { #a reference within the definition - #e.g see punk::args::tclcore ::after + #e.g see punk::args::moduledoc::tclcore ::after #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id @@ -1952,6 +1987,7 @@ tcl::namespace::eval punk::args { char - character {set normtype char} dict - dictionary {set normtype dict} index - indexexpression {set normtype indexexpression} + indexset {set normtype indexset} "" - none - solo { if {$is_opt} { #review - are we allowing clauses for flags? @@ -1975,6 +2011,10 @@ tcl::namespace::eval punk::args { } } any - anything {set normtype any} + unknown { + #'unspecified' ?? + set normtype unknown + } ansi - ansistring {set normtype ansistring} string - globstring {set normtype $lc_firstword} literal { @@ -2705,25 +2745,38 @@ tcl::namespace::eval punk::args { #@dynamic only has meaning as 1st element of a def in the deflist } - #@id must be within first 4 lines of a block - or assign auto + #@id must be within first 4 lines of first 3 blocks - or assign auto #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { + proc rawdef_id {rawdef {lvl 1}} { set id "" - foreach d $rawdef { + set found_id_line 0 + foreach d [lrange $rawdef 0 2] { foreach ln [lrange [split $d \n] 0 4] { if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { if {$firstword eq "@id"} { + set found_id_line 1 + #review - uplevel 2 would be a call from punk::args::define ?? + set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]] if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { set id [dict get $rest -id] - break } + break } } } - if {$id ne ""} { + if {$found_id_line} { break } } + if {$id eq "" && $found_id_line} { + #Looked like an @id - but presumable the rest of the line was malformed. + #we won't produce an autoid for such a definition. + set first3blocks "" + foreach b [lrange $rawdef 0 2] { + append first3blocks $b\n + } + error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks" + } if {$id eq "" || [string tolower $id] eq "auto"} { variable id_counter set id "autoid_[incr id_counter]" @@ -2916,7 +2969,9 @@ tcl::namespace::eval punk::args { set seen_documentedns [list] ;#seen per pkgns foreach definitionlist [set ${pkgns}::PUNKARGS] { #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] + #set id [rawdef_id $definitionlist] + set lvl 1 ;#level at which tstr substitution occurs in @id line + set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]] if {[string match autoid_* $id]} { puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" puts stderr "definition:\n" @@ -2958,6 +3013,9 @@ tcl::namespace::eval punk::args { } else { set needed [list] foreach pkgns $nslist { + if {[string match (autodef)* $pkgns]} { + set pkgns [string range $pkgns 9 end] + } if {![string match ::* $pkgns]} { puts stderr "warning: update_definitions received unqualified ns: $pkgns" set pkgns ::$pkgns @@ -3443,18 +3501,28 @@ tcl::namespace::eval punk::args { set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO + #review - when can there be more than one selected form? set argdisplay_header "" set argdisplay_body "" - set is_custom_argdisplay 0 + if {[llength $selected_forms] == 1} { + set fid [lindex $selected_forms 0] + set FRM [dict get $spec_dict FORMS $fid] + if {[dict size [dict get $FRM FORMDISPLAY]]} { + set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""] + set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""] + } + } + + + # if {![dict size $F $fid $FORMDISPLAY]} {} + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + #set is_custom_argdisplay 0 set blank_header_col [list] @@ -4335,7 +4403,7 @@ tcl::namespace::eval punk::args { documentation generated dynamically and may not yet have an id. IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - Generally punk::ns::arginfo (aliased as i in the punk shell) should + Generally punk::ns::cmdhelp (aliased as i in the punk shell) should be used in preference - as it will search for a documentation mechanism and call punk::args::usage as necessary. " @@ -5730,6 +5798,15 @@ tcl::namespace::eval punk::args { break } } + indexset { + if {![punk::lib::is_indexset $e_check]} { + set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + break + } + } string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks @@ -8729,7 +8806,7 @@ tcl::namespace::eval punk::args { } set type_expression [string trim $typespec ?] - if {$type_expression in {any none}} { + if {$type_expression in {any none unknown}} { continue } #puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]" @@ -8790,7 +8867,8 @@ tcl::namespace::eval punk::args { dict set finalopts $o $v } } - return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + set docid [dict get $argspecs id] + return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid] } lappend PUNKARGS [list { @@ -9570,8 +9648,15 @@ tcl::namespace::eval punk::args { } } - set cinfo [punk::ns::resolve_command {*}$cmd] - set tp [dict get $cinfo cmdtype] + #don't use full cmdinfo if $cmd is a single element + if {[llength $cmd] == 1} { + set cinfo [punk::ns::cmdwhich $cmd] + set tp [dict get $cinfo whichtype] + } else { + puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo" + set cinfo [punk::ns::cmdinfo {*}$cmd] + set tp [dict get $cinfo cmdtype] + } dict set choiceinfodict $sc [list [list resolved $cmd]] @@ -9584,9 +9669,23 @@ tcl::namespace::eval punk::args { } } - if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + #could be more than one punk::args id - choose a precedence by how we order the id_exists checks. + if {[punk::args::id_exists [list $ensemble $sc]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc] + } elseif {[punk::args::id_exists $cmd]} { dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}$cmd] + } elseif {[punk::args::id_exists [dict get $cinfo origin]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]] + } else { + #puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]" } + + #if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + # dict lappend choiceinfodict $sc {doctype punkargs} + #} } set argdef "" @@ -9699,9 +9798,18 @@ tcl::namespace::eval punk::args::lib { ooc { lappend marks [punk::ns::Cmark ooc cyan] } + classmethod { + lappend marks [punk::ns::Cmark classmethod term-orange1] + } + coremethod { + lappend marks [punk::ns::Cmark coremethod term-plum1] + } ooo { lappend marks [punk::ns::Cmark ooo cyan] } + objectmethod { + lappend marks [punk::ns::Cmark objectmethod term-orange1] + } native { lappend marks [punk::ns::Cmark native] } @@ -9724,11 +9832,11 @@ tcl::namespace::eval punk::args::lib { @id -id ::punk::args::lib::tstr @cmd -name punk::args::lib::tstr\ -summary\ - "Templating with \$\{$varName\}"\ + "Templating with placeholders such as: \$\{$varName\}"\ -help\ - "A rough equivalent of js template literals + "Roughly analogous to js template literals - Substitutions: + Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm similarity index 89% rename from src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm index da2fcd9f..10413ffc 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::tclcore 0.1.0 +# Application punk::args::moduledoc::tclcore 0.1.0 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,11 +18,11 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args::tclcore 0 0.1.0] +#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.1.0] #[copyright "2025"] #[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] #[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] -#[require punk::args::tclcore] +#[require punk::args::moduledoc::tclcore] #[keywords module] #[description] #[para] - @@ -31,10 +31,10 @@ #*** !doctools #[section Overview] -#[para] overview of punk::args::tclcore +#[para] overview of punk::args::moduledoc::tclcore #[subsection Concepts] -#[para] - - +#[para] This is a punk::args module documentation package. +#[para] It provides punk::args definitions for core Tcl commands, # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements @@ -42,7 +42,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::args::tclcore +#[para] packages used by punk::args::moduledoc::tclcore #[list_begin itemized] package require Tcl 8.6- @@ -52,6 +52,7 @@ package require textblock #*** !doctools #[item] [package {Tcl 8.6}] #[item] [package {punk::args}] +#[item] [package {punk::ansi}] #[item] [package {textblock}] #*** !doctools @@ -66,7 +67,7 @@ package require textblock # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tclcore { +tcl::namespace::eval punk::args::moduledoc::tclcore { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase #variable xyz @@ -114,7 +115,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { tcl::namespace::import ::punk::ansi::a+ - tcl::namespace::import ::punk::args::tclcore::manpage_tcl + tcl::namespace::import ::punk::args::moduledoc::tclcore::manpage_tcl # -- --- --- --- --- #non colour SGR codes # we can use these directly via ${$I} etc without marking a definition with @dynamic @@ -135,149 +136,16 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { + #*** !doctools + #[subsection {Namespace punk::args::moduledoc::tclcore::argdoc}] + #[para] This is the main documentation namespace where calls to punk::args::define are made, and definitions are added to the punk::args::moduledoc::tclcore::argdoc::PUNKARGS variable. + #[para] Some utility functions exist here for use in the definitions. + #[list_begin definitions] + variable PUNKARGS - #lappend PUNKARGS [list { - # @id -id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # @cmd -name ::punk::args::tclcore::argdoc::ensemble_subcommands_definition -help\ - # "Helper function to return a punk::args definition snippet for subcommands" - # @leaders -max 0 -min 0 - # -groupdict -default {} -type dict -help\ - # "Dictionary keyed on arbitrary groupname, where value - # is a list of known subcommands that should be displayed - # by groupname. Each groupname forms the title of a subtable - # in the choices list. - # Subcommands not assigned to a groupname will appear first - # in an untitled subtable." - # -columns -default 4 -type integer -help\ - # "Max number of columns for all subtables in the choices - # display area" - # @values -min 1 -max 1 - # ensemble -optional 0 -help\ - # "Name of ensemble command" - - #}] - #proc ensemble_subcommands_definition {args} { - # #args manually parsed - with use of argdef for unhappy-path only - # if {![llength $args]} { - # #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - # punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # return - # } - # set ensemble [lindex $args end] - # set optlist [lrange $args 0 end-1] - # if {[llength $optlist] % 2} { - # #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - # punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # return - # } - # set defaults [dict create\ - # -groupdict {}\ - # -columns 4\ - # ] - # set optlist [dict merge $defaults $optlist] - # dict for {k v} $optlist { - # switch -- $k { - # -groupdict - -columns {} - # default { - # #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - # punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - # return - # } - # } - # } - # set opt_groupdict [dict get $optlist -groupdict] - # set opt_columns [dict get $optlist -columns] - - # package require punk::ns - # set subdict [punk::ns::ensemble_subcommands -return dict $ensemble] - # set allsubs [dict keys $subdict] - # # ---------------------------------------------- - # # manually defined group members may have subcommands that are obsoleted/missing - # # we choose to make the situation obvious by re-classifying into a corresponding group with the " - MISSING" suffix - # set checked_groupdict [dict create] - # dict for {g members} $opt_groupdict { - # set validmembers {} - # set invalidmembers {} - # foreach m $members { - # if {$m in $allsubs} { - # lappend validmembers $m - # } else { - # lappend invalidmembers $m - # } - # } - # dict set checked_groupdict $g $validmembers - # if {[llength $invalidmembers]} { - # dict set checked_groupdict "${g}_MISSING" $invalidmembers - # } - # } - # if {[dict exists $checked_groupdict ""]} { - # set others [dict get $checked_groupdict ""] - # dict unset checked_groupdict "" - # } else { - # set others [list] - # } - - # #REVIEW - # set debug 0 - # if {$debug} { - # puts "punk::args::tclcore::argdoc::ensemble_subcommands_definition" - # if {[catch { - # ::punk::lib::pdict checked_groupdict - # } msg]} { - # puts stderr "punk::args::tclcore::ensemble_subcommands_definition Cannot call pdict\n$msg" - # } - # puts -------------------- - # puts "$checked_groupdict" - # puts -------------------- - # } - - # set opt_groupdict $checked_groupdict - # # ---------------------------------------------- - # set allgrouped [list] - # dict for {g members} $opt_groupdict { - # lappend allgrouped {*}$members - # } - # set choiceinfodict [dict create] - # foreach {sc cmd} $subdict { - # if {$sc ni $allgrouped} { - # if {$sc ni $others} { - # lappend others $sc - # } - # } - # set cinfo [punk::ns::resolve_command {*}$cmd] - # set tp [dict get $cinfo cmdtype] - - # dict set choiceinfodict $sc [list [list resolved $cmd]] - - # switch -- $tp { - # ensemble - native { - # dict lappend choiceinfodict $sc [list doctype $tp] - # } - # object { - # dict lappend choiceinfodict $sc [list doctype oo] - # } - # } - - # if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { - # dict lappend choiceinfodict $sc {doctype punkargs} - # } - # } - - # set argdef "" - # append argdef "subcommand -choicegroups \{" \n - # append argdef " \"\" \{$others\}" \n - # dict for {g members} $opt_groupdict { - # append argdef " \"$g\" \{$members\}" \n - # } - # append argdef " \} -choicecolumns $opt_columns -choiceinfo {$choiceinfodict}" \n - - # #todo -choicelabels - # #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. - # #consider a different mechanism to add a label on rhs of same line as choice (for (i) marker) - - # return $argdef - #} + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore::argdoc ---}] } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -366,7 +234,7 @@ tcl::namespace::eval punk::args::tclcore { "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." @values -min 1 -max 1 procname -type string -optional 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" punk::args::define { @id -id ::tcl::info::body @@ -374,19 +242,15 @@ tcl::namespace::eval punk::args::tclcore { "Returns the body procedure named ${$I}procname${$NI}." @values -min 1 -max 1 procname -type string -optional 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" punk::args::define { - @id -id ::tcl::info::default - @cmd -name "Built-in: tcl::info::default" -help\ - "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} - has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. - Otherwise, returns ${$B}0${$N}." - @values -min 3 -max 3 - procname -type string -optional 0 - parameter - varname - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + @id -id ::tcl::info::cmdcount + @cmd -name "Built-in: tcl::info::cmdcount" -help\ + "Returns the total number of commands evaluated in this interpreter." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" punk::args::define { @id -id ::tcl::info::cmdtype @@ -420,7 +284,116 @@ tcl::namespace::eval punk::args::tclcore { " @values -min 1 -max 1 commandName -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::coroutine + @cmd -name "Built-in: tcl::info::coroutine" -help\ + "Returns the name of the current ${$B}coroutine${$N}, or the empty string if there + is no current coroutine or the current coroutine has been deleted." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::default + @cmd -name "Built-in: tcl::info::default" -help\ + "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} + has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. + Otherwise, returns ${$B}0${$N}." + @values -min 3 -max 3 + procname -type string -optional 0 + parameter + varname + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::functions + @cmd -name "Built-in: tcl::info::functions" -help\ + "If ${$I}pattern${$NI} is not given, returns a list of all the math functions currently defined. + If ${$I}pattern${$NI} is given, returns only those names that match ${$I}pattern${$NI} according to ${$B}string match${$N}." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::globals + @cmd -name "Built-in: tcl::info::globals" -help\ + "If ${$I}pattern${$NI} is not given, returns a list of all the names of currently-defined + global variables. Global variables are variables in the global namespace. If ${$I}pattern${$NI} is + given, only those names matching ${$I}pattern${$NI} are returned. Matching is determined using the + same rules as for ${$B}string match${$N}." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::hostname + @cmd -name "Built-in: tcl::info::hostname" -help\ + "Returns the name of the current host. + This name is not guaranteed to be the fully-qualified domain name of the host. + Where machines have several different names, as is common on systems with + both TCP/IP (DNS) and NetBIOS-based networking installed, it is the name that + is suitable for TCP/IP networking that is returned." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::level + @cmd -name "Built-in: tcl::info::level" -help\ + "If number is not given, the level this routine was called from. Otherwise + returns the complete command active at the given level. If number is greater + than ${$B}0${$N}, it is the desired level. Otherwise, it is number levels up from the + current level. A complete command is the words in the command, with all + substitutions performed, meaning that it is a list. See ${$B}uplevel${$N} for more + information on levels." + @values -min 0 -max 2 + level -type integer -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::library + @cmd -name "Built-in: tcl::info::library" -help\ + "Returns the value of ${$B}tcl_library${$N}, which is the name of the library + directory in which the scripts distributed with Tcl scripts are stored." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::loaded + @cmd -name "Built-in: tcl::info::loaded" -help\ + "Returns the name of each file loaded in interp by the load command with + prefix prefix . If prefix is not given, returns a list where each item is + the name of the loaded file and the prefix for which the file was loaded. + For a statically-loaded package the name of the file is the empty string. + For interp, the empty string is the current interpreter." + @values -min 0 -max 2 + interp -type string -optional 1 + prefix -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::locals + @cmd -name "Built-in: tcl::info::locals" -help\ + "If ${$I}pattern${$NI} is given, returns the name of each local variable matching + pattern according to ${$B}string match${$N}. Otherwise, returns the name of each local + variable. A variables defined with the ${$B}global${$N}, ${$B}upvar${$N} or ${$B}variable${$N} is not local." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + + punk::args::define { + @id -id ::tcl::info::nameofexecutable + @cmd -name "Built-in: tcl::info::nameofexecutable" -help\ + "Returns the absolute pathname of the program for the current interpreter. + If such a file can not be identified an empty string is returned." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + punk::args::define { @id -id ::oo::InfoObject::call @@ -440,7 +413,7 @@ tcl::namespace::eval punk::args::tclcore { class, or the literal string ${$B}object${$N} if the method implementation is on an instance) element 3: a word describing the type of method implementation - (see ${$B}info object methodtype${$N} + (see ${$B}info object methodtype${$N}) Note that there is no inspection of whether the method implementations actually use ${$B}next${$N} to transfer control along the call chain, and the call chains that @@ -450,6 +423,39 @@ tcl::namespace::eval punk::args::tclcore { method } "@doc -name Manpage: -url [manpage_tcl info]" + + #--------- + punk::args::define { + @id -id ::oo::InfoClass::call + @cmd -name "Built-in: oo::InfoClass::call" -help\ + "Returns a description of the method implementations that are used to provide + a stereotypical instance of ${$I}class's${$NI} implementation of ${$I}method${$NI}. + (stereotypical instances being objects instantiated by a class without having any + object-specific definitions added). + This consists of a + list of lists of four elements, where each sublist consists of: + element 0: a word that describes the general type of method implementation, being + one of + ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, + ${$B}filter${$N} for an applied filter, + ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that + is invoked as part of unknown method handling. + element 1: a word giving the name of the particular method invoked (which is always + the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" + for the ${$B}unknown${$N} type) + element 2: a word giving the fully qualified name of the class that defined the + method + element 3: a word describing the type of method implementation + (see ${$B}info class methodtype${$N}) + + Note that there is no inspection of whether the method implementations actually use + ${$B}next${$N} to transfer control along the call chain, and the call chains that + this command files do not actually contain private methods." + @values -min 2 -max 2 + class + method + } "@doc -name Manpage: -url [manpage_tcl info]" + proc info_subcommands {} { #package require punk::ns #set subdict [punk::ns::ensemble_subcommands -return dict info] @@ -461,17 +467,20 @@ tcl::namespace::eval punk::args::tclcore { return [punk::args::ensemble_subcommands_definition -groupdict $groups -columns 4 info] } - set DYN_INFO_SUBCOMMANDS {${[punk::args::tclcore::argdoc::info_subcommands]}} + set DYN_INFO_SUBCOMMANDS {${[punk::args::moduledoc::tclcore::argdoc::info_subcommands]}} lappend PUNKARGS [list { @dynamic @id -id ::info - @cmd -name "Built-in: info" -help\ + @cmd -name "Built-in: info"\ + -summary\ + "Information about the state of the Tcl interpreter"\ + -help\ "Information about the state of the Tcl interpreter" @leaders -min 1 -max 1 ${$DYN_INFO_SUBCOMMANDS} @values -min 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl array]" ] + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl array]" ] } @@ -522,17 +531,20 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id "::tcl::binary::encode::hex" @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" + @cmd -name "binary encode hex"\ + -summary "Encode each byte to a pair of hex digits (lower case output)" @values -min 1 -max 1 data -type string } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::hex" @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" + @cmd -name "binary encode hex"\ + -summary "Decode contiguous pairs of hex digits to bytes (input may be upper or lower case)" -strict -type none -help\ "Instructs the decoder to throw an error if it encounters whitespace - characters. Otherwise it ignores them." + characters. Otherwise it ignores them. + Whether -strict is applied or not, a trailing unpaired hex digit is ignored." @values -min 1 -max 1 data -type string }] @@ -580,6 +592,101 @@ tcl::namespace::eval punk::args::tclcore { data -type string } ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::convertfrom" + @cmd -name "encoding convertfrom" -help\ + "Converts data, which should be in the form of a binary string encoded as per encoding, + to a Tcl string. If encoding is not specified, the current system encoding is used." + + @form -form basic + @values -min 1 -max 2 + encoding -type string -typesynopsis ${$I}encoding${$NI} -optional 1 + data -type string -help "binary string" + + @form -form full + @leaders -min 0 -max 0 + @opts + -profile -type string -typesynopsis ${$I}profile${$NI} -help\ + "Determines the command behavior in the presence of conversion errors. + Any premature termination of processing due to errors is reported through an exception + if the -failindex option is not specified. + + Operations involving encoding transforms may encounter several types of errors such as + invalid sequences in the source data, characters that cannot be encoded in the target + encoding and so on. A profile prescribes the strategy for dealing with such errors in + one of two ways: + + Terminating further processing of the source data. The profile does not determine how + this premature termination is conveyed to the caller. By default, this is signalled + by raising an exception. If the -failindex option is specified, errors are reported + through that mechanism. + + Continue further processing of the source data using a fallback strategy such as + replacing or discarding the offending bytes in a profile-defined manner. + + The following profiles are currently implemented with strict being the default if the -profile is not specified."\ + -choicecolumns 1\ + -choices {strict tcl8 replace}\ + -choiceprefix 0\ + -choicelabels { + strict + " The strict profile always stops processing when an conversion error is encountered. + The error is signalled via an exception or the -failindex option mechanism. + The strict profile implements a Unicode standard conformant behavior." + tcl8 + " The tcl8 profile always follows the first strategy above and corresponds to the behavior + of encoding transforms in Tcl 8.6. When converting from an external encoding other than + utf-8 to Tcl strings with the encoding convertfrom command, invalid bytes are mapped to + their numerically equivalent code points. For example, the byte 0x80 which is invalid in + ASCII would be mapped to code point U+0080. When converting from utf-8, invalid bytes + that are defined in CP1252 are mapped to their Unicode equivalents while those that are + not fall back to the numerical equivalents. For example, byte 0x80 is defined by CP1252 + and is therefore mapped to its Unicode equivalent U+20AC while byte 0x81 which is not + defined by CP1252 is mapped to U+0081. As an additional special case, the sequence + 0xC0 0x80 is mapped to U+0000. When converting from Tcl strings to an external encoding + format using encoding convertto, characters that cannot be represented in the target + encoding are replaced by an encoding-dependent character, usually the question mark ?." + replace + " Like the tcl8 profile, the replace profile always continues processing on conversion + errors but follows a Unicode standard conformant method for substitution of invalid + source data. When converting an encoded byte sequence to a Tcl string using encoding + convertfrom, invalid bytes are replaced by the U+FFFD REPLACEMENT CHARACTER code point. + When encoding a Tcl string with encoding convertto, code points that cannot be represented + in the target encoding are transformed to an encoding-specific fallback character, U+FFFD + REPLACEMENT CHARACTER for UTF targets and generally `?` for other encodings." + } + -failindex -type string -typesynopsis ${$I}var${$NI} -help\ + "If specified, instead of an exception being raised on premature termination, + the result of the conversion up to the point of the error is returned as the + result of the command. In addition, the index of the source byte triggering + the error is stored in var. If no errors are encountered, the entire result + of the conversion is returned and the value -1 is stored in var." + @values -min 2 -max 2 + encoding -type string -optional 0 + data -type string -help "binary string" + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + + lappend PUNKARGS [list { + @id -id "::tcl::encoding::convertto" + @cmd -name "encoding convertto" -help\ + "Convert string to the specified encoding. The result is a Tcl binary string that + contains the sequence of bytes representing the converted string in the specified + encoding. If encoding is not specified, the current system encoding is used." + @form -form basic + @values -min 1 -max 2 + encoding -type string -typesynopsis ${$I}encoding${$NI} -optional 1 + data -type string + + @form -form full + @leaders -min 0 -max 0 + @opts + ${[punk::args::resolved_def -form 1 -types opts ::tcl::encoding::convertfrom -*]} + @values -min 2 -max 2 + encoding -type string -optional 0 + data -type string + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } namespace eval argdoc { lappend PUNKARGS [list { @id -id "::tcl::encoding::dirs" @@ -597,6 +704,46 @@ tcl::namespace::eval punk::args::tclcore { directoryList -optional 1 -type list } "@doc -name Manpage: -url [manpage_tcl encoding]" ] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::names" + @cmd -name "encoding names" -help\ + "Returns a list containing the names of all of the encodings that are + currently available. The encodings “utf-8” and “iso8859-1” are + guaranteed to be present in the list." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::profiles" + @cmd -name "encoding profiles" -help\ + "Returns a list of the names of encoding profiles. See PROFILES below." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::system" + @cmd -name "encoding system" -help\ + "Set the system encoding to ${$I}encoding${$NI}. If ${$I}encoding${$NI} is + omitted then the command returns the current system encoding. + The system encoding is used whenever Tcl passes strings to system calls." + @values -min 0 -max 1 + encoding -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::user" + @cmd -name "encoding user" -help\ + "Returns the name of encoding as per the user's preferences. + On Windows systems, this is based on the user's code page settings in + the registry. On other platforms, the returned value is the same as + returned by encoding system." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } lappend PUNKARGS [list { @id -id ::time @@ -1124,7 +1271,7 @@ tcl::namespace::eval punk::args::tclcore { arguments as second (and possibly subsequent) arguments. This facilitates lookups in nested dictionaries. For example, the following two commands are equivalent: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { dict get $dict foo bar spong dict get [dict get [dict get $dict foo] bar] spong\ } @@ -1704,7 +1851,7 @@ tcl::namespace::eval punk::args::tclcore { The handler is invoked when a command called from within the namespace cannot be found in the current namespace, the namespace's path nor in the global namespace. - When the handler is invoiked, the full invocation line will be appended to + When the handler is invoked, the full invocation line will be appended to the script and the result evaluated in the context of the namespace. The default handler for all namespaces is ${[a+ italic]}::unknown${[a+ noitalic]}. If no argument is given, it returns the handler for the current namespace." @@ -1725,11 +1872,13 @@ tcl::namespace::eval punk::args::tclcore { See the section NAME RESOLUTION in the manpage for an explanation of the rules regarding name resolution. " - @opts - -command -type none - #todo - make mutually exclusive - (separate forms) - -variable -type none - @values -min 1 -max 1 + @leaders -min 0 -max 1 + option -type {literalprefix(-command)|literalprefix(-variable)} -optional 1 -choices {-command -variable} + #@opts + #-command -type none + ##todo - make mutually exclusive - (separate forms) + #-variable -type none + #@values -min 1 -max 1 name } "@doc -name Manpage: -url [manpage_tcl namespace]" ] @@ -1921,7 +2070,7 @@ tcl::namespace::eval punk::args::tclcore { namespace even if its name does not start with “::”. The semantics of ${$B}apply${$N} can also be described by approximately this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc apply {fun args} { set len [llength $fun] if {($len < 2) || ($len > 3)} { @@ -1965,7 +2114,7 @@ tcl::namespace::eval punk::args::tclcore { arrayName must be the name of an existing array variable. The subcommand argument determines what action is carried out by the command." @leaders - ${[punk::args::tclcore::argdoc::array_subcommands]} + ${[punk::args::moduledoc::tclcore::argdoc::array_subcommands]} } "@doc -name Manpage: -url [manpage_tcl array]" ] @@ -2128,6 +2277,163 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl catch]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + #TODO - add CLOCK_ARITHMETIC documentation + #TODO - TIME ZONES documentation? + lappend PUNKARGS [list { + @id -id ::tcl::clock::add + @cmd -name "Built-in: tcl::clock::add"\ + -summary\ + "Add an offset to timeVal in seconds (base 1970-01-01 00:00 UTC)"\ + -help\ + "Adds a (possibly negative) offset to a time that is expressed as an integer number of seconds. See CLOCK ARITHMETIC for a full description." + @leaders -min 1 -max -1 + timeVal -type integer|literal(now) -help\ + "Time value in integer number of seconds since epoch time. + Instead of timeVal a non-integer value now can be used as replacement for today, + which is simply interpolated to the run-time as value of clock seconds." + count_unit -type {int string} -multiple 1 -optional 1 -help\ + "unit is one of seconds,minutes,hours,cays,weekdays,weeks,months or years" + @opts + -timezone -type string -choicerestricted 0 -choiceprefix 0 -choicecolumns 7\ + -help\ + "e.g (from tzdata file) + :localtime + :UTC + :Australia/Sydney + :America/New_York + Note that the choices listed below are case insensitive, but the location based timezones + beginning with a colon are case sensitive. + See 'TIME ZONES' in the clock manpage"\ + -choices { + gmt ut utc bst wet wat at + nft nst ndt ast adt est edt + cst cdt mst mdt pst pdt yst + ydt hst hdt cat ahst nt idlw + cet cest met mewt mest swt sst + eet eest bt it zp4 zp5 ist + zp6 wast wadt jt cct jst cast + cadt east eadt gst nzt nzst nzdt + idle + } + -locale -type string -help\ + "Specifies that locale-dependent scanning and formatting (and date arithmetic for dates preceding + the adoption of the Gregorian calendar) is to be done in the locale identified by localeName. + The locale name may be any of the locales acceptable to the msgcat package, or it may be the special + name system, which represents the current locale of the process, or the null string, which + represents Tcl's default locale. + e.g en_US" + -gmt -type boolean -help\ + "If boolean is true, specifies that a time specified to clock add, clock format or clock scan should be processed in UTC. + If boolean is false, the processing defaults to the local time zone. This usage is obsolete; the correct current usage + is to specify the UTC time zone with “-timezone :UTC” or any of the equivalent ways to specify it." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::clock::format + @cmd -name "Built-in: tcl::clock::format"\ + -summary\ + "Format a time that is expressed as an integer number of seconds."\ + -help\ + "Formats a time that is expressed as an integer number of seconds into a format intended + for consumption by users or external programs. See ${$B}CLOCK ARITHMETIC${$N} for a full description." + @leaders -min 1 -max -1 + timeVal -type integer|literal(now) -help\ + "Time value in integer number of seconds since epoch time. + Instead of timeVal a non-integer value now can be used as replacement for today, + which is simply interpolated to the run-time as value of clock seconds." + @opts + ${[punk::args::resolved_def -types opts ::tcl::clock::add -*]} + -format -type string -help\ + "A string that specifies how the date and time are to be formatted. + The string consists of any number of characters other than the per-cent sign (“%”) + interspersed with any number of format groups, which are two-character sequences + beginning with the per-cent sign. The permissible format groups, and their + interpretation, are described under ${$B}FORMAT GROUPS${$N}." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + #::tcl::clock::clicks + #::tcl::clock::format + + + #review - definition doesn't preclude supplying both -milliseconds and -microseconds, but they are mutually exclusive + #lappend PUNKARGS [list { + # @id -id ::tcl::clock::clicks + # @cmd -name "Built-in: tcl::clock::clicks"\ + # -summary\ + # "high-resolution time value as system-dependent integer."\ + # -help\ + # "If no -option argument is supplied, returns a high-resolution time value as a system-dependent integer value. + # The unit of the value is system-dependent but should be the highest resolution clock available on the system + # such as a CPU cycle counter. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + # @opts + # -milliseconds -type none -help\ + # "Synonymous with ${$B}clock milliseconds${$N}. + # This usage is obsolete, and ${$B}clock milliseconds${$N} is to be + # considered the preferred way of obtaining a count of milliseconds." + # -microseconds -type none -help\ + # "Synonymous with ${$B}clock microseconds${$N}. + # This usage is obsolete, and ${$B}clock microseconds${$N} is to be + # considered the preferred way of obtaining a count of microseconds." + # @values -min 0 -max 0 + #} "@doc -name Manpage: -url [manpage_tcl clock]" ] + lappend PUNKARGS [list { + @id -id ::tcl::clock::clicks + @cmd -name "Built-in: tcl::clock::clicks"\ + -summary\ + "high-resolution time value as system-dependent integer."\ + -help\ + "If no option argument is supplied, returns a high-resolution time value as a system-dependent integer value. + The unit of the value is system-dependent but should be the highest resolution clock available on the system + such as a CPU cycle counter. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + @values -min 0 -max 1 + option -optional 1 -type {literalprefix(-milliseconds)|literalprefix(-microseconds)} -choices {-milliseconds -microseconds}\ + -choicelabels { + -milliseconds + "Synonymous with ${$B}clock milliseconds${$N}. + This usage is obsolete, and ${$B}clock milliseconds${$N} is to be + considered the preferred way of obtaining a count of milliseconds." + -microseconds + "Synonymous with ${$B}clock microseconds${$N}. + This usage is obsolete, and ${$B}clock microseconds${$N} is to be + considered the preferred way of obtaining a count of microseconds." + }\ + -choicecolumns 1 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + + lappend PUNKARGS [list { + @id -id ::tcl::clock::microseconds + @cmd -name "Built-in: tcl::clock::microseconds"\ + -summary\ + "Current time as an integer number of microseconds."\ + -help\ + "Returns the current time as an integer number of microseconds. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::clock::milliseconds + @cmd -name "Built-in: tcl::clock::milliseconds"\ + -summary\ + "Current time as an integer number of milliseconds."\ + -help\ + "Returns the current time as an integer number of milliseconds. See ${$B}HIGH RESOLUTION TIMERS${$N} for a full description." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::clock::seconds + @cmd -name "Built-in: tcl::clock::seconds"\ + -summary\ + "Current time as an integer number of seconds."\ + -help\ + "Returns the current time as an integer number of seconds." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl clock]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { @dynamic @id -id ::concat @@ -2230,14 +2536,14 @@ tcl::namespace::eval punk::args::tclcore { Historically, this feature had been most useful in conjunction with the catch command: if a caught error cannot be handled successfully, info can be used to return a stack trace reflecting the original point of occurrence of the error: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { catch {...} errMsg set savedInfo $::errorInfo ... error $errMsg $savedInfo }]} When working with Tcl 8.5 or later, the following code should be used intead: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { catch {...} errMsg options ... return -options $options $errMsg @@ -2280,7 +2586,7 @@ tcl::namespace::eval punk::args::tclcore { with extra values appended. This technique is used in a number of places throughout the Tcl core (e.g. in ${$B}fcopy${$N}, ${$B}lsort${$N} and ${$B}trace${$N} command callbacks). This example shows how to do this using core Tcl commands: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set script { puts "logging now" lappend $myCurrentLogVar @@ -2301,7 +2607,7 @@ tcl::namespace::eval punk::args::tclcore { pattern. It is less general than the eval command, and hence easier to make robust in practice. The following procedure acts in a way that is analogous to the lappend command, except it inserts the argument values at the start of the list in the variable: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc lprepend {varName args} { upvar 1 $varName var # Ensure that the variable exists and contains a list @@ -2311,11 +2617,11 @@ tcl::namespace::eval punk::args::tclcore { } }]} However, the last line would now normally be written without eval, like this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set var [linsert $var 0 {*}$args] }]} Or indeed like this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set var [list {*}$args {*}$var] }]} } @@ -2336,7 +2642,7 @@ tcl::namespace::eval punk::args::tclcore { Since non-zero exit codes are usually interpreted as error cases by the calling process, the exit command is an important part of signaling that something fatal has gone wrong. This code fragment is useful in scripts to act as a general problem trap: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc main {} { # ... put the real main code in here ... } @@ -2457,7 +2763,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl buildinfo]"\ {@examples -help { These show the use of ::tcl::build-info. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ::tcl::build-info → 9.0.2+af16c07b81655fabde8028374161ad54b84ef9956843c63f49976b4ef601b611.gcc-1204 ::tcl::build-info commit @@ -2507,7 +2813,10 @@ tcl::namespace::eval punk::args::tclcore { one will be treated as the first ${$I}arg${$NI} even if it starts with a -." @values -min 1 -max -1 - arg -type string -multiple 1 -optional 0 + arg -type string\ + -help "Command and arguments to be executed. May be interspersed with + various 'control of flow' operators which are not passed to the subprocess."\ + -multiple 1 -optional 0 -choicerestricted 0 -choices {"|" "|&" ">>" "2>>" ">>&"} #we must give an optional value a -default - or it will be processed as empty string and won't validate if not received! #(default values are never validated) stderr_to_result -type {literal(2>@1)} -optional 1 -default 0 @@ -2680,7 +2989,7 @@ tcl::namespace::eval punk::args::tclcore { The two forms may be mixed, so -types {d f r w} will find all regular files OR directories that have both read AND write permissions. The following are equivalent: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { glob -type d * glob */} ]} @@ -2912,24 +3221,24 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl ledit]"\ {@examples -help { Prepend to a list. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set lst {c d e f g} -> c d e f g ledit lst -1 -1 a b -> a b c d e f g }]} Append to the list. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ledit lst end+1 end+1 h i -> a b c d e f g h i }]} Delete the third and fourth elements. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ledit lst 2 3 -> a b e f g h i }]} Replace two elements with three. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { ledit lst 2 3 x y z -> a b x y z g h i set lst @@ -3309,7 +3618,7 @@ tcl::namespace::eval punk::args::tclcore { included, it's sign should agree with the direction of the sequence (descending -> negative and ascending -> positive), otherwise an empty list is returned. For example: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { % lseq 1 to 5 ;#increasing -> 1 2 3 4 5 @@ -3515,15 +3824,15 @@ tcl::namespace::eval punk::args::tclcore { sublist (as if the overall element and the indexList were passed to lindex) and sort based on the given element. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -integer -index 1 \ {{First 24} {Second 18} {Third 30}} }]} returns ${$B}{Second 18} {First 24} {Third 30}${$N}, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -index end-1 \ {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}} }]} returns ${$B}{c 4 5 6 d h} {a 1 e i} {b 2 3 f 5}${$N}, and - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -index {0 1} { {{b i g} 12345} {{d e m o} 34512} @@ -3542,10 +3851,10 @@ tcl::namespace::eval punk::args::tclcore { The list length must be an integer multiple of the strideLength, which in turn must be at least 2. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -stride 2 {carrot 10 apple 50 banana 25} }]} returns "apple 50 banana 25 carrot 10", and - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { lsort -stride 2 -index 1 -integer {carrot 10 apple 50 banana 25} }]} returns "carrot 10 banana 25 apple 50".} -nocase -type none -help\ @@ -3675,7 +3984,7 @@ tcl::namespace::eval punk::args::tclcore { in the directory that it was started in (unless the user specifies otherwise) since that minimizes user confusion. The way to do this is to save the current directory while the external command is being run: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set tarFile [file normalize somefile.tar] set savedDir [pwd] cd /tmp @@ -3691,7 +4000,7 @@ tcl::namespace::eval punk::args::tclcore { in the directory that it was started in (unless the user specifies otherwise) since that minimizes user confusion. The way to do this is to save the current directory while the external command is being run: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set tarFile [file normalize somefile.tar] set savedDir [pwd] cd /tmp @@ -4134,7 +4443,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl socket]"\ {@examples -help { Here is a very simple time server: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc Server {startTime channel clientaddr clientport} { puts "Connection from $clientaddr registered" set now [clock seconds] @@ -4146,7 +4455,7 @@ tcl::namespace::eval punk::args::tclcore { socket -server [list Server [clock seconds]] 9900 vwait forever}]} And here is the corresponding client to talk to the server and extract some information: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set server localhost set sockChan [socket $server 9900] gets $sockChan line1 @@ -4190,11 +4499,11 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl source]"\ {@examples -help { Run the script in the file ${B}foo.tcl${$N} and then the script in ${$B}bar.tcl${$N}: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { source foo.tcl source bar.tcl }]} Alternatively: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { foreach scriptFile {foo.tcl bar.tcl} { source $scriptFile }}]} @@ -4295,10 +4604,10 @@ tcl::namespace::eval punk::args::tclcore { specified (in any of the forms described in STRING_INDICES), then the search is constrained to start with the character in ${$I}haystackString${$NI} specified by the index. For Example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string first a 0a23456789abcdef 5 }]} will return ${$B}10${$N}, but - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string first a 0a23456789abcdef 11 }]} will return ${$B}-1${$N}. " @@ -4350,10 +4659,10 @@ tcl::namespace::eval punk::args::tclcore { specified (in any of the forms described in STRING_INDICES), then only the characters in ${$I}haystackString${$NI} at or before the specified lastIndex will be considered by the search. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string last a 0a23456789abcdef 15 }]} will return ${$B}10${$N}, but - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string last a 0a23456789abcdef 9 }]} will return ${$B}1${$N}." @values -min 1 -max 3 @@ -4385,12 +4694,12 @@ tcl::namespace::eval punk::args::tclcore { key appearing first in the list will be checked first, and so on. ${$I}string${$NI} is only iterated over once, so earlier key replacements will have no affect for later key matches. For example, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc }]} will return the string ${$B}01321221${$N}. Note that if an earlier key is a prefix of a later one, it will completely mask the later one, So if the previous example were reordered like this, - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { string map {1 0 ab 2 a 3 abc 1} 1abcaababcabababc }]} it will return the string ${$B}02c322c222c${$N}. " @@ -4960,7 +5269,7 @@ tcl::namespace::eval punk::args::tclcore { ${B}EXAMPLES${$N} The following produces an error that is identical to that produced by expr when trying to divide a value by zero. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { throw {ARITH DIVZERO {divide by zero}} {divide by zero} }]}" @values -min 2 -max 2 @@ -4988,7 +5297,8 @@ tcl::namespace::eval punk::args::tclcore { obsolete {variable vdelete vinfo} }\ -choiceinfo { - add {{doctype punkargs} {subhelp ::trace add}} + add {{doctype punkargs} {subhelp ::trace add}} + remove {{doctype punkargs} {subhelp ::trace remove}} } @values -min 0 -max 0 @@ -4996,23 +5306,30 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id "::trace add" - @cmd -name "Built-in: trace add" -help\ - "" + @cmd -name "Built-in: trace add"\ + -summary\ + "Add a command, execution or variable trace."\ + -help\ + "Add a command, execution or variable trace." @form -synopsis "trace add type name ops ?args?" @leaders type -choicegroups { "" {command execution variable} }\ -choiceinfo { - command {{doctype punkargs}} - execution {{doctype punkargs}} + command {{doctype punkargs} {subhelp ::trace add command}} + execution {{doctype punkargs} {subhelp ::trace add execution}} + variable {{doctype punkargs}} } } "@doc -name Manpage: -url [manpage_tcl trace]" punk::args::define { @id -id "::trace add command" - @cmd -name "Built-in: trace add command" -help\ + @cmd -name "Built-in: trace add command"\ + -summary\ + "Add command trace for operation(s): rename delete"\ + -help\ "Arrange for commandPrefix to be executed (with additional arguments) whenever command name is modified in one of the ways given by the list ops. Name will be resolved using the usual namespace resolution rules @@ -5056,10 +5373,126 @@ tcl::namespace::eval punk::args::tclcore { " } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { + @id -id "::trace add variable" + @cmd -name "Built-in: trace add variable"\ + -summary\ + "Add variable trace for operation(s): array read write unset."\ + -help\ + "Arrange for commandPrefix to be executed whenever variable name is accessed + in one of the ways given by the list ops. Name may refer to a normal variable, + an element of an array, or to an array as a whole (i.e. name may be just the + name of an array, with no parenthesized index). If name refers to a whole + array, then commandPrefix is invoked whenever any element of the array is + manipulated. If the variable does not exist, it will be created but will not + be given a value, so it will be visible to namespace which queries, but not to + info exists queries." + name -type string -help\ + "Name of variable" + # --------------------------------------------------------------- + ops -type list -choices {array read write unset} -choiceprefix 0\ + -choicemultiple {1 4}\ + -choicecolumns 1\ + -choicelabels { + array\ + " Invoke commandPrefix whenever the variable is accessed or + modified via the array command, provided that name is not a + scalar variable at the time that the array command is invoked. + If name is a scalar variable, the access via the array command + will not trigger the trace." + read\ + " Invoke commandPrefix whenever the variable isread." + write\ + " Invoke commandPrefix whenever the variable is written." + unset\ + " Invoke commandPrefix whenever the variable is unset. Variables + can be unset explicitly with the unset command, or implicitly + when procedures return (all of their local variables are unset). + Variables are also unset when interpreters are deleted, but + traces will not be invoked because there is no interpreter in + which to execute them." + }\ + -help\ + "Indicates which operations are of interest." + commandPrefix -type string -help\ + "When the trace triggers, three arguments are appended to commandPrefix + so that the actual command is as follows: + ----------------------------------------- + commandPrefix name1 name2 op + ----------------------------------------- + Name1 gives the name for the variable being accessed. This is not + necessarily the same as the name used in the trace add variable command: + the upvar command allows a procedure to reference a variable under a + different name. If the trace was originally set on an array or array + element, name2 provides which index into the array was affected. This + information is present even when name1 refers to a scalar, which may + happen if the upvar command was used to create a reference to a single + array element. If an entire array is being deleted and the trace was + registered on the overall array, rather than a single element, then + name1 gives the array name and name2 is an empty string. Op indicates + what operation is being performed on the variable, and is one of read, + write, or unset as defined above. + + CommandPrefix executes in the same context as the code that invoked the + traced operation: if the variable was accessed as part of a Tcl procedure, + then commandPrefix will have access to the same local variables as code in + the procedure. This context may be different than the context in which the + trace was created. If commandPrefix invokes a procedure (which it normally + does) then the procedure will have to use upvar or uplevel if it wishes to + access the traced variable. Note also that name1 may not necessarily be + the same as the name used to set the trace on the variable; differences + can occur if the access is made through a variable defined with the upvar + command. + + For read and write traces, commandPrefix can modify the variable to affect + the result of the traced operation. If commandPrefix modifies the value of + a variable during a read or write trace, then the new value will be + returned as the result of the traced operation. The return value from + commandPrefix is ignored except that if it returns an error of any sort + then the traced operation also returns an error with the same error message + returned by the trace command (this mechanism can be used to implement + read-only variables, for example). For write traces, commandPrefix is + invoked after the variable's value has been changed; it can write a new + value into the variable to override the original value specified in the + write operation. To implement read-only variables, commandPrefix will have + to restore the old value of the variable. + + While commandPrefix is executing during a read or write trace, traces on + the variable are temporarily disabled. This means that reads and writes + invoked by commandPrefix will occur directly, without invoking + commandPrefix (or any other traces) again. However, if commandPrefix + unsets the variable then unset traces will be invoked. + + When an unset trace is invoked, the variable has already been deleted: it + will appear to be undefined with no traces. If an unset occurs because of + a procedure return, then the trace will be invoked in the variable context + of the procedure being returned to: the stack frame of the returning + procedure will no longer exist. Traces are not disabled during unset + traces, so if an unset trace command creates a new trace and accesses the + variable, the trace will be invoked. Any errors in unset traces are ignored. + + If there are multiple traces on a variable they are invoked in order of + creation, most-recent first. If one trace returns an error, then no further + traces are invoked for the variable. If an array element has a trace set, + and there is also a trace set on the array as a whole, the trace on the + overall array is invoked before the one on the element. + + Once created, the trace remains in effect either until the trace is removed + with the trace remove variable command described below, until the variable + is unset, or until the interpreter is deleted. Unsetting an element of array + will remove any traces on that element, but will not remove traces on the + overall array. + + This command returns an empty string." + } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { @id -id "::trace add execution" - @cmd -name "Built-in: trace add execution" -help\ + @cmd -name "Built-in: trace add execution"\ + -summary\ + "Add execution trace for operation(s): enter leave enterstep leavestep."\ + -help\ "Arrange for commandPrefix to be executed (with additional arguments) whenever command name is executed, with traces occurring at the points indicated by the list ops. Name will be resolved using the usual namespace @@ -5159,6 +5592,25 @@ tcl::namespace::eval punk::args::tclcore { " } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { + @id -id "::trace remove" + @cmd -name "Built-in: trace remove"\ + -summary\ + "Remove a command, execution or variable trace."\ + -help\ + "Remove a command, execution or variable trace." + @form -synopsis "trace remove type name ops ?args?" + @leaders + type -choicegroups { + "" {command execution variable} + }\ + -choiceinfo { + command {{doctype punkargs} {subhelp ::trace remove command}} + execution {{doctype punkargs} {subhelp ::trace remove execution}} + variable {{doctype punkargs} {subhelp ::trace remove variable}} + } + + } "@doc -name Manpage: -url [manpage_tcl trace]" punk::args::define { @id -id "::trace remove command" @cmd -name "Built-in: trace remove command" -help\ @@ -5175,6 +5627,44 @@ tcl::namespace::eval punk::args::tclcore { delete" commandPrefix } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove execution" + @cmd -name "Built-in: trace remove execution" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string. If + name does not exist, the command will throw an error" + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + enter + leave + enterstep + leavestep" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove variable" + @cmd -name "Built-in: trace remove variable" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string." + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + array + read + write + unset" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -5263,7 +5753,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl try]"\ {@examples -help { Ensure that a file is closed no matter what: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set f [open /some/file/name a] try { puts $f "some message" @@ -5273,7 +5763,7 @@ tcl::namespace::eval punk::args::tclcore { } }]} Handle different reasons for a file to not be openable for reading: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { try { set f [open /some/file/name r] } trap {POSIX EISDIR} {} { @@ -5286,7 +5776,7 @@ tcl::namespace::eval punk::args::tclcore { The file is closed in success and error case by the finally clause. It is allowed to call return within the try block. Remark that with tcl 9, the read command may also throw utf-8 conversion errors: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc readfile {filename} { set f [open $filename r] try { @@ -5442,15 +5932,15 @@ tcl::namespace::eval punk::args::tclcore { varName -type string -multiple 1 -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl vwait]"\ + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl vwait]"\ {@examples -help { Run the event-loop continually until some event calls exit. (You can use any variable not mentioned elsewhere, but the name forever reminds you at a glance of the intent.) - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { vwait forever }]} Wait five seconds for a connection to a server socket, otherwise close the socket and continue running the script: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { # Initialise the state after 5000 set state timeout set server [socket -server accept 12345] @@ -5480,7 +5970,7 @@ tcl::namespace::eval punk::args::tclcore { }]} A command that will wait for some time delay by waiting for a namespace variable to be set. Includes an interlock to prevent nested waits. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { namespace eval example { variable v done proc wait {delay} { @@ -5500,7 +5990,7 @@ tcl::namespace::eval punk::args::tclcore { the waiting for the a variable never finishes; that vwait command is still waiting for a script scheduled with after to complete, which just happens to be running an inner vwait (for b) even though the event that the outer vwait was waiting for (the setting of a) has occurred. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { after 500 { puts "waiting for b" vwait b @@ -5517,7 +6007,7 @@ tcl::namespace::eval punk::args::tclcore { set b 42 }]} If you run the above code, you get this output: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { waiting for a waiting for b setting a @@ -5526,7 +6016,7 @@ tcl::namespace::eval punk::args::tclcore { commands, and yet b will not be set until after the outer vwait returns, so the script has deadlocked. The only ways to avoid this are to either structure the overall program in continuation-passing style or to use coroutine to make the continuations implicit. The first of these options would be written as: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { after 500 { puts "waiting for b" trace add variable b write {apply {args { @@ -5552,7 +6042,7 @@ tcl::namespace::eval punk::args::tclcore { vwait done }]} The second option, with coroutine and some helper procedures, is done like this: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { # A coroutine-based wait-for-variable command proc waitvar globalVar { trace add variable ::$globalVar write \ @@ -5659,7 +6149,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl update]"\ {@examples -help { Run computations for about a second and then finish: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set x 1000 set done 0 after 1000 set done 1 @@ -5703,12 +6193,12 @@ tcl::namespace::eval punk::args::tclcore { The uplevel command causes the invoking procedure to disappear from the procedure calling stack while the command is being executed. In the above example, suppose c invokes the command: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { uplevel 1 {set x 43; d}}]} where d is another Tcl procedure. The set command will modify the variable x in b's context, and d will execute at level 3, as if called from b. If it in turn executes the command: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { uplevel 1 {set x 42}}]} then the set command will modify the same variable x in b's context: the procedure c does not appear to be on the call stack when d is executing. @@ -5757,7 +6247,7 @@ tcl::namespace::eval punk::args::tclcore { calling and also makes it easier to build new control constructs as Tcl procedures. For example, consider the following procedure: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { proc add2 name { upvar $name x set x [expr {$x + 2}] @@ -5821,7 +6311,7 @@ tcl::namespace::eval punk::args::tclcore { evaluated (before each loop iteration), so changes in the variables will be visible. For an example, try the following script with and without the braces around ${$B}$x<10:${$N} - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set x 0 while {$x<10} { puts "x is $x" @@ -5860,7 +6350,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string initValue -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -5876,7 +6366,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string initValue -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -5892,7 +6382,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string level -type integer -range {0 9} -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @dynamic @@ -5907,7 +6397,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string bufferSize -type integer -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib deflate" @@ -5918,7 +6408,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 2 string -type string level -type integer -range {0 9} -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib push" @@ -6019,7 +6509,7 @@ tcl::namespace::eval punk::args::tclcore { compressed stream back to the channel, making them appear as unread to further readers." @values -min 0 -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gunzip" @@ -6053,7 +6543,7 @@ tcl::namespace::eval punk::args::tclcore { @opts -headerVar -type string -typesynopsis ${$I}varName${$NI} @values -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gzip" @@ -6090,7 +6580,7 @@ tcl::namespace::eval punk::args::tclcore { -level -type integer -range {0 9} -typesynopsis ${$I}level${$NI} -header -type dict -typesynopsis ${$I}dict${$NI} @values -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -6144,22 +6634,22 @@ tcl::namespace::eval punk::args::tclcore { -choicelabels {${$CHOICELABELS}}\ -choiceinfo {${$CHOICEINFO}} - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"\ + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]"\ {@examples -help { To compress a Tcl string, it should be first converted to a particular charset encoding since the zlib command always operates on binary strings. - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set binData [encoding convertto utf-8 $string] set compData [zlib compress $binData] }]} When converting back, it is also important to reverse the charset encoding: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set binData [zlib decompress $compData] set string [encoding convertfrom utf-8 $binData] }]} The compression operation from above can also be done with streams, which is especially helpful when you want to accumulate the data by stages: - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { set strm [zlib stream compress] $strm put [encoding convertto utf-8 $string] # ... @@ -6176,7 +6666,7 @@ tcl::namespace::eval punk::args::tclcore { dict set groups "ZIP Creation" {mkzip mkimg mkkey lmkimg lmkzip} return [punk::args::ensemble_subcommands_definition -groupdict $groups -columns 3 zipfs] } - set DYN_ZIPFS_SUBCOMMANDS {${[punk::args::tclcore::argdoc::zipfs_subcommands]}} + set DYN_ZIPFS_SUBCOMMANDS {${[punk::args::moduledoc::tclcore::argdoc::zipfs_subcommands]}} punk::args::define { @dynamic @id -id ::zipfs @@ -6201,7 +6691,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 1 -max 1 ${$DYN_ZIPFS_SUBCOMMANDS} @values -min 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::canonical @@ -6214,7 +6704,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 1 mountpoint -type string -optional 1 filename -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::exists @@ -6223,7 +6713,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 filename -type file - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::find @@ -6235,7 +6725,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 directoryName -type directory - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::info @@ -6254,7 +6744,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 file -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::list @@ -6275,7 +6765,7 @@ tcl::namespace::eval punk::args::tclcore { #patterntype -type literalprefix(-glob)|literalprefix(-regexp) -optional 1 patterntype -type string -default -glob -choices {-glob -regexp} -typesynopsis -glob|-regex pattern -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkimg @@ -6290,7 +6780,7 @@ tcl::namespace::eval punk::args::tclcore { inlist -type dict password -type any -optional 1 infile -type file -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkzip @@ -6304,7 +6794,7 @@ tcl::namespace::eval punk::args::tclcore { outfile -type file inlist -type dict password -type any -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mount @@ -6349,7 +6839,7 @@ tcl::namespace::eval punk::args::tclcore { mountpoint -type string password -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mountdata @@ -6359,7 +6849,7 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max 1 data -type any mountpoint -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkzip @@ -6382,7 +6872,7 @@ tcl::namespace::eval punk::args::tclcore { strip -type string -optional 1 -help\ "file name prefix" password -type any -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkimg @@ -6424,7 +6914,7 @@ tcl::namespace::eval punk::args::tclcore { "file name prefix" password -type string -optional 1 infile -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkkey @@ -6434,7 +6924,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 1 -max 1 password -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::root @@ -6445,7 +6935,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @opts -min 0 -max 0 @values -min 0 -max 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::unmount @@ -6457,7 +6947,7 @@ tcl::namespace::eval punk::args::tclcore { @opts -min 0 -max 0 @values -min 1 -max 1 mountpoint - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- } @@ -6466,8 +6956,8 @@ tcl::namespace::eval punk::args::tclcore { #*** !doctools - #[subsection {Namespace punk::args::tclcore}] - #[para] Core API functions for punk::args::tclcore + #[subsection {Namespace punk::args::moduledoc::tclcore}] + #[para] Core API functions for punk::args::moduledoc::tclcore #[list_begin definitions] @@ -6488,7 +6978,7 @@ tcl::namespace::eval punk::args::tclcore { #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tclcore ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -6496,11 +6986,11 @@ tcl::namespace::eval punk::args::tclcore { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tclcore::lib { +tcl::namespace::eval punk::args::moduledoc::tclcore::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] #*** !doctools - #[subsection {Namespace punk::args::tclcore::lib}] + #[subsection {Namespace punk::args::moduledoc::tclcore::lib}] #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -6514,33 +7004,23 @@ tcl::namespace::eval punk::args::tclcore::lib { #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tclcore::lib ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::args::tclcore::system { - #*** !doctools - #[subsection {Namespace punk::args::tclcore::system}] - #[para] Internal functions that are not part of the API - -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore ::punk::args::tclcore::argdoc + lappend ::punk::args::register::NAMESPACES ::punk::args::moduledoc::tclcore ::punk::args::moduledoc::tclcore::argdoc } ## Ready -package provide punk::args::tclcore [tcl::namespace::eval punk::args::tclcore { - variable pkg punk::args::tclcore +package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore { + variable pkg punk::args::moduledoc::tclcore variable version set version 0.1.0 }] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tkcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tkcore-0.1.1.tm similarity index 93% rename from src/vfs/_vfscommon.vfs/modules/punk/args/tkcore-0.1.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tkcore-0.1.1.tm index 8492aba7..eef3100e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tkcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tkcore-0.1.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::tkcore 0.1.0 +# Application punk::args::moduledoc::tkcore 0.1.1 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,11 +18,11 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::args::tkcore 0 0.1.0] +#[manpage_begin punkshell_module_punk::args::moduledoc::tkcore 0 0.1.1] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::args::tkcore] +#[require punk::args::moduledoc::tkcore] #[keywords module] #[description] #[para] - @@ -31,7 +31,7 @@ #*** !doctools #[section Overview] -#[para] overview of punk::args::tkcore +#[para] overview of punk::args::moduledoc::tkcore #[subsection Concepts] #[para] - @@ -42,7 +42,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::args::tkcore +#[para] packages used by punk::args::moduledoc::tkcore #[list_begin itemized] package require Tcl 8.6- @@ -65,13 +65,13 @@ package require textblock -tcl::namespace::eval punk::args::tkcore { +tcl::namespace::eval punk::args::moduledoc::tkcore { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools - #[subsection {Namespace punk::args::tkcore}] - #[para] Core API functions for punk::args::tkcore + #[subsection {Namespace punk::args::moduledoc::tkcore}] + #[para] Core API functions for punk::args::moduledoc::tkcore #[list_begin definitions] tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase @@ -102,7 +102,7 @@ tcl::namespace::eval punk::args::tkcore { namespace eval argdoc { tcl::namespace::import ::punk::ansi::a+ - tcl::namespace::import ::punk::args::tkcore::manpage + tcl::namespace::import ::punk::args::moduledoc::tkcore::manpage # -- --- --- --- --- #non colour SGR codes # we can use these directly via ${$I} etc without marking a definition with @dynamic @@ -124,15 +124,15 @@ tcl::namespace::eval punk::args::tkcore { namespace eval argdoc { lappend PUNKARGS [list { - @id -id "(default)::punk::args::tkcore::common" + @id -id "(default)::punk::args::moduledoc::tkcore::common" } "@doc -name Manpage: -url [manpage index]" ] #list all tk_standardoptions #use punk::args::resolved_spec - #{${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions -disabledforeground -font ...]}} + #{${[punk::args::resolved_def -types opts (default)::punk::args::moduledoc::tkcore::tk_standardoptions -disabledforeground -font ...]}} ::punk::args::define { - @id -id "(default)::punk::args::tkcore::tk_standardoptions" + @id -id "(default)::punk::args::moduledoc::tkcore::tk_standardoptions" -activebackground -type colour -help\ "Specifies background color to use when drawing active elements. An element (a widget or portion of a widget) is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some @@ -388,7 +388,7 @@ tcl::namespace::eval punk::args::tkcore { @opts -type string -parsekey "" -group "STANDARD OPTIONS" -grouphelp\ "" }\ - {${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions\ + {${[punk::args::resolved_def -types opts (default)::punk::args::moduledoc::tkcore::tk_standardoptions\ -activebackground\ -activeforeground\ -anchor\ @@ -461,7 +461,7 @@ tcl::namespace::eval punk::args::tkcore { } #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tkcore ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tkcore ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -469,62 +469,41 @@ tcl::namespace::eval punk::args::tkcore { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tkcore::lib { +tcl::namespace::eval punk::args::moduledoc::tkcore::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] #*** !doctools - #[subsection {Namespace punk::args::tkcore::lib}] - #[para] Secondary functions that are part of the API + #[subsection {Namespace punk::args::moduledoc::tkcore::lib}] + #[para] Secondary functions that are part of the API #[list_begin definitions] - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tkcore::lib ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tkcore::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::args::tkcore::system { - #*** !doctools - #[subsection {Namespace punk::args::tkcore::system}] - #[para] Internal functions that are not part of the API - - - -#} - # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation # == === === === === === === === === === === === === === === -tcl::namespace::eval punk::args::tkcore { +tcl::namespace::eval punk::args::moduledoc::tkcore { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS variable PUNKARGS_aliases lappend PUNKARGS [list { - @id -id "(package)punk::args::tkcore" - @package -name "punk::args::tkcore" -help\ - "Package - Description" + @id -id "(package)punk::args::moduledoc::tkcore" + @package -name "punk::args::moduledoc::tkcore" -help\ + "punk::args documentation for Tk package" }] namespace eval argdoc { #namespace for custom argument documentation proc package_name {} { - return punk::args::tkcore + return punk::args::moduledoc::tkcore } proc about_topics {} { #info commands results are returned in an arbitrary order (like array keys) @@ -540,11 +519,11 @@ tcl::namespace::eval punk::args::tkcore { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::args::tkcore + punk::args::lib::tstr [string trim { + package punk::args::moduledoc::tkcore punk::args documentation for Tk } \n] } @@ -552,7 +531,7 @@ tcl::namespace::eval punk::args::tkcore { return "MIT" } proc get_topic_Version {} { - return "$::punk::args::tkcore::version" + return "$::punk::args::moduledoc::tkcore::version" } proc get_topic_Contributors {} { set authors {{Julian Noble -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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::tzint 1.1.1 +# Application punk::args::moduledoc::tzint 1.1.1 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,11 +18,11 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::args::tzint 0 1.1.1] +#[manpage_begin punkshell_module_punk::args::moduledoc::tzint 0 1.1.1] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::args::tzint] +#[require punk::args::moduledoc::tzint] #[keywords module] #[description] #[para] - @@ -31,7 +31,7 @@ #*** !doctools #[section Overview] -#[para] overview of punk::args::tzint +#[para] overview of punk::args::moduledoc::tzint #[subsection Concepts] #[para] - @@ -42,7 +42,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::args::tzint +#[para] packages used by punk::args::moduledoc::tzint #[list_begin itemized] package require Tcl 8.6- @@ -62,13 +62,13 @@ package require Tcl 8.6- #[section API] -tcl::namespace::eval punk::args::tzint { +tcl::namespace::eval punk::args::moduledoc::tzint { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools - #[subsection {Namespace punk::args::tzint}] - #[para] Core API functions for punk::args::tzint + #[subsection {Namespace punk::args::moduledoc::tzint}] + #[para] Core API functions for punk::args::moduledoc::tzint #[list_begin definitions] variable PUNKARGS @@ -119,7 +119,7 @@ tcl::namespace::eval punk::args::tzint { #This implies "varName data" is optional - but in practice it seems not to be (?) "varName data" -type {string string} -optional 0 @opts - -symbology -type string -choicerestricted 0 -choices {${[::punk::args::tzint::argdoc::get_symbologies]}} + -symbology -type string -choicerestricted 0 -choices {${[::punk::args::moduledoc::tzint::argdoc::get_symbologies]}} -height -type integer -help\ "The height of a 1d symbol" -whitespace -type integer -help\ @@ -182,7 +182,7 @@ tcl::namespace::eval punk::args::tzint { #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::tzint ---}] + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tzint ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -193,22 +193,21 @@ tcl::namespace::eval punk::args::tzint { # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation # == === === === === === === === === === === === === === === -tcl::namespace::eval punk::args::tzint { +tcl::namespace::eval punk::args::moduledoc::tzint { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS variable PUNKARGS_aliases lappend PUNKARGS [list { - @id -id "(package)punk::args::tzint" - @package -name "punk::args::tzint" -help\ - "Package - Description" + @id -id "(package)punk::args::moduledoc::tzint" + @package -name "punk::args::moduledoc::tzint" -help\ + "punk::args documentation for tzint package" }] namespace eval argdoc { #namespace for custom argument documentation proc package_name {} { - return punk::args::tzint + return punk::args::moduledoc::tzint } proc about_topics {} { #info commands results are returned in an arbitrary order (like array keys) @@ -216,7 +215,7 @@ tcl::namespace::eval punk::args::tzint { set about_topics [list] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + lappend about_topics [string range $tail [string length get_topic_] end] } #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] @@ -224,11 +223,11 @@ tcl::namespace::eval punk::args::tzint { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::args::tzint + punk::args::lib::tstr [string trim { + package punk::args::moduledoc::tzint description to come.. } \n] } @@ -236,7 +235,7 @@ tcl::namespace::eval punk::args::tzint { return "MIT" } proc get_topic_Version {} { - return "$::punk::args::tzint::version" + return "$::punk::args::moduledoc::tzint::version" } proc get_topic_Contributors {} { set authors {} @@ -261,23 +260,23 @@ tcl::namespace::eval punk::args::tzint { # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] - dict set overrides @id -id "::punk::args::tzint::about" - dict set overrides @cmd -name "punk::args::tzint::about" + dict set overrides @id -id "::punk::args::moduledoc::tzint::about" + dict set overrides @cmd -name "punk::args::moduledoc::tzint::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::args::tzint + About punk::args::moduledoc::tzint documentation for tzint package }] \n] - dict set overrides topic -choices [list {*}[punk::args::tzint::argdoc::about_topics] *] + dict set overrides topic -choices [list {*}[punk::args::moduledoc::tzint::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 - dict set overrides topic -default [punk::args::tzint::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + dict set overrides topic -default [punk::args::moduledoc::tzint::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] lappend PUNKARGS [list $newdef] proc about {args} { package require punk::args #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on - set argd [punk::args::parse $args withid ::punk::args::tzint::about] + set argd [punk::args::parse $args withid ::punk::args::moduledoc::tzint::about] lassign [dict values $argd] _leaders opts values _received - punk::args::package::standard_about -package_about_namespace ::punk::args::tzint::argdoc {*}$opts {*}[dict get $values topic] + punk::args::package::standard_about -package_about_namespace ::punk::args::moduledoc::tzint::argdoc {*}$opts {*}[dict get $values topic] } } # end of sample 'about' function @@ -291,14 +290,14 @@ tcl::namespace::eval punk::args::tzint { # variable PUNKARGS_aliases namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::args::tzint ::punk::args::tzint::argdoc + lappend ::punk::args::register::NAMESPACES ::punk::args::moduledoc::tzint ::punk::args::moduledoc::tzint::argdoc } # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready -package provide punk::args::tzint [tcl::namespace::eval punk::args::tzint { - variable pkg punk::args::tzint +package provide punk::args::moduledoc::tzint [tcl::namespace::eval punk::args::moduledoc::tzint { + variable pkg punk::args::moduledoc::tzint variable version set version 1.1.1 }] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/testcmd-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/testcmd-0.1.0.tm new file mode 100644 index 00000000..064bbe70 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/testcmd-0.1.0.tm @@ -0,0 +1,349 @@ +# -*- 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.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::args::testcmd 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::args::testcmd { + variable PUNKARGS + namespace export * + namespace ensemble create + + proc proc1 {args} {return proc1-$args} + namespace eval aaa_ensemble { + namespace export * + namespace ensemble create + proc a1 {} {} + proc a2 {} {} + namespace eval deep_ensemble { + namespace export * + namespace ensemble create + punk::args::define { + @id -id ::punk::args::testcmd::aaa_ensemble::deep_ensemble::d1 + @cmd -name punk::args::testcmd::aaa_ensemble::deep_ensemble::d1\ + -summary\ + "d1 summary"\ + -help\ + "d1 help info" + @leaders + subcmd -help "d1 subcmd" + @opts + -force -type none -help "apply force" + @values -min 0 -max -1 + arg -type any -multiple 1 -optional 1 -help "items" + } + proc d1 {args} { + set argd [punk::args::parse $args withid ::punk::args::testcmd::aaa_ensemble::deep_ensemble::d1] + lassign [dict values $argd] leaders opts values received + puts "got leaders: $leaders" + puts "got opts : $opts" + puts "got values : $values" + } + proc d2 {} {} + punk::args::define\ + {@id -id ${[namespace current]}::d3}\ + {@cmd -name ${[namespace current]}::d3\ + -summary\ + "${[namespace current]}::d3 summary"\ + -help\ + "d3 help info" + @leaders + subcmd -help "d3 subcmd" + @opts + -force -type none -help "apply force" + @values -min 0 -max -1 + arg -type any -multiple 1 -optional 1 -help "items" + } + proc d3 {args} { + set argd [punk::args::parse $args withid [namespace current]::d3] + lassign [dict values $argd] leaders opts values received + puts "d3 got leaders: $leaders" + puts "d3 got opts : $opts" + puts "d3 got values : $values" + } + } + } + namespace eval custom_ensemble { + namespace export * + namespace ensemble create + namespace ensemble configure [namespace current] -map {sub ::punk::args::testcmd::custom_ensemble::tricky} + #this ensemble named 'sub' is actually not part of the 'undocumented' command's subcommands - as sub points to tricky" + namespace eval sub { + namespace export * + namespace ensemble create + proc s1 {} {} + proc s2 {args} {} + proc s3 {a b} {} + proc s4 {a {b defaultvalue}} {} + } + namespace eval tricky { + namespace export * + namespace ensemble create + proc t1 {} {} + proc t2 {args} {} + proc t3 {a b} {} + proc t4 {a {b defaultvalue}} {} + } + } + namespace eval bbb_subensemble { + namespace export * + namespace ensemble create + proc b1 {} {} + proc b2 {} {} + + #here we create a def for the trace subcommand from scratch + #we could also have pulled it directly from the "::trace" definition + #using something like: punk::args::resolved_def -override {@id {-id ::punk::args::testcmd::bbb_subensemble::trace}} ::trace + #instead we've chosen to hide some of the deprecated subcommands (these are only available in tcl < 9 anyway) + punk::args::define { + @id -id ::punk::args::testcmd::bbb_subensemble::trace + @cmd -name "simulated built-in: punk::args::testcmd::bbb_subensemble::trace"\ + -summary\ + "Monitor variable accesses, command usages and command executions."\ + -help\ + "This command causes Tcl commands to be executed whenever certain + operations are invoked. " + + @leaders -min 1 -max 1 + option -choicegroups { + "" {add remove info} + }\ + -choiceinfo { + add {{doctype punkargs} {subhelp ::trace add}} + remove {{doctype punkargs} {subhelp ::trace remove}} + info {{doctype punkargs} {subhelp ::trace info}} + } + @values -min 0 -max 0 + + } + proc trace {args} { + tailcall ::trace {*}$args + } + } + #undocumented intermediate command 'gapped' with documented subcommand 'g1' + proc undocumented {args} { + set subcommands [list doc1 undoc1 ensemble sub] + switch -- [lindex $args 0] { + doc1 { + punk::args::testcmd::undocumented::doc1 {*}[lrange $args 1 end] + } + undoc1 { + punk::args::testcmd::undocumented::undoc1 {*}[lrange $args 1 end] + } + ensemble { + punk::args::testcmd::undocumented::ensemble {*}[lrange $args 1 end] + } + sub { + #deliberately mismatch the subcommand identifier to the location of the ensemble. + #this is just to emphasize the fact that we can't assume anything about the location + #of any subcommands after the undocumented point. They may not even be in the ::punk::args::testcmd::undocumented namespace + #so guessing would be a bad idea. + punk::args::testcmd::undocumented::tricky {*}[lrange $args 1 end] + } + default { + error "unknown subcommand '[lindex $args 0]' known subcommands: $subcommands" + } + } + } + namespace eval undocumented { + punk::args::define { + @id -id "::punk::args::testcmd::undocumented doc1" + @cmd -name "punk::args::testcmd::undocumented doc1"\ + -summary\ + "doc1 summary"\ + -help\ + "doc1 help info" + @leaders + subcmd -help "doc1 subcmd" + @opts + -force -type none -help "apply force" + @values -min 0 -max -1 + arg -type any -multiple 1 -optional 1 -help "items" + } + proc doc1 {args} { + set argd [punk::args::parse $args withid "::punk::args::testcmd::undocumented doc1"] + lassign [dict values $argd] leaders opts values received + puts "got leaders: $leaders" + puts "got opts : $opts" + puts "got values : $values" + } + proc undoc1 {args} { + return undoc1 + } + namespace eval ensemble { + namespace export * + namespace ensemble create + proc e1 {} {} + proc e2 {args} {} + proc e3 {a b} {} + proc e4 {a {b defaultvalue}} {} + } + #this ensemble named 'sub' is actually not part of the 'undocumented' command's subcommands - as sub points to tricky" + namespace eval sub { + namespace export * + namespace ensemble create + proc s1 {} {} + proc s2 {args} {} + proc s3 {a b} {} + proc s4 {a {b defaultvalue}} {} + } + namespace eval tricky { + namespace export * + namespace ensemble create + proc t1 {} {} + proc t2 {args} {} + proc t3 {a b} {} + proc t4 {a {b defaultvalue}} {} + } + } +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::testcmd::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::args::testcmd::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::args::testcmd { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::args::testcmd" + @package -name "punk::args::testcmd" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::args::testcmd + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::args::testcmd + description to come.. + } \n] + } + proc get_topic_License {} { + return "" + } + proc get_topic_Version {} { + return "$::punk::args::testcmd::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::args::testcmd::about" + dict set overrides @cmd -name "punk::args::testcmd::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::args::testcmd + }] \n] + dict set overrides topic -choices [list {*}[punk::args::testcmd::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::args::testcmd::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::args::testcmd::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::args::testcmd::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::args::testcmd +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args::testcmd [tcl::namespace::eval punk::args::testcmd { + variable pkg punk::args::testcmd + variable version + set version 0.1.0 +}] +return + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm index 20fa6dae..7a6e4416 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm @@ -66,12 +66,14 @@ namespace eval punk::cap::handlers::templates { set multivendor_package_whitelist [list punk::mix::templates] - #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called + #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the base rather than rechecking it each time the templates handler api is called #for template pathtype absolute - we can do the same. #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. - #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #adhoc and currentproject* pathtypes are relative to cwd - so no base information can be stored at registration time. + #module pathtype base is resolved by the providing package itself at load time using 'info script' + + #not all template item types will need base information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -86,44 +88,19 @@ namespace eval punk::cap::handlers::templates { if {[file pathtype $path] ne "relative"} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" } - - #todo - check for mounted modpod (or tarjar?) - #e.g //zipfs:/#modpod/d1/d2/#mounted-modpod-libname-V.v - #(or equivalent for vfs eg c:/repo/jn/shellspy/modules/test/#modpod/test/#mounted-modpod-libname-V.v - - set provide_statement [package ifneeded $pkg [package require $pkg]] - set tmfile [lindex $provide_statement end] - if {[interp issafe]} { - #default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable - if {[catch {file exists $tmfile} tm_exists]} { - puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" - flush stderr - return 0 - } - } else { - set tm_exists [file exists $tmfile] - } - if {!$tm_exists} { - puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" - flush stderr + #The package should have provided a base folder (by using 'info script') when it was loaded + #'package ifneeded' for a module gives initial path information for a package - but it might redirect to sourcing from a different location such as being mounted elsewhere in a vfs, + #in which case we wouldn't get the correct path. + if {![dict exists $capdict base]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'base' key (required when pathtype is 'module')" return 0 } - set tmfolder [file dirname $tmfile] - #todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately - #set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - - #set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW - - #REVIEW - do we even want project base relative to where the lib came from?? - #should be relative to executable? or cwd? - set projectbase [punk::repo::find_project $tmfolder] - - #store the projectbase even if it's empty string set extended_capdict $capdict - set resolved_path [file join $tmfolder $path] + set base [dict get $capdict base] + set resolved_path [file join $base $path] dict set extended_capdict resolved_path $resolved_path - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base $base } currentproject_multivendor { #currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense @@ -156,14 +133,18 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" return 0 } - set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + #set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]] + #set projectinfo [punk::repo::find_repos $shellbase] - #set projectbase [dict get $projectinfo closest] - set projectbase [punk::repo::find_project $shellbase] + #set base [dict get $projectinfo closest] + + #may result in empty base for no project found + set base [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base $base } shellproject_multivendor { #currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense @@ -175,14 +156,15 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" return 0 } - set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + #set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review + set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]] #set projectinfo [punk::repo::find_repos $shellbase] - #set projectbase [dict get $projectinfo closest] - set projectbase [punk::repo::find_project $shellbase] + #set base [dict get $projectinfo closest] + set base [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base $base } absolute { if {[file pathtype $path] ne "absolute"} { @@ -194,15 +176,12 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" return 0 } - #set projectinfo [punk::repo::find_repos $normpath] - #set projectbase [dict get $projectinfo closest] - set projectbase [punk::repo::find_project $normpath] #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor - dict set extended_capdict projectbase $projectbase + dict set extended_capdict base "" } default { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype" @@ -332,16 +311,16 @@ namespace eval punk::cap::handlers::templates { set path [dict get $capdecl_extended path] set pathtype [dict get $capdecl_extended pathtype] set vendor [dict get $capdecl_extended vendor] - # projectbase not present in capdecl_extended for all template pathtypes + # base not present in capdecl_extended for all template pathtypes ? if {$pathtype eq "adhoc"} { #e.g (cwd)/templates set targetpath [file join $startdir [dict get $capdecl_extended path]] if {[file isdirectory $targetpath]} { - dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype] + dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype base $startdir] } } elseif {$pathtype eq "module"} { - set module_projectroot [dict get $capdecl_extended projectbase] - dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] + set mbase [dict get $capdecl_extended base] + dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $mbase] } elseif {$pathtype eq "currentproject_multivendor"} { #set searchbase $startdir #set pathinfo [punk::repo::find_repos $searchbase] @@ -357,11 +336,11 @@ namespace eval punk::cap::handlers::templates { set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *] foreach vf $vendorfolders { if {$vf ne "_project"} { - dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $pwd_projectroot] } } if {[file isdirectory [file join $vendorbase _project]]} { - dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $pwd_projectroot] } } set custombase [file join $deckbase custom] @@ -369,11 +348,11 @@ namespace eval punk::cap::handlers::templates { set customfolders [glob -nocomplain -dir $custombase -type d -tails *] foreach cf $customfolders { if {$cf ne "_project"} { - dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $pwd_projectroot] } } if {[file isdirectory [file join $custombase _project]]} { - dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype] + dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $pwd_projectroot] } } } @@ -385,7 +364,7 @@ namespace eval punk::cap::handlers::templates { #path relative to projectroot already validated by handler as being within a currentproject_multivendor tree set targetfolder [file join $pwd_projectroot $path] if {[file isdirectory $targetfolder]} { - dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype] + dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $pwd_projectroot] } } } elseif {$pathtype eq "shellproject_multivendor"} { @@ -394,7 +373,7 @@ namespace eval punk::cap::handlers::templates { #set pathinfo [punk::repo::find_repos $shellbase] #set pwd_projectroot [dict get $pathinfo closest] - set shell_projectroot [dict get $capdecl_extended projectbase] + set shell_projectroot [dict get $capdecl_extended base] if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { @@ -406,11 +385,11 @@ namespace eval punk::cap::handlers::templates { set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *] foreach vf $vendorfolders { if {$vf ne "_project"} { - dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $shell_projectroot] } } if {[file isdirectory [file join $vendorbase _project]]} { - dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $shell_projectroot] } } set custombase [file join $deckbase custom] @@ -418,11 +397,11 @@ namespace eval punk::cap::handlers::templates { set customfolders [glob -nocomplain -dir $custombase -type d -tails *] foreach cf $customfolders { if {$cf ne "_project"} { - dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $shell_projectroot] } } if {[file isdirectory [file join $custombase _project]]} { - dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $shell_projectroot] } } @@ -434,17 +413,17 @@ namespace eval punk::cap::handlers::templates { #set pathinfo [punk::repo::find_repos $shellbase] #set pwd_projectroot [dict get $pathinfo closest] - set shell_projectroot [dict get $capdecl_extended projectbase] + set shell_projectroot [dict get $capdecl_extended base] if {$shell_projectroot ne ""} { set targetfolder [file join $shell_projectroot $path] if {[file isdirectory $targetfolder]} { - dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot] + dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $shell_projectroot] } } } elseif {$pathtype eq "absolute"} { #lappend found_paths [dict get $capdecl_extended resolved_path] - set abs_projectroot [dict get $capdecl_extended projectbase] - dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot] + set abs_projectroot [dict get $capdecl_extended base] + dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $abs_projectroot] } } @@ -460,19 +439,19 @@ namespace eval punk::cap::handlers::templates { dict for {vendor pathinfolist} $found_paths_module { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } #Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD) dict for {vendor pathinfolist} $found_paths_shellproject_multivendor { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } dict for {vendor pathinfolist} $found_paths_shellproject { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } @@ -488,7 +467,7 @@ namespace eval punk::cap::handlers::templates { } dict for {vendor pathinfolist} $found_paths_absolute { foreach pathinfo $pathinfolist { - dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] + dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor] } } #adhoc paths relative to cwd (or specified -startdir) can override any @@ -540,9 +519,9 @@ namespace eval punk::cap::handlers::templates { set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] - if {[dict exists $refinfo sourceinfo projectbase]} { + if {[dict exists $refinfo sourceinfo base]} { #some template pathtypes refer to the projectroot from the template - not the cwd - set ref_projectroot [dict get $refinfo sourceinfo projectbase] + set ref_projectroot [dict get $refinfo sourceinfo base] } else { set ref_projectroot $projectroot } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm index 08174ca8..a59fdcea 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::icomm 0 0.1.0] +#[manpage_begin punkshell_module_punk::icomm 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] 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 60f0bb7d..c5dd1b09 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm @@ -1489,7 +1489,7 @@ tcl::namespace::eval punk::imap4 { Returns the Tcl channel to use in subsequent calls to the API. Other API commands will return zero on success. e.g - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { % set chan [CONNECT mail.example.com] sock123aaa456789 % AUTH_PLAIN $chan user pass diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm index 46cd5668..b6b784f5 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm @@ -497,78 +497,6 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } - #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) - proc aliases {{glob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - set ns_mapped [string map {:: \uFFFF} $ns] - #puts stderr "aliases ns: $ns_mapped" - set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: - if {![string length [lindex $segments end]]} { - #special case for :: only include leading segment rather thatn {} {} - set segments [lrange $segments 0 end-1] - } - set segcount [llength $segments] ;#only match number of segments matching current ns - - - set all_aliases [interp aliases {}] - set matched [list] - foreach a $all_aliases { - #normalize with leading :: - if {![string match ::* $a]} { - set abs ::$a - } else { - set abs $a - } - - set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] - set acount [llength $asegs] - #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {($acount - 1) == $segcount} { - if {[lrange $asegs 0 end-1] eq $segments} { - if {[string match $glob [lindex $asegs end]]} { - #report this alias in the current namespace - even though there may be no matching command - lappend matched $a ;#add raw alias token which may or may not have leading :: - } - } - } - } - #set matched_abs [lsearch -all -inline $all_aliases $glob] - - return $matched - } - - proc alias {{aliasorglob ""} args} { - set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - if {[llength $args]} { - if {$aliasorglob in [interp aliases ""]} { - set existing [interp alias "" $aliasorglob] - puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" - } - if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { - #use empty string/whitespace as intention to delete alias - return [interp alias "" $aliasorglob ""] - } - return [interp alias "" $aliasorglob "" {*}$args] - } else { - if {![string length $aliasorglob]} { - set aliaslist [punk::lib::aliases] - puts -nonewline stderr $aliaslist - return - } - #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias - set target [interp alias "" $aliasorglob] - if {[llength $target]} { - return $target - } - - if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { - set aliaslist [punk::lib::aliases $aliasorglob] - puts -nonewline stderr $aliaslist - return - } - return [list] - } - } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -2242,7 +2170,51 @@ namespace eval punk::lib { } } + punk::args::define { + @id -id ::punk::lib::is_indexset + @cmd -name punk::lib::is_indexset\ + -summary\ + "Validate string is a comma-delimited 'indexset'."\ + -help\ + "Validate that a string is an 'indexset' + An indexset consists of a comma delimited list of indexes or index-ranges. + The indexes are 0-based. + Ranges must be specified with .. as the separator. + Common whitespace elements space,tab,newlines are ignored. + Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, + e.g end-2 or 2+2. + + see indexset_resolve" + @values -min 2 -max 2 + indexset -type string + } + proc is_indexset {indexset} { + #collapse internal whitespace (for basic whitespace set we allow) + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] + if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + return 0 + } + set ranges [split $indexset ,] + foreach r $ranges { + set validateindices [list] + set rposn [string first .. $r] + if {$rposn >= 0} { + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } else { + #'range' is just an index + set validateindices [list $r] + } + foreach v $validateindices { + if {$v eq "" || $v eq "end"} {continue} + if {[string is integer -strict $v]} {continue} + if {[catch {lindex {} $v}]} { + return 0 + } + } + } + return 1 + } #review - compare to IMAP4 methods of specifying ranges? punk::args::define { @id -id ::punk::lib::indexset_resolve @@ -2251,6 +2223,8 @@ namespace eval punk::lib { "Resolve an indexset to a list of integers based on supplied list or string length."\ -help\ "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. + e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 + An indexset consists of a comma delimited list of indexes or index-ranges. The indexes are 0-based. Ranges must be specified with .. as the separator. @@ -2258,27 +2232,30 @@ namespace eval punk::lib { Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. - end means the last page. - end-1 means the second last page. + end means the last item. + end-1 means the second last item. 0.. is the same as 0..end. - examples: + indexset examples: 1,3.. - output the page index 1 (2nd page) followed by all from index 3 to the end. + output the index 1 (2nd item) followed by all from index 3 to the end. + 'indexset_resolve 4 1,3..' -> 1 3 + 'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9 0-2,end - output the first 3 pages, and the last page. + output the first 3 indices, and the last index. end-1..0 - output the indexes in reverse order from 2nd last page to first page." + output the indexes in reverse order from 2nd last item to first item." @values -min 2 -max 2 numitems -type integer - indexset -type string + indexset -type indexset -help "comma delimited specification for indices to return" } proc indexset_resolve {numitems indexset} { - if {![string is integer -strict $numitems] || ![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] - } - set index_list [list] ;#list of actual indexes within the range + } + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace + set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] set index_list [list] foreach ipart $iparts { @@ -2286,7 +2263,7 @@ namespace eval punk::lib { set rposn [string first .. $ipart] if {$rposn>=0} { #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb + lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb set rawa [string trim $rawa] set rawb [string trim $rawb] if {$rawa eq ""} {set rawa 0} 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 f9dfaf56..e0532e41 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# 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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::libunknown 0 0.1] +#[manpage_begin punkshell_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-0.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.tm index 1ac6a836..e3f2cb16 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.tm @@ -7,6 +7,11 @@ tcl::namespace::eval punk::mix { package require punk::cap::handlers::templates ;#handler for templates cap punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap set t [time { if {[catch {punk::mix::templates::provider register *} errM]} { 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 da72bd9a..f3b54962 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 @@ -480,7 +480,7 @@ namespace eval punk::mix::cli { } #repotypes *could* be both git and fossil - so report both if so if {"git" in $repotypes} { - append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n + append result "\nGIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n if {[string length [set git_prog [auto_execok git]]]} { set git_remotes [exec {*}$git_prog remote -v] append result $git_remotes @@ -791,10 +791,10 @@ namespace eval punk::mix::cli { if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { - puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" $event targetset_end FAILED -note "could not copy $modulefile" } else { - puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" # -- --- --- --- --- --- $event targetset_end OK -note "zip modpod" } @@ -821,7 +821,7 @@ namespace eval punk::mix::cli { if {$tmfile_versionsegment eq $magicversion} { set versionfiledata "" if {![file exists $versionfile]} { - puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]" puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" set module_build_version "0.1" } else { @@ -830,7 +830,7 @@ namespace eval punk::mix::cli { set ln0 [lindex [split $versionfiledata \n] 0] set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] if {![util::is_valid_tm_version $ln0]} { - puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + puts stderr "ERROR:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]" exit 3 } set module_build_version $ln0 @@ -973,10 +973,10 @@ namespace eval punk::mix::cli { if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { - puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]" $event targetset_end FAILED -note "could not copy $modulefile" } else { - puts stderr "Copied tarjar module $modulefile to $target_module_dir" + puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]" # -- --- --- --- --- --- $event targetset_end OK -note "tarjar" } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm index 63b5335c..465d4f0b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm @@ -19,36 +19,39 @@ ##e.g package require frobz package require punk::cap - +namespace eval punk::mix::templates [list variable modulefile [info script]] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::templates { variable pkg punk::mix::templates variable cap_provider + variable decls [list] + + lappend decls [list punk.templates [list path templates pathtype module base [file dirname $modulefile] vendor punk]] + + lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? + + #only punk::templates is allowed to register a _multivendor path - review + #other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only + lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] + lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] + + + #we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! + #need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version + #perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) + #review - the job of this templates package is just to point to where the templates are located, not to specify how they're updated? + lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] + lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. + #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. namespace eval capsystem { if {[info commands capprovider.registration] eq ""} { punk::cap::class::interface_capprovider.registration create capprovider.registration oo::objdefine capprovider.registration { method get_declarations {} { - set decls [list] - lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? - - lappend decls [list punk.templates {path templates pathtype module vendor punk}] - #only punk::templates is allowed to register a _multivendor path - review - #other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only - lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] - lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] - - - #we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! - #need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version - #perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) - lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] - lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. - #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. - return $decls + return $::punk::mix::templates::decls } } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.1.tm new file mode 100644 index 00000000..9eb39a77 Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.1.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.2.tm new file mode 100644 index 00000000..ef6addb3 Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.2.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm index 84bb21c6..ae801db5 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::netbox 0 0.1.0] +#[manpage_begin punkshell_module_punk::netbox 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm index a60963a3..d686759c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::netbox::man 0 0.1.0] +#[manpage_begin punkshell_module_punk::netbox::man 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 3de09e5e..afb62a31 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -36,7 +36,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -172,7 +172,7 @@ tcl::namespace::eval punk::ns { #needed to use n/ to change to an oddly named namespace such as ":x" proc nsexists {nspath} { if {$nspath eq ""} {return 0} - set parts [nsparts $nspath] + set parts [nsparts_cached $nspath] if {[lindex $parts 0] ne ""} { #relative set ns_caller [uplevel 1 {::namespace current}] @@ -191,7 +191,7 @@ tcl::namespace::eval punk::ns { #approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection #WARNING: creates namespaces if they don't exist proc nseval_getscript {location} { - set parts [nsparts $location] + set parts [nsparts_cached $location] if {[lindex $parts 0] eq ""} { lset parts 0 :: } @@ -400,19 +400,185 @@ tcl::namespace::eval punk::ns { return [join $nonempty_segments ::] } + #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) + #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #nsparts will prefer leading colon (ie greedy on ::) + #This is important to support leading colon commands such as :/ + # ie ::punk:::jjj:::etc -> :: punk :jjj :etc + proc nsparts1 {nspath} { + set nspath [string map {:::: ::} $nspath] + set mapped [string map {:: \u0FFF} $nspath] + set parts [split $mapped \u0FFF] + #if {[lindex $parts end] eq ""} { + #} + return $parts + } + + + #Memory leak for systems that create and delete a lot of differently names namespaces/commands - review + #consider configuration option to disable for large long-running systems? + #re-code nsparts in c/zig to make a performant version and avoid caching? + variable nsparts_cache [dict create] + proc nsparts_cached {nspath} { + variable nsparts_cache + if {[dict exists $nsparts_cache $nspath]} { + return [dict get $nsparts_cache $nspath] + } + set parts [nsparts $nspath] + dict set nsparts_cache $nspath $parts + return $parts + } + #not that nsparts is insanely slow - but it's called frequently - hence nsparts_cached + #noticeable for example when calling punk::ns::aliases whilst in global namespaces. + proc nsparts {nspath} { + #note that if all of :, :ns and ns: are valid namespace names (and they technically are in Tcl) + #we get ambiguities if trying to join them. + #eg ::a:::b could be "::a: b" or "::a :b" + #however a::::b would unambiguously be "a: :b" + #and a:::::b could only be "a : b" + # a::::::b could be "a: : b" or "a : :b" + #(ambiguities on mod 3 == 0 number of colons only?) + #leading ::::x could be ": :x" - but it is probably commonly relied on in tcl scripts that this resolves to just ::x + #A consistent rule to avoid ambiguity would need to be + # "no leading/trailing colons in namespace names" + # or "no leading colons in namespace names (except bare colon)" + # or "no trailing colons in namespace names (except bare colon)" + # + #The no trailing version has more utility - (sorting of colon namespaces together) and would allow processing of runs of colons left-to-right + #There remains ambiguity in that a relative namespace involving leading colons can't always be distinguished from an absolute namespace. + #ie :::x could represent ":x" in absolute terms or ": x" as a relative path. + #as leading :: is the normal way to decide a namespace is absolute - this leaves no way of specifying a relative namespace if the next sub namespace is just ":" + # + #for no trailing colon + #number of intermediate colons cannot be a number in the sequence + #4,7,10,13,16,19,22... + #if it is - we must trip 2 colons + #4 x::::x -> x::x = x,x + #7 x:::::::x -> x:::::x = x,:,x + #10 x::::::::::x -> x::::::::x = x,:,:,x + + #after stripping 2 - valid nums are + #1 x:x (internal - part of ns) + #2 x::x + #3 x:: :x + #5 x:: : ::x + #6 x:: : :: :x + #8 x:: : :: : ::x + #9 x:: : :: : :: :x + #11 x:: : :: : :: : ::x + #12 x:: : :: : :: : :: :x + #14 x:: : :: : :: : :: : ::x + #15 x:: : :: : :: : :: : :: :x + #17 x:: : :: : :: : :: : :: : ::x + #18 x:: : :: : :: : :: : :: : :: :x + + if {$nspath eq ""} { + return "" + } + + set s 0 + set parts [list] + set p "" + set cend -1 + while {[regexp -start $s -indices {(:+)[^:]*} $nspath _all cindices]} { + lassign $cindices cstart cend + append p [string range $nspath $s $cstart-1] + set numcolons [expr {$cend - $cstart + 1}] + if {$numcolons == 1} { + #internal colon + append p : + set s [expr {$cend+1}] + continue + } elseif {$numcolons == 2} { + lappend parts $p + set p "" + set s [expr {$cend+1}] + continue + } elseif {($numcolons -1) % 3 == 0} { + set numcolons [expr {$numcolons -2}] + } + #assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence + if {$numcolons % 3 == 0} { + #if numcolons % 3 == 0 we have a leading colon left for next ns + #this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y + #we resolve with allowing leading colons only for each ns. + set singlec_count [expr {($numcolons /3) -1}] + if {$singlec_count > 0} { + lappend parts $p {*}[lrepeat $singlec_count :] + } else { + lappend parts $p + } + set p ":" + set s [expr {$cend+1}] + continue + } else { + set singlec_count [expr {(($numcolons +1)/3) -1}] + if {$singlec_count > 0} { + lappend parts $p {*}[lrepeat $singlec_count :] + } else { + lappend parts $p + } + set p "" + set s [expr {$cend+1}] + } + } + if {$cend < ([string length $nspath]-1)} { + lappend parts $p[string range $nspath $cend+1 end] + } else { + #trailing colons + set numcolons [expr {$cend - $cstart + 1}] + lappend parts $p + } + return $parts + } + + proc nsprefix {{nspath ""}} { + set prefixparts [lrange [nsparts_cached $nspath] 0 end-1] + if {[llength $prefixparts] == 1 && [lindex $prefixparts 0] eq ""} { + return :: + } + return [join $prefixparts ::] + } #REVIEW - the combination of nsprefix & nstail are designed to *almost* always be able to reassemble the input, and to be independent of what namespaces actually exist #The main difference being collapsing (or ignoring) repeated double-colons #we need to distinguish unprefixed from prefixed ie ::x vs x #There is an apparent inconsistency with nstail ::a:::x being able to return :x - #whereas nsprefix :::a will return just a + #whereas nsprefix :::a will return just ::a #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. # - #nsprefix is *somewhat* like 'namespace parent' execept that it is string based - ie no requirement for the namespaces to actually exist + #nsprefix is *somewhat* like 'namespace parent' except that it is string based - ie no requirement for the namespaces to actually exist # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. - proc nsprefix {{nspath ""}} { + #nsprefix is more like 'namespace qualifiers' - but can return the global namespace as :: instead of empty string. + proc nsprefix1 {{nspath ""}} { + #normalize the common case of leading :::: and also collapse any internal runs of 4 (there can be no namespace named as empty string - as this is reserved for global ns by Tcl) + + while {[regexp {::::} $nspath]} { + set nspath [string map {:::: ::} $nspath] + } + set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + #return [string trimright $rawprefix :] + } + } + #deprecated + proc nsprefix_orig {{nspath ""}} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] @@ -428,13 +594,19 @@ tcl::namespace::eval punk::ns { } } + proc nstail {nspath} { + return [lindex [nsparts_cached $nspath] end] + } + #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands #For most purposes 'namespace tail' is fine. - proc nstail {nspath args} { + proc nstail1 {nspath args} { #normalize the common case of :::: - set nspath [string map {:::: ::} $nspath] + while {[regexp {::::} $nspath]} { + set nspath [string map {:::: ::} $nspath] + } #it's unusual - but namespaces *can* have spaced in them. set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] @@ -454,28 +626,31 @@ tcl::namespace::eval punk::ns { #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. return [lindex $parts end] } - - #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) - #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them - #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string - #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. - #nsparts will prefer leading colon (ie greedy on ::) - #This is important to support leading colon commands such as :/ - # ie ::punk:::jjj:::etc -> :: punk :jjj :etc - proc nsparts {nspath} { + #deprecated + proc nstail_orig {nspath args} { + #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] + #it's unusual - but namespaces *can* have spaced in them. set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] - #if {[lindex $parts end] eq ""} { - #} - return $parts + + set defaults [list -strict 0] + set opts [dict merge $defaults $args] + set strict [dict get $opts -strict] + + if {$strict} { + foreach p $parts { + if {[string match :* $p]} { + error "nstail unpaired colon ':' in $nspath" + } + } + } + + #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. + return [lindex $parts end] } + #tcl 8.x has creative writing var weirdness.. tcl 9 is likely to differ proc nsvars {{nsglob "*"}} { set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $nsglob]] @@ -484,7 +659,7 @@ tcl::namespace::eval punk::ns { set searchns [nsprefix $ns_absolute] ;#the ns within which we want to searchns set searchall [nsjoin $searchns *] ;#will correctly form ::* or ::childns::* - set nsparts [nsparts $searchns] + set nsparts [nsparts_cached $searchns] set weird_ns 0 if {[lsearch $nsparts :*] >=0} { set weird_ns 1 @@ -522,7 +697,7 @@ tcl::namespace::eval punk::ns { proc nsglob_as_re {glob} { #any segment that is not just * must match exactly one segment in the path set pats [list] - foreach seg [nsparts $glob] { + foreach seg [nsparts_cached $glob] { if {$seg eq ""} { set seg "" } @@ -609,7 +784,7 @@ tcl::namespace::eval punk::ns { set base "" set tailparts [list] if {$CALLDEPTH == 0} { - set parts [nsparts $ns_absolute] + set parts [nsparts_cached $ns_absolute] lset parts 0 :: set idx 0 if {$has_globchars} { @@ -635,8 +810,10 @@ tcl::namespace::eval punk::ns { #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] + #jjj #set allchildren [lsort [nseval $base [list ::namespace children]]] - set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] + #set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] + set allchildren [lsort [nseval $base [list ::namespace children]]] #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" @@ -767,18 +944,22 @@ tcl::namespace::eval punk::ns { } + #review ooc vs classmethod ooo vs objectmethod ? punk::args::define { @id -id ::punk::ns::Cmark @cmd -name punk::ns::Cmark @leaders - type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { - oo " symbol \u25c6" - ooc " symbol \u25c7" - ooo " symbol \u25c8" - punkargs " symbol \u24d8" - ensemble " symbol \u24ba" - native " symbol \u24c3" - unknown " symbol \u2370" + type -choices {oo ooc classmethod coremethod ooo objectmethod punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + classmethod " symbol \u25c7" + coremethod " symbol \u25c9" + ooo " symbol \u25c8" + objectmethod " symbol \u25c8" + punkargs " symbol \u24d8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" } @opts @values -min 0 -max -1 @@ -794,23 +975,134 @@ tcl::namespace::eval punk::ns { return; #should be unreachable - parse should raise usage error } set type [lindex $args 0] - set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set type [tcl::prefix::match -error "" {oo ooc classmethod coremethod ooo objectmethod punkargs ensemble native unknown} $type] set ansinames [lrange $args 1 end] switch -- $type { - oo - ooc - ooo - punkargs - ensemble - native - unknown {} + oo - ooc - classmethod - coremethod - ooo - objectmethod - punkargs - ensemble - native - unknown {} default { #punk::args::usage ::punk::ns::Cmark punk::args::parse $args withid ::punk::ns::Cmark return; #should be unreachable - parse should raise usage error } } - set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] + set marks [dict create oo \u25c6 ooc \u25c7 classmethod \u25c7 coremethod \u25c9 ooo \u25c8 objectmethod \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { return [dict get $marks $type] } } + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{tailglob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + + set ns_segments [nsparts_cached $ns] ;#include empty string before leading :: + if {![string length [lindex $ns_segments end]]} { + #special case for :: only include leading segment rather than {} {} + set ns_segments [lrange $ns_segments 0 end-1] + } + set segcount [llength $ns_segments] ;#only match number of segments matching current ns + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + if {[string match ${ns}* $abs] && [string match *::$tailglob $abs]} { + #Note that string match *::$tailglob $abs is not a proper match for all possible tailglobs + #It reduces our search space to avoid too many 'nsparts' calls, but has false positives - still need to match tailglob to last segment only in the loop. + set asegs [nsparts_cached $abs] + #set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $ns_segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $ns_segments} { + if {[string match $tailglob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + return $matched + } + proc aliases1 {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::ns::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::ns::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } #REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc.. punk::args::define { @@ -1316,6 +1608,14 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } + punk::args::define { + @id -id ::punk::ns::cmdtype + @cmd -name punk::ns::cmdtype -help\ + "" + @values -min 1 -max 1 + cmd -help\ + "namespace-relative or namespace-absolute path of command." + } #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc @@ -1323,7 +1623,7 @@ tcl::namespace::eval punk::ns { #it is not desirable to do a partial cmdtype support here proc cmdtype {cmd} { #set cmd [namespace which $cmd] ;#will return empty result for empty string command or command such as :x or any command that doesn't exist - set fqcmd [namespace which $cmd] ;#will resolve for example 'namespace path' reachable commands + set fqcmd [uplevel 1 [list ::namespace which $cmd]] ;#will resolve for example 'namespace path' reachable commands if {$fqcmd eq ""} { #e.g ::ns:::x will return empty result from namespace which even if :x is a command in ::ns set where [nsprefix $cmd] @@ -1338,7 +1638,7 @@ tcl::namespace::eval punk::ns { set what [nstail $fqcmd] } #ensure we con't call 'namespace eval' on a nonexistent ns and create cruft namespaces - set parts [nsparts $where] + set parts [nsparts_cached $where] if {[lsearch $parts :*] > -1} { set weird_ns 1 if {![nsexists $where]} { @@ -1356,11 +1656,12 @@ tcl::namespace::eval punk::ns { if {[interp issafe]} { #todo - weird_ns if {[catch {namespace eval $where [list ::tcl::info::cmdtype $what]} result]} { - if {[info commands ::cmdtype] ne ""} { - #hack - look for an alias that may have been specifically enabled to bring this back - tailcall ::cmdtype $cmd + #hack - look for an alias that may have been specifically enabled to bring this back + #review - why this name? + if {[info commands ::info_cmdtype] ne ""} { + return [namespace eval $where [list ::info_cmdtype $what]] } - return na + #fall-through to below } else { return $result } @@ -1370,19 +1671,103 @@ tcl::namespace::eval punk::ns { if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { return notfound } else { - return [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] + set tclcmdtype [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] + if {$tclcmdtype eq "object"} { + if {[nseval_ifexists $where [list ::info object isa class $what]]} { + set tclcmdtype ooclass + } else { + set tclcmdtype ooobject + } + } } } else { if {[namespace eval $where [list ::info commands $what]] eq ""} { #e.g parray if it hasn't yet been called (an auto_path loaded command) return notfound } else { - tailcall namespace eval $where [list ::tcl::info::cmdtype $what] + set tclcmdtype [namespace eval $where [list ::tcl::info::cmdtype $what]] + if {$tclcmdtype eq "object"} { + if {[namespace eval $where [list ::info object isa class $what]]} { + set tclcmdtype ooclass + } else { + set tclcmdtype ooobject + } + } + } + } + return $tclcmdtype + } + # CCC + set locationparts [nsparts_cached $where] + set weird_ns 0 + set c "" + if {[lsearch $locationparts :*] >= 0} { + set weird_ns 1 + } + if {$weird_ns} { + if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { + return notfound + } + } else { + if {[namespace eval $where [list ::info commands $what]] eq ""} { + #e.g parray if it hasn't yet been called (an auto_path loaded command) + return notfound + } + } + if {$weird_ns} { + set cmdorigin [nseval_ifexists $where [list ::namespace origin $what]] + } else { + set cmdorigin [namespace eval $where [list ::namespace origin $what]] + } + if {[nsprefix $cmdorigin] ne $where} { + return import + } + if {$weird_ns} { + set c [nseval_ifexists $where [list ::info commands $what]] + } else { + set c [tcl::namespace::eval $where [list ::info commands $what]] + } + if {$c ne ""} { + #if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} {} + set script [string map [list %w% $what] { + ::if {![::catch [::list ::namespace ensemble configure "%w%"]]} { + ::return ensemble + } elseif {[::info object isa class "%w%"]} { + ::return ooclass + } elseif {[::info object isa object "%w%"]} { + ::return ooobject } + }] + if {$weird_ns} { + set o [nseval_ifexists $where $script] + } else { + set o [tcl::namespace::eval $where $script] + } + if {$o ne ""} { + return $o } + } else { + return notfound + } + if {$weird_ns} { + set p [nseval_ifexists $where [list ::info procs $what]] + } else { + set p [tcl::namespace::eval $where [list ::info procs $what]] + } + if {$p ne ""} { + return proc + } + + #punk::ns::aliases last - as probably slowest + if {$weird_ns} { + set a [nseval_ifexists $where [list ::punk::ns::aliases $what]] + } else { + set a [tcl::namespace::eval $where [list ::punk::ns::aliases $what]] + } + if {$a ne ""} { + return alias } - #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller - #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob @@ -1391,7 +1776,6 @@ tcl::namespace::eval punk::ns { #glob chars in the path will result in multiple namespaces being matched #e.g ::tcl::*::d* will match commands beginning with d and child namespaces beginning with d in any namespaces 1 below ::tcl proc get_ns_dicts {fq_glob args} { - #JMN #puts stderr "get_ns_dicts $fq_glob" set glob_is_absolute [expr {[string match ::* $fq_glob]}] if {!$glob_is_absolute} { @@ -1456,9 +1840,9 @@ tcl::namespace::eval punk::ns { } -#JMN +# CCC set location $ch - set locationparts [nsparts $location] + set locationparts [nsparts_cached $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { set weird_ns 1 @@ -1537,11 +1921,11 @@ tcl::namespace::eval punk::ns { set allundetermined [list] set interp_aliases [interp aliases ""] #use aliases glob - because aliases can be present with or without leading :: - #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases + #NOTE: alias may not have matching command in the relevant namespace (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::ns::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::ns::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] @@ -1567,144 +1951,107 @@ tcl::namespace::eval punk::ns { # lappend allaliases $cmd #} set ctype [cmdtype ${location}::$cmd] - switch -- $ctype { - na { - if {$weird_ns} { - set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] - } else { - set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] - } - if {[nsprefix $cmdorigin] ne $location} { - #import - lappend allimported $cmd - set origin_location [nsprefix $cmdorigin] - } else { - set origin_location $location - } - #tcl 8.6 (info cmdtype unavailable) - #todo - use catch tcl::unsupported::corotype to see if coroutine - set originlocationparts [nsparts $origin_location] - set weird_origin 0 - if {[lsearch $originlocationparts :*] >= 0} { - set weird_origin 1 - } - if {$weird_origin} { - if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd - } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { - lappend allooobjects $cmd - if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { - lappend allooclasses $cmd - } - } else { - - } - } else { - if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd - } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { - lappend allooobjects $cmd - if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { - lappend allooclasses $cmd - } - } else { - + if {$ctype eq "import"} { + if {$weird_ns} { + set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] + } else { + set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] + } + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #ie we don't need to follow a chain of 'imported' results. + set origin_location [nsprefix $cmdorigin] + set origin_cmd [nstail $cmdorigin] + + set originlocationparts [nsparts_cached $origin_location] + set weird_origin 0 + if {[lsearch $originlocationparts :*] >= 0} { + set weird_origin 1 + } + if {$weird_origin} { + set mixedtype i-[nseval_ifexists $origin_location [list ::punk::ns::cmdtype $origin_cmd]] + } else { + set mixedtype i-[namespace eval $origin_location [list ::punk::ns::cmdtype $origin_cmd]] + } + lappend allimported $cmd + } else { + set mixedtype $ctype + } + #assert mixedtype != import + #review - we don't have a way to mark as both native and ensemble + switch -- $mixedtype { + i-native - native { + lappend allnative $cmd + } + i-ensemble - ensemble { + lappend allensembles $cmd + } + i-alias - alias { + #review + lappend allaliases $cmd + } + i-object - object { + #punk::ns::cmdtype will return ooobject or ooclass directly + if {[info object isa object ${location}::$cmd]} { + lappend allooobjects $cmd + if {[info object isa class ${location}::$cmd]} { + lappend allooclasses $cmd } } } + i-ooobject - ooobject { + lappend allooobjects $cmd + } + i-ooclass - ooclass { + lappend allooclasses $cmd + } + i-privateObject - privateObject { + lappend allooobjects $cmd + lappend allooprivateobjects $cmd + } + i-privateClass - privateClass { + lappend allooobjects $cmd + lappend allooprivateclasses $cmd + } + i-interp - interp { + lappend allinterps $cmd + } + i-coroutine - coroutine { + lappend allcoroutines $cmd + } + i-zlibStream - zlibStream { + lappend allzlibstreams $cmd + } default { - if {$ctype eq "import"} { - if {$weird_ns} { - set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] - } else { - set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] - } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source - #ie we don't need to follow a chain of 'imported' results. - set origin_location [nsprefix $cmdorigin] - set origin_cmd [nstail $cmdorigin] - - set originlocationparts [nsparts $origin_location] - set weird_origin 0 - if {[lsearch $originlocationparts :*] >= 0} { - set weird_origin 1 - } - if {$weird_origin} { - set mixedtype i-[nseval_ifexists $origin_location [list ::tcl::info::cmdtype $origin_cmd]] - } else { - set mixedtype i-[namespace eval $origin_location [list ::tcl::info::cmdtype $origin_cmd]] - } - lappend allimported $cmd - } else { - set mixedtype $ctype - } - #assert mixedtype != import - #review - we don't have a way to mark as both native and ensemble - switch -- $mixedtype { - i-native - native { - lappend allnative $cmd - } - i-ensemble - ensemble { - lappend allensembles $cmd - } - i-alias - alias { - #review - lappend allaliases $cmd - } - i-object - object { - if {[info object isa object ${location}::$cmd]} { - lappend allooobjects $cmd - if {[info object isa class ${location}::$cmd]} { - lappend allooclasses $cmd - } - } - } - i-privateObject - privateObject { - lappend allooobjects $cmd - lappend allooprivateobjects $cmd - } - i-privateClass - privateClass { - lappend allooobjects $cmd - lappend allooprivateclasses $cmd - } - i-interp - interp { - lappend allinterps $cmd - } - i-coroutine - coroutine { - lappend allcoroutines $cmd - } - i-zlibStream - zlibStream { - lappend allzlibstreams $cmd - } - default { - #there may be other registered types - #(extensible with Tcl_RegisterCommandTypeName) - lappend allothers $cmd - } - - } - + #there may be other registered types + #(extensible with Tcl_RegisterCommandTypeName) + lappend allothers $cmd } } - #JMN TODO - if {[catch { - if {$cmd eq ""} { - #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. - set nsorigin [namespace origin ${location}::] - } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] - } else { - set nsorigin [namespace origin [nsjoin $location $cmd]] - } - } errM]} { - puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" - puts stderr "error message: $errM" - lappend allundetermined $cmd - } else { - if {[nsprefix $nsorigin] ne $location} { - lappend allimported $cmd - } - } + #JMN TODO? + #if {[catch { + # #if {$cmd eq ""} { + # # #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. + # # set nsorigin [namespace origin ${location}::] + # #} elseif {[string match :* $cmd]} { + # # set nsorigin [nseval $location "::namespace origin $cmd"] + # #} else { + # # set nsorigin [namespace origin [nsjoin $location $cmd]] + # #} + # set locparts [nsparts_cached $location] + # if {[lsearch $locparts :*] >=0 || [string match :* $cmd]} { + # set nsorigin [nseval $location [list namespace origin $cmd]] + # } else { + # set nsorigin [namespace origin [nsjoin $location $cmd]] + # } + #} errM]} { + # puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" + # puts stderr "error message: $errM" + # lappend allundetermined $cmd + #} else { + # if {[nsprefix $nsorigin] ne $location} { + # lappend allimported $cmd + # } + #} } if {$glob ne "*"} { set childtailmatches [lsearch -all -inline $childtails $glob] @@ -1712,7 +2059,8 @@ tcl::namespace::eval punk::ns { set exported [lsearch -all -inline $allexported $glob] set procs [lsearch -all -inline $allprocs $glob] - #set aliases [lsearch -all -inline $allaliases $glob] + # ccc + set aliases [lsearch -all -inline $allaliases $glob] set ensembles [lsearch -all -inline $allensembles $glob] set native [lsearch -all -inline $allnative $glob] set coroutines [lsearch -all -inline $allcoroutines $glob] @@ -1729,7 +2077,8 @@ tcl::namespace::eval punk::ns { #set fqchildren $allchildren set exported $allexported set procs $allprocs - #set aliases $allaliases + # ccc + set aliases $allaliases set ensembles $allensembles set native $allnative set coroutines $allcoroutines @@ -1765,54 +2114,104 @@ tcl::namespace::eval punk::ns { if {$has_punkargs || $has_tepam} { set ns_updated [dict create] foreach c $commands { - if {$c in $imported} { - set fq [namespace origin [nsjoin $location $c]] - } elseif {$c in $aliases} { + set found_documentation 0 + #we first need to check if there is direct documentation for the command at this location, before diverting to examine the target of imports/aliases for docs + if {$has_punkargs} { + set id [nsjoin $location $c] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } + if {[::punk::args::id_exists $id]} { + lappend usageinfo $c + set found_documentation 1 + } + } + + + if {!$found_documentation && $c in $aliases} { + #could be an alias in $location, or an imported alias + #TODO - use which_alias ? - set tgt [interp alias "" [nsjoin $location $c]] + if {$c in $imported} { + if {$weird_ns} { + set fq [nseval $location [list namespace origin $c]] + } else { + set fq [namespace origin [nsjoin $location $c]] + } + } else { + set fq [nsjoin $location $c] + } + + set tgt [interp alias "" $fq] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft $fq :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options + set id [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) if {[string match ::* $word1]} { - set fq $word1 + set id $word1 } else { - set fq ::$word1 + set id ::$word1 } } - } else { - set fq [nsjoin $location $c] - } - if {$has_punkargs} { - #set id [string trimleft $fq :] - set id $fq - set id_ns [namespace qualifiers $id] - if {![dict exists $ns_updated $id_ns]} { - #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" - punk::args::update_definitions [list $id_ns] - dict set ns_updated $id_ns 1 - } if {[::punk::args::id_exists $id]} { lappend usageinfo $c - } else { - if {$has_tepam} { - if {$fq in $::tepam::ProcedureList} { - lappend usageinfo $c - } - } + set found_documentation 1 } + #todo - alias to an alias + #e.g n/new jjj + # interp alias "" ::jjj::corp2 "" ::corp + #todo -pseudocode + #cmdwhich id + #while origin ne whichtype && origintype eq "alias" { + # if id_exists $origin { + # lappend usageinfo $c; set found_documentation 1 + # break + # } + # cmdwhich id + #} + + # CCC + #or just use punk::ns::cmdinfo + } else { + #all non-alias + if {!$found_documentation && $has_punkargs && $c in $imported} { + if {$weird_ns} { + set fq [nseval $location [list namespace origin $c]] + } else { + set fq [namespace origin [nsjoin $location $c]] + } + + #set id [string trimleft $fq :] + set id $fq + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } + if {[::punk::args::id_exists $id]} { + lappend usageinfo $c + set found_documentation 1 + } + } + } + if {!$found_documentation && $has_tepam} { + set fq [namespace origin [nsjoin $location $c]] if {$fq in $::tepam::ProcedureList} { lappend usageinfo $c } } + } } #catch {package require natsort} @@ -1947,99 +2346,6 @@ tcl::namespace::eval punk::ns { #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { - ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 - } - if {![llength $args]} { - lappend args * - } - ::foreach search $args { - ::if {$ci > [::llength $colors]-1} { - ::set ci 0 - } - ::if {$ci == 0 || $do_raw} { - ::set col "" - ::set rst "" - } else { - ::set col [a+ [::lindex $colors $ci] bold] - ::set rst [a+] - } - ::incr ci ;#colourindex - #inspect -label search $search - - ::if {![::llength $search]} { - ::set base $commandns - ::set what "*" - } else { - ::if {[::string match ::* $search]} { - ::set base [::punk::ns::nsprefix $search] - ::set what [::punk::ns::nstail $search] - } else { - ::set base $commandns - ::set what $search - } - } - set weird_ns 0 - if {[string match *:::* $base]} { - set weird_ns 1 - } - #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created - if {$weird_ns} { - ::if {![nsexists $base]} { - ::continue - } - #info commands can't glob with weird_ns prefix - puts ">>> base: $base what: $what" - ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { - set _all [uplevel 1 [list ::info commands]] - set _matches [list] - foreach _a $_all { - set _c [uplevel 1 [list ::namespace which $_a]] - if {[::string match ${loc}::${what} $_c]} { - ::lappend _matches $_a - } - } - return $_matches - }} $base $what ]] - } else { - ::if {![::tcl::namespace::exists $base]} { - ::continue - } - ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] - } - ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] - foreach c $all_ns_tails { - ::if {$do_raw} { - ::lappend commandlist [::list $c $c] - } else { - ::lappend commandlist [::list $c $col[::list $c]$rst] - } - } - } - set commandlist [lsort -index 0 $commandlist] - set results [list] - foreach pair $commandlist { - lappend results [lindex $pair 1] - } - #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) - #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - if {![llength $results]} { - return {} - } else { - return [join $results \n]\n - } - } - interp alias {} nscommands {} punk::ns::nscommands - interp alias {} nscommands1 {} .= ,'ok'@0.= { @@ -2114,19 +2420,19 @@ tcl::namespace::eval punk::ns { set subcommand_dict [dict create] set commands [list] - set nscommands [list] + set ns_commands [list] if {[llength [dict get $ensembleinfo -subcommands]]} { #set exportspecs [namespace eval $ns {namespace export}] #foreach pat $exportspecs { - # lappend nscommands {*}[info commands ${ns}::$pat] + # lappend ns_commands {*}[info commands ${ns}::$pat] #} #when using -subcommands, even unexported commands are available - set nscommands [info commands ${ns}::*] + set ns_commands [info commands ${ns}::*] foreach sub [dict get $ensembleinfo -subcommands] { if {[dict exists $map $sub]} { #-map takes precence over same name exported from -namespace dict set subcommand_dict $sub [dict get $map $sub] - } elseif {"${ns}::$sub" in $nscommands} { + } elseif {"${ns}::$sub" in $ns_commands} { dict set subcommand_dict $sub ${ns}::$sub } else { #subcommand probably supplied via -unknown handler? @@ -2139,9 +2445,9 @@ tcl::namespace::eval punk::ns { } else { set exportspecs [namespace eval $ns {namespace export}] foreach pat $exportspecs { - lappend nscommands {*}[info commands ${ns}::$pat] + lappend ns_commands {*}[info commands ${ns}::$pat] } - foreach fqc $nscommands { + foreach fqc $ns_commands { dict set subcommand_dict [namespace tail $fqc] $fqc } } @@ -2153,30 +2459,224 @@ tcl::namespace::eval punk::ns { } } - punk::args::define { - @id -id ::punk::ns::resolve_command - @cmd -name punk::ns::resolve_command -help\ - "Return a dict with command resolution info" - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 + proc nscommands {args} { + set commandns [uplevel 1 [list ::namespace current]] + set commandlist [::list] + #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + set colors [::list none cyan yellow green] + set ci 0 ;#colourindex + set do_raw 0 + if {[::set posn [::lsearch $args -raw]] >= 0} { + ::set args [::lreplace $args $posn $posn] + ::set do_raw 1 + } + if {![llength $args]} { + lappend args * + } + ::foreach search $args { + ::if {$ci > [::llength $colors]-1} { + ::set ci 0 + } + ::if {$ci == 0 || $do_raw} { + ::set col "" + ::set rst "" + } else { + ::set col [a+ [::lindex $colors $ci] bold] + ::set rst [a+] + } + ::incr ci ;#colourindex + #inspect -label search $search + + ::if {![::llength $search]} { + ::set base $commandns + ::set what "*" + } else { + ::if {[::string match ::* $search]} { + ::set base [::punk::ns::nsprefix $search] + ::set what [::punk::ns::nstail $search] + } else { + ::set base $commandns + ::set what $search + } + } + set weird_ns 0 + if {[string match *:::* $base]} { + set weird_ns 1 + } + #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created + if {$weird_ns} { + ::if {![nsexists $base]} { + ::continue + } + #info commands can't glob with weird_ns prefix + puts ">>> base: $base what: $what" + ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { + set _all [uplevel 1 [list ::info commands]] + set _matches [list] + foreach _a $_all { + set _c [uplevel 1 [list ::namespace which $_a]] + if {[::string match ${loc}::${what} $_c]} { + ::lappend _matches $_a + } + } + return $_matches + }} $base $what ]] + } else { + ::if {![::tcl::namespace::exists $base]} { + ::continue + } + ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] + } + ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] + foreach c $all_ns_tails { + ::if {$do_raw} { + ::lappend commandlist [::list $c $c] + } else { + ::lappend commandlist [::list $c $col[::list $c]$rst] + } + } + } + set commandlist [lsort -index 0 $commandlist] + set results [list] + foreach pair $commandlist { + lappend results [lindex $pair 1] + } + #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) + #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. + if {![llength $results]} { + return {} + } else { + return [join $results \n]\n + } } - proc resolve_command {args} { - if {[llength $args] == 0} { - return + interp alias {} nscommands {} punk::ns::nscommands + proc nscommandlist {{ns *}} { + set nsparts [nsparts_cached $ns] + set tail [lindex $nsparts end] + if {[string match ::* $ns]} { + if {[regexp {\*} $tail]} { + set targetns [nsprefix $ns] + set search $tail + } else { + set targetns $ns + set search * + } + } else { + set nscaller [uplevel 1 [list ::namespace current]] + if {[regexp {\*} $tail]} { + if {[nsprefix $ns] ne ""} { + set targetns [nsjoin $nscaller [nsprefix $ns]] + } else { + set targetns $nscaller + } + set search $tail + } else { + set targetns [nsjoin $nscaller $ns] + set search * + } } - set querycommand [lindex $args 0] - set queryargs [lrange $args 1 end] + if {![string match "*:::*" $targetns]} { + #ordinary namespace path - can use standard info commands with glob + set all_cmds [info commands [::punk::ns::nsjoin $targetns $search]] + set all_cmds [lmap v $all_cmds {namespace tail $v}] + return [lsort $all_cmds] + } else { + # 'unwisely' named ns: cannot rely on 'info commands ' + # running 'info commands' from within the namespace will return all commands resolvable from the space - not just those that are defined there. + # this includes global commands and those supplied by namespaces configured in 'namespace path' + # we can't just use a 'diff' of what commands are visible compared to those that are available from global or 'namespace path' + # because there may be overrides/duplicates that are present in the namespace bing searched. + # we rely on the *apparent* (undocumented?) fact that in the list of commands resolved by 'info commands', + # the commands that are actually in the namespace are listed first. + # This means we can stop processing on the first command for which 'namespace which' shows another namespace. + set remaining [nseval_ifexists $targetns [list apply {{loc} { + ::set _visiblecommands [::uplevel 1 [::list ::info commands]] + ::set _matches [::list] + ::foreach _v $_visiblecommands { + ::set _commandns [::uplevel 1 [::list ::namespace which $_v]] + ::if {[::string match ${loc}::* $_commandns]} { + ::lappend _matches $_v + } else { + #abort at first in list that resolves from some other namespace + break + } + } + ::return $_matches + }} $targetns]] + if {$search ne "*"} { + set remaining [lsearch -all -inline -glob $remaining $search] + } + return [lsort $remaining] + } + + } + interp alias {} nscommandlist {} punk::ns::nscommandlist + + + punk::args::define { + @id -id ::punk::ns::cmdwhich + @cmd -name punk::ns::cmdwhich\ + -summary\ + "Return a dict with keys origin, origintype, which, whichtype."\ + -help\ + "Return a dict with keys origin, origintype, which, whichtype. + 'which' represents the full namespace path of the resolved command. + The command is first resolved by Tcl by looking for it in the namespace + in which whichcmd was run, then at each of any entries configured with + 'namespace path' for that namespace, and finally in the global namespace. + 'origin' represents the full namespace path of where the command represented + by 'which' points to, or the target of the alias if 'whichtype' is 'alias'. + This differs from the Tcl 'namespace origin' result. + In the usual case of a simple proc in a namespace, + 'which' and 'origin' will be the same, but for an imported command or an + alias - 'origin' could be a different location, or a different name, or in + the case of an alias, have additional curried-in arguments. + + Note that 'origin' is not necessarily the earliest point in the chain. + For example an alias in one namespace could be imported into another. + This may give a result with origintype alias and whichtype import. + cmdwhich would have to be called on the origin value to inspect further. + An alias pointing to a target with curried-in arguments will show an + origintype of 'script' - whereas an alias to a single word will show the + origintype of the target command. + + An alias that has been renamed into another namespace does not have full + ability to be introspected easily by Tcl. In such a case 'which' and 'origin' + may show the same target, both with type 'alias'. Another mechanism such as + pattern::which_alias may need to be used to inspect the origin alias further. + Such mechanisms may involve actually running the command - which can be risky + to do on arbitrary commands, and so is not automated. + + An alias may point to a command that is runnable, but not available for + introspection by the current interp (e.g in safe interps). + Such an alias may return an origintype of 'notfound', just as a nonexistant + command or alias target would." + + @values -min 1 -max 1 + cmd -multiple 0 -optional 0 + } + #REVIEW! todo - change 'origin' in resultdict to 'next'? + #(origin too similar to 'namespace origin' - but we are using it for that as well as alias target) + proc cmdwhich {querycommand} { set nscaller [uplevel 1 [list ::namespace current]] - #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented + #puts "cmdwhich nscaller: $nscaller" if {[string match ::* $querycommand]} { - set targetns [nsprefix $querycommand] - set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global - #when arginfo given a fully qualified path - we only want an answer for that exact command - set nscommands [info commands ${targetns}::*] - if {[lsearch -exact $nscommands $querycommand] >= 0} { + #absolute + set targetns [nsprefix $querycommand] + set name [nstail $querycommand] + set targetparts [nsparts_cached $targetns] + if {[lsearch $targetparts :*] >=0} { + # + #for an *unwisely* named ns - info commands ${targetns}::* will not work + set ns_commands [nscommandlist $targetns] ;#results are tails only + set ns_commands_fq [lmap v $ns_commands {string cat $targetns ::$v}] + + } else { + set ns_commands_fq [info commands ${targetns}::*] ;#results remain fully qualified + } + if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths if {[catch { set origin [nseval_ifexists $targetns [list ::namespace origin $name]] @@ -2192,7 +2692,7 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #relative comandpath + #relative commandpath if {[string match (autodef)* $querycommand]} { #pass through - should be found with id lookup set origin $querycommand @@ -2202,7 +2702,7 @@ tcl::namespace::eval punk::ns { set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] set targetns [nsprefix $thispath] set name [nstail $thispath] - set targetparts [nsparts $targetns] + set targetparts [nsparts_cached $targetns] if {[lsearch $targetparts :*] >=0} { #weird ns set valid_ns [nsexists $targetns] @@ -2224,72 +2724,346 @@ tcl::namespace::eval punk::ns { #namespace as relative to current doesn't seem to exist #Tcl would also attempt to resolve as global if {$nscaller ne "::"} { - return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] } set origin $querycommand set resolved $querycommand - } } } - #ns::cmdtype only detects alias type on 8.7+? - set initial_cmdtype [punk::ns::cmdtype $origin] - switch -- $initial_cmdtype { - na - alias { - #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) - set tgt [interp alias "" $origin] - if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft $origin :]] - } - #first word of tgt may be namespace relative or absolute - if {$tgt ne ""} { - set word1 [lindex $tgt 0] - if {$word1 eq "punk::mix::base::_cli"} { - #special case for punk deck - REVIEW - #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set targetword [lindex $tgt end] - } else { - #todo - alias may have prefilled some leading args - so usage report should reflect that??? - #(possible curried arguments) - #review - curried arguments could be for ensembles! - set targetword $word1 - return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] - } - - + set origintype [punk::ns::cmdtype $origin] + set whichtype [punk::ns::cmdtype $resolved] + + if {$resolved eq $origin && $origintype in {na alias} && $whichtype in {na alias}} { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + #even if it was marked as na (8.6?) - it's an alias + set whichtype alias + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] set origin $targetword #retest cmdtype on modified origin - set cmdtype [punk::ns::cmdtype $origin] + set origintype [punk::ns::cmdtype $origin] } else { - set cmdtype $initial_cmdtype + #alias may have some curried-in arguments + if {[llength $tgt] == 1} { + set whichinfo [uplevel 1 [list cmdwhich $tgt]] + set origin [dict get $whichinfo origin] + set origintype [dict get $whichinfo origintype] + } else { + set origin $tgt ;#multiword origin + set origintype script + } } - if {$cmdtype eq "na"} { + } else { + #not an alias + if {$whichtype eq "na"} { #tcl 8.6 if {[info object isa object $origin]} { - set cmdtype "object" + if {[info object isa class $origin]} { + set origintype "ooclass" + set whichtype "ooclass" + } else { + set origintype "ooobject" + set whichtype "ooobject" + } } } } - default { - set cmdtype $initial_cmdtype - } } - punk::args::update_definitions [list [namespace qualifiers $origin]] - set id $origin - + return [dict create origin $origin origintype $origintype which $resolved whichtype $whichtype] + } - #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict - if {[punk::args::id_exists $id] && ![llength $queryargs]} { - return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + #review - should be in punk::args? + proc generate_autodef {args} { + set cmd [lindex $args 0] + if {[string match (autodef)* $cmd]} { + set cmd [string range $cmd 9 end] } - - #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" - if {![punk::args::id_exists $origin]} { - if {[namespace ensemble exists $origin]} { - #review + set queryargs [lrange $args 1 end] + set cinfo [punk::ns::cmdwhich $cmd] + set origin [dict get $cinfo origin] + set cmdtype [dict get $cinfo origintype] + switch -- $cmdtype { + script - alias { + #don't generate (autodef) on plain alias or curried alias (script) - let them resolve + } + object - ooobject - ooclass { + #class is also an object + #todo -mixins etc etc + set class [info object class $origin] + #the call: info object methods -all + # seems to do the right thing as far as hiding unexported methods, and showing things like destroy + # - which don't seem to be otherwise easily introspectable + set public_methods [info object methods $origin -all] + #set class_methods [info class methods $class] + #set object_methods [info object methods $origin] + + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] + if {$c1 in $public_methods} { + switch -- $c1 { + new { + set constructorinfo [info class constructor $origin] + set arglist [lindex $constructorinfo 0] + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} new" + @cmd -name "${$origin} new"\ + -summary\ + "Create new object instance."\ + -help\ + "create object with autogenerated command name. + Arguments are passed to the constructor." + @values + }] + set i 0 + foreach a $arglist { + if {[llength $a] == 1} { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } else { + append argdef \n "[lindex $a 0] -default [lindex $a 1]" + } + incr i + } + punk::args::define $argdef + set queryargs_remaining [lrange $queryargs 1 end] + } + create { + set constructorinfo [info class constructor $origin] + set arglist [lindex $constructorinfo 0] + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} create" + @cmd -name "${$origin} create"\ + -summary\ + "Create new object instance with specified command name."\ + -help\ + "create object with specified command name. + Arguments following objectName are passed to the constructor." + @values -min 1 + objectName -type string -help\ + "possibly namespaced name for object instance command" + }] + set i 0 + foreach a $arglist { + if {[llength $a] == 1} { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } else { + append argdef \n "[lindex $a 0] -default [lindex $a 1]" + } + incr i + } + punk::args::define $argdef + set queryargs_remaining [lrange $queryargs 1 end] + } + destroy { + #review - generally no doc + # but we may want notes about a specific destructor + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} destroy" + @cmd -name "destroy"\ + -summary\ + "delete object instance."\ + -help\ + "delete object, calling destructor if any. + destroy accepts no arguments." + @values -min 0 -max 0 + }] + punk::args::define $argdef + set queryargs_remaining [lrange $queryargs 1 end] + } + default { + #use info object call to resolve callchain + #we assume the first impl is the topmost in the callchain + # and its call signature is therefore the one we are interested in - REVIEW + # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? + set implementations [::info object call $origin $c1] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] + set oodef "" + foreach impl $implementations { + lassign $impl generaltype mname location methodtype + switch -- $generaltype { + method - private { + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) + if {$location eq "object"} { + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " + if {[punk::args::id_exists $idcustom]} { + return + } + set oodef [::info object definition $origin $c1] + } else { + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" + if {[punk::args::id_exists $idcustom]} { + return + } + set oodef [::info class definition $location $c1] + } + break + } + filter { + } + unknown { + } + } + } + if {$oodef ne ""} { + set autoid "(autodef)$location $c1" + set arglist [lindex $oodef 0] + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated by generate_autodef) + arglist:${$arglist}" + @values + }] + set i 0 + foreach a $arglist { + switch -- [llength $a] { + 1 { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } + 2 { + append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" + } + default { + puts stderr "generate_autodef unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" + } + } + incr i + } + punk::args::define $argdef + return ok + } else { + return "unable to resolve $origin method $c1" + } + + } + } + } + } + set choicelabeldict [dict create] + set choiceinfodict [dict create] + foreach cmd $public_methods { + switch -- $cmd { + default { + set implementations [::info object call $origin $cmd] + set def "" + foreach impl $implementations { + lassign $impl generaltype mname location methodtype + # + switch -- $generaltype { + method - private { + #private? todo? + if {$location eq $origin} { + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" + #dict set choiceinfodict $cmd {{doctype ooo}} + dict set choiceinfodict $cmd {{doctype objectmethod}} + } elseif {$location eq $class} { + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" + #dict set choiceinfodict $cmd {{doctype ooc}} + dict set choiceinfodict $cmd {{doctype classmethod}} + } else { + #e.g impl: {method destroy ::oo::object {core method: "destroy"}} + set id "$location $cmd" + if {[string match "core method:*" $methodtype]} { + dict lappend choiceinfodict $cmd {doctype coremethod} + } else { + dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] + } + } + if {[punk::args::id_exists $id]} { + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} + dict lappend choiceinfodict $cmd [list subhelp {*}$id] + } + break + } + filter { + #todo? flag if filter is on object vs class? + dict set choiceinfodict $cmd {{doctype filter}} + dict set choiceinfodict $cmd {{doctype TODO}} + #filter chain? + } + unknown { + dict set choiceinfodict $cmd {{doctype unknown}} + } + default { + error "generate_autodef unhandled generaltype:'$generaltype' for info object call $origin $cmd" + } + } + } + } + } + } + + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review + #puts stderr "--->$vline" + set autoid "(autodef)$origin" + if {[info object isa class $origin]} { + set objtype Class + } else { + set objtype Object + } + #An object command name can contain spaces - so we must quote the -id value + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -name "${$objtype}: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated by generate_autodef) + (see 'i punk::ns::Cmark' for symbols)" + @leaders -min 1 + }] + append argdef \n $vline + punk::args::define $argdef + + } + privateObject { + return "Command is a privateObject - no info currently available" + } + privateClass { + return "Command is a privateClass - no info currently available" + } + interp { + #todo + puts stderr "generate_autodef - interp" + } + script { + #todo + puts stderr "generate_autodef - script" + } + ensemble { + #review #todo - check -unknown #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. #presumably -choiceprefix should be zero in that case?? @@ -2340,133 +3114,450 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand - if {$posn_subcommand > 0} { - set params [lrange $queryargs 0 $posn_subcommand-1] - set remaining_queryargs [lrange $queryargs $posn_subcommand end] + if {[llength $queryargs]} { + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] + #subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + tailcall generate_autodef {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] + } + } + } + + #todo - synopsis? + set choicelabeldict [dict create] + + set choiceinfodict [dict create] + + dict for {sub subwhat} $subcommand_dict { + if {[llength $subwhat] > 1} { + #TODO - resolve using cmdinfo? + puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" + } + set targetfirstword [lindex $subwhat 0] + set targetinfo [cmdwhich $targetfirstword] + set targetorigin [dict get $targetinfo origin] + set targetcmdtype [dict get $targetinfo origintype] + set nstarget [nsprefix $targetorigin] + + dict set choiceinfodict $sub [list [list resolved $subwhat]] + dict lappend choiceinfodict $sub [list doctype $targetcmdtype] + + if {[punk::args::id_exists [list $origin $sub]]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] + } elseif {[punk::args::id_exists $targetorigin]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] + } elseif {[punk::args::id_exists ${origin}::$sub]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}${origin}::$sub] + } else { + #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" + } + + } + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + puts "ENSEMBLE auto def $autoid (generate_autodef)" + #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -help\ + "(autogenerated by generate_autodef) + ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" } else { - set params [list] - set remaining_queryargs $queryargs + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } } - if {[llength $remaining_queryargs]} { - if {$prefixes} { - set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + append argdef \n $vline + punk::args::define $argdef + } + proc { + #JJJ + set tepamhelp "" + if {[info exists ::tepam::ProcedureList]} { + if {$origin in $::tepam::ProcedureList} { + set tepamhelp [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout } else { - #must be exact match - not a prefix - set match [lindex $remaining_queryargs 0] + #handle any tepam functions that don't eat their own dogfood but have help variables + #e.g tepam::procedure, tepam::argument_dialogbox + #Rather than hardcode these - we'll guess that any added will use the same scheme.. + if {[namespace qualifiers $origin] eq "::tepam"} { + set func [namespace tail $origin] + #tepam XXXHelp vars don't exactly match procedure names :/ + if {[info exists ::tepam::${func}Help]} { + set tepamhelp [set ::tepam::${func}Help] + } else { + set f2 [string totitle $func] + if {[info exists ::tepam::${f2}Help]} { + set tepamhelp [set ::tepam::${f2}Help] + } else { + #e.g argument_dialogbox -> ArgumentDialogboxHelp + set parts [split $func _] + set uparts [lmap p $parts {string totitle $p}] + set f3 [join [list {*}$uparts Help] ""] + if {[info exists ::tepam::${f3}]} { + set tepamhelp [set ::tepam::${f3}] + } + } + } + } } - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } + set autoid "(autodef)$origin" + #note it's possible for a proc name to have a space - so we need to quote the -id value + if {$tepamhelp ne ""} { + puts "TEPAM PROC auto def $autoid (generate_autodef)" + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -help\ + "(autogenerated by generate_autodef) + proc: ${$origin}" + }] + append argdef \n "@formdisplay -body {$tepamhelp}" + punk::args::define $argdef + } else { + puts "PROC auto def $autoid (generate_autodef)" + set infoargs [info args $origin] + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -help\ + "(autogenerated by generate_autodef) + proc: ${$origin}" + @leaders + }] + set i -1 + #rather than type 'any' - we should use 'unknown' + foreach a $infoargs { + incr i + if {[info default $origin $a def]} { + append argdef \n "$a -type unknown -default \"$def\"" + } else { + if {$i == [llength $infoargs]-1 && $a eq "args"} { + append argdef \n "arg -type unknown -multiple 1 -optional 1" + } else { + append argdef \n "$a -type unknown" + } + } + } + punk::args::define $argdef + } + } + } - #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] - puts "+++> resolve_next: $resolve_next" + } - set sub_resolution [resolve_command {*}$resolve_next] - set sub_args_remaining [dict get $sub_resolution args_remaining] - set sub_args_full [dict get $sub_resolution args_full] - #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] - set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + punk::args::define { + @id -id ::punk::ns::cmdinfo + @cmd -name punk::ns::cmdinfo\ + -summary\ + "Subcommand resolution of ensemble-like tree of commands."\ + -help\ + "Return a dict with command resolution info for ensemble-like tree of commands with subcommands" + @leaders -min 0 -max 0 + @opts + -form -default * -help\ + "Ordinal index or name of command form" + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + variable cmdinfo_reducerid 0 + proc cmdinfo {args} { + set argd [punk::args::parse $args withid ::punk::ns::cmdinfo] + lassign [dict values $argd] leaders opts values received - puts stderr "+++> $sub_resolution" - puts stderr "+++> $f" - dict set sub_resolution args_full $f - return $sub_resolution - } + set cmdlist [dict get $values cmditem] + if {[llength $cmdlist] == 0} { + return ;#review - shouldn't get here anyway + } + set fid [dict get $opts -form] ;#todo + + variable cmdinfo_reducerid + set reduce ::punk::ns::reducer[incr cmdinfo_reducerid] + set nscaller [uplevel 1 [list ::namespace current]] + + set init [coroutine $reduce cmd_traverse $nscaller $fid {*}$cmdlist] + #puts stderr "init: $init" + set final 0 + set origin "" + set stack [list] + set commands [list] + set consumed_args [list] + set docid "" + while {$final == 0} { + lassign [$reduce $origin] final origin consumed remainingargs docid + #if {$final != 1} { + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + #puts "->$final neworigin: $origin consumed:$consumed remaining:$remainingargs docid:$docid" + lappend stack [list $origin {*}$consumed] + lappend commands $origin + lappend consumed_args {*}$consumed + #} + } + set finalcommand [lindex $commands end] + set cinfo [cmdwhich $finalcommand] + set origin [dict get $cinfo origin] + set cmdtype [dict get $cinfo origintype] + return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] + } + proc cmd_traverse {ns formid args} { + set autodefined [dict create] + #puts "cmd_traverse args: $args yielding: [info coroutine]" + yield [info coroutine] + if {![llength $args]} { + return + } + set cmd "" + + #use a for loop over args - as sometimes we may consume more than one in our reduction (e.g when there are ensemble parameters) + set argc [llength $args] + set cmd [lindex $args 0] + set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] + set origin [dict get $whichinfo origin] + set which [dict get $whichinfo which] + set whichtype [dict get $whichinfo whichtype] + + set docid "" + + #An imported or aliased command could be deliberately documented in the target namespace to override the origin + if {$argc == 1 && $origin ne $which} { + punk::args::update_definitions [list [namespace qualifiers $which]] + #we don't call generate_auto_def on the 'which' version of the command + #but we do want to lookup and use any explicit punk::args id that may exist for it + if {[punk::args::id_exists $which]} { + set docid $which + set origin $which ;#Flip our traversal to be on the documented 'which' rather than the actual origin + if {$whichtype eq "alias"} { + #*documented* alias + return [list 1 $origin {} [lrange $args 1 end] $docid] } + } + } - set choiceinfodict [dict create] - set choicelabeldict [dict create] + if {$docid eq ""} { + #there was no explicit documentation for the command at it's actual 'which' location. + punk::args::update_definitions [list [namespace qualifiers $origin]] + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" + } + } - set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set targetfirstword [lindex $subwhat 0] - set ns [::namespace which $targetfirstword] - set ns [nsprefix $ns] - set targettail [namespace tail $targetfirstword] - if {![dict exists $namespaces $ns]} { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] - dict set namespaces $ns $nsinfo - } else { - set nsinfo [dict get $namespaces $ns] + set resolvedargs {} + #if {$argc == 1} { + # return [list 1 $origin {} [lrange $args 1 end] $docid] + #} else { + set origin [yield [list 0 $origin {} [lrange $args 1 end] $docid]] + set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] + set origin [dict get $whichinfo origin] + set origintype [dict get $whichinfo origintype] + set which [dict get $whichinfo origin] + #an alias may have direct documentation + #if so - use it before resolving via origin + punk::args::update_definitions [list [namespace qualifiers $which]] + if {[punk::args::id_exists $which]} { + set docid $which + set origin $which + } else { + set docid "" + } + if {$docid eq ""} { + #review - orgintype classmethod, objectmethod? + if {$origintype eq "script"} { + #a 'script' is essentially an alias-target to a command with curried args + #There will not be documentation or a 'command' matching the entire script, but there may be for the target command (first word of script) + set scriptcmdraw [lindex $origin 0] + set scriptinfo [namespace eval $ns [list punk::ns::cmdwhich $scriptcmdraw]] + set scriptcmd [dict get $scriptinfo which] + set scriptargs [lrange $origin 1 end] + #ledit args -1 -1 {*}$scriptargs ;#prepend + set args [linsert $args 1 {*}$scriptargs] + #JJJ review + #set resolvedargs $scriptargs + punk::args::update_definitions [list [namespace qualifiers $scriptcmd]] + if {![punk::args::id_exists $scriptcmd] && ![dict exists $autodefined $scriptcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $scriptcmd] + dict set autodefined $origin 1 + #if the scriptcmd is itself an alias - no autodef will be generated for it } - dict set choiceinfodict $sub [list [list resolved $subwhat]] + if {[punk::args::id_exists $scriptcmd]} { + set docid $scriptcmd + } elseif {[punk::args::id_exists "(autodef)$scriptcmd"]} { + set docid (autodef)$scriptcmd + } else { - if {$targettail in [dict get $nsinfo usageinfo]} { - dict lappend choiceinfodict $sub {doctype punkargs} - #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] - } - if {$targettail in [dict get $nsinfo ensembles]} { - dict lappend choiceinfodict $sub {doctype ensemble} - } - if {$targettail in [dict get $nsinfo ooobjects]} { - if {$targettail in [dict get $nsinfo ooclasses]} { - dict lappend choiceinfodict $sub {doctype ooc} - } else { - dict lappend choiceinfodict $sub {doctype ooo} - } + set docid "" } + set origin $scriptcmd + } elseif {$origintype eq "alias"} { + #JJJ2 + #puts "==> examining alias $origin" + if {[string match >* [nstail $origin]] && [package provide pattern] ne ""} { + if {![catch {pattern::which_alias $origin} alias_target]} { + #review - todo? + set patternorigin [lindex $alias_target 0] + #set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] + set args [linsert $args 1 {*}[lrange $alias_target 1 end]] + #set resolvedargs [lrange $alias_target 1 end] + punk::args::update_definitions [list [namespace qualifiers $patternorigin]] + if {![punk::args::id_exists $patternorigin] && ![dict exists $autodefined $patternorigin]} { + namespace eval $ns [list punk::ns::generate_autodef $patternorigin] + dict set autodefined $origin 1 + #if the patternorigin is itself an alias - no autodef will be generated for it + } + if {[punk::args::id_exists $patternorigin]} { + set docid $patternorigin + } elseif {[punk::args::id_exists "(autodef)$patternorigin"]} { + set docid (autodef)$patternorigin + } else { - if {$targettail in [dict get $nsinfo native]} { - dict lappend choiceinfodict $sub {doctype native} + set docid "" + } + set origin $patternorigin + } } - } - - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] - set autoid "(autodef)$origin" - set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} - @cmd -help\ - "(autogenerated) - Ensemble: ${$origin}" - @leaders -min 1 - }] - if {[llength $parameters] == 0} { - append argdef \n "@leaders -min 1" } else { - append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" - foreach p $parameters { - append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + punk::args::update_definitions [list [namespace qualifiers $origin]] + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" } } - append argdef \n $vline - punk::args::define $argdef - set id $autoid } + #} + if {[llength $args] == 1} { + return [list 2 $origin $resolvedargs {} $docid] } - #testing where id = $origin or id = (autodef)::$origin - if {[punk::args::id_exists $id]} { - #cycle forward through leading values - set specid $id - set specargs $queryargs - if {[llength $queryargs]} { - #JJJ - set spec [punk::args::get_spec $id] - #TODO -form - set form_names [dict get $spec form_names] + set terminate 0 + for {set i 1} {$i < [llength $args]} {incr i} { + #set a [lindex $args $i] + #puts "i:$i a:$a origin:$origin" + #xxx + #puts "==> origin:'$origin' a:'$a'" + + #this docid may be an (autodef) for a level that had no specific documentation. + #If the command at this level is a proc - such an autodef will not have automatically determined any deeper subcommands. + #If however there exists a definition for a space delimited deeper level - then that docid should ideally be found + #e.g punk::args::id_exists "$origin $a" + #we could/should look deeper going backwards? + #ie examining each docid from start will not work to find deeper documented items if there are gaps in manual docs and autodefs based on intermediate procs + #The idea is to support packages for which documentation is incomplete - and to avoid unnecessary lookups of intermediaries. + #e.g starting at: punk::args::id_exists "$origin {*}[lrange $args $i end]" and shortening? + #for example the fictitious ensemble-like nest "::a b c d" + #c may be an undoc'ed proc but the id "::a b c d" may exist + #or ::a b might resolve somewhere unrelated e.g ::foo::bar and "::foo::bar c d" might exist + #starting at the end may involve testing for many ids based on non subcommand args (args to the deepest subcommand itself) + # while id_exists checks don't seem to be hugely expensive - this may not be the best approach on a very large documented system. + #we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. + #(would not support shor-form prefix of subcommand - even if the proc implementation did) + set docid_exists 0 + if {[punk::args::id_exists "$origin [lindex $args $i]"]} { + set a [lindex $args $i] + #review - tests? + puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" + #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent + #There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. + set docid_exists 1 + set docid "$origin $a" + set origin [list $origin $a] + incr i + set queryargs [lrange $args $i end] + set resolvedargs [list $a] ;#even though the + set queryargs_untested $queryargs + } elseif {[punk::args::id_exists $docid]} { + set docid_exists 1 + set queryargs [lrange $args $i end] + set resolvedargs [list] + set queryargs_untested $queryargs + } else { + #we cannot generate autodoc for any deeper (e.g ensemble/proc after undocumented parent) + #There is nothing to indicate the locations of subcommands - they could be anywhere. + #e.g (dispatched by custom code in a proc) + #'guessing' that they follow a namespace hierarchy would be error-prone and a bad idea even if it sometimes worked. + } - #'subcommands' only allowed in single-form commands - review + if {$docid_exists} { + set spec [punk::args::get_spec $docid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] set fid [lindex $form_names 0] + #set fid "" + #if {$formid eq "*"} { + # if {[llength $form_names] == 1} { + # set fid [lindex $form_names 0] + # } else { + # error "cmd_traverse command has [llength $form_names] forms but no specific -form selected. multiform discrimination not yet supported" + # } + #} elseif {[string is integer -strict $formid]} { + # set fid [lindex $form_names $formid] + #} else { + # set fid [tcl::prefix::match -error "" $form_names $formid] + #} + #if {$fid eq ""} { + # error "cmd_traverse unable to match form $formid. form names: $form_names" + #} + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES] set valnames [dict get $spec FORMS $fid VAL_NAMES] - #'subcommands' are only present in forms that consist solely of leaders - REVIEW - #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) - if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs - set queryargs_untested $queryargs + if {![llength $optnames] && ![llength $valnames]} { + + #set queryargs [lrange $args $i end] + #set resolvedargs [list] + #set queryargs_untested $queryargs set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] foreach q $queryargs lname $leadernames_matched { + #puts "===> queryargs:$queryargs lnames:$leadernames_matched" + #usually we expect only one entry in leadernames (except for -ensembleparameter cases) if {$lname eq ""} { + #todo - return? break } set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] - set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] @@ -2481,122 +3572,175 @@ tcl::namespace::eval punk::ns { lappend allchoices {*}$clist } if {$is_ensembleparam} { - #review - lappend nextqueryargs $q - #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - set specargs $queryargs_untested + lappend resolvedargs $q + lpop queryargs_untested 0 + #ledit queryargs_untested 0 0 + #review - add tests continue } if {![llength $allchoices]} { #review - only leaders with a defined set of choices are eligible for consideration as a subcommand - lappend nextqueryargs $q + #lappend resolvedargs $q #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - set specargs $queryargs_untested - continue + #ledit queryargs_untested 0 0 + #jjj + #continue + return [list 3 $origin $resolvedargs $queryargs_untested $docid] + break } - - set resolved_q [tcl::prefix::match -error "" $allchoices $q] if {$resolved_q eq ""} { + return [list 4 $origin $resolvedargs $queryargs_untested $docid] break } if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { #a unique prefix is not sufficient for this arg + return [list 5 $origin $resolvedargs $queryargs_untested $docid] break } - lappend nextqueryargs $resolved_q - #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] - set sub_resolution [punk::ns::resolve_command {*}$resolvelist] - #return $sub_resolution - - set sub_origin [dict get $sub_resolution origin] - set sub_argsremaining [dict get $sub_resolution args_remaining] - set sub_resolved [dict get $sub_resolution resolved] - set sub_cmdtype [dict get $sub_resolution cmdtype] - set sub_args_full [dict get $sub_resolution args_full] - puts stderr "===> $sub_resolution" - - return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + #if {$resolved_q ne $q} { + # ##we have our first difference + #} + + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + set prevdocid $docid + set docid "" + foreach inf $cinfo { + switch -- [lindex $inf 0] { + "resolved" { + #punk::args::ensemble_subcommands_definition + set mapped_subcmd [lrange $inf 1 end] + if {![punk::args::id_exists $mapped_subcmd]} { + punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] + if {![dict exists $autodefined $mapped_subcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $mapped_subcmd] + dict set autodefined $origin 1 + } + } + #if {![punk::args::id_exists $mapped_subcmd] && [punk::args::id_exists "(autodef)$mapped_subcmd"]} { + # set mapped_subcmd "(autodef)$mapped_subcmd" + #} + if {[punk::args::id_exists $mapped_subcmd]} { + set docid $mapped_subcmd + } elseif {[punk::args::id_exists "(autodef)$mapped_subcmd"]} { + set docid (autodef)$mapped_subcmd + } else { + set docid "" + } + #puts stderr "cmd_traverse 'resolved' $mapped_subcmd" + } + "subhelp" { + set mapped_subcmd [lrange $inf 1 end] + #set mapped_subcmd [lindex $inf 1] + if {![punk::args::id_exists $mapped_subcmd]} { + punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] + if {![dict exists $autodefined $mapped_subcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $mapped_subcmd] + dict set autodefined $origin 1 + } + } + #if {![punk::args::id_exists $mapped_subcmd] && [punk::args::id_exists "(autodef)$mapped_subcmd"]} { + # set mapped_subcmd "(autodef)$mapped_subcmd" + #} + if {[punk::args::id_exists $mapped_subcmd]} { + set docid $mapped_subcmd + } elseif {[punk::args::id_exists "(autodef)$mapped_subcmd"]} { + set docid (autodef)$mapped_subcmd + } else { + set docid "" + } + #allow subhelp override - todo: review/document rationale/usecases + break + } + } } - #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list {*}$specid {*}$nextqueryargs] - if {[punk::args::id_exists $currentid]} { - set spec [punk::args::get_spec $currentid] - set form_names [dict get $spec form_names] - set fid [lindex $form_names 0] - - set specid $currentid - set specargs $queryargs_untested - set nextqueryargs [list] - - if {[llength $form_names] != 1} { - break + if {$mapped_subcmd eq ""} { + if {[string match (autodef)* $origin]} { + set raw_origin [string range $origin 9 end] + } else { + set raw_origin $origin } - set optnames [dict get $spec FORMS $fid OPT_NAMES] - set valnames [dict get $spec FORMS $fid VAL_NAMES] - if {[llength $optnames] || [llength $valnames]} { - break + #puts stderr "cmd_traverse testing punk::args::id_exists \"$raw_origin $resolved_q\"" + if {[punk::args::id_exists "$raw_origin $resolved_q"]} { + set mapped_subcmd "$raw_origin $resolved_q" + set docid $mapped_subcmd + } else { + #REVIEW - there is no reason to assume a subcommand (even in an ensemble) + #will be located at "${raw_origin}::$resolved_q" + #ensemble -map could point resolved_q somewhere else entirely + + #punk::args::update_definitions [list $raw_origin] + #if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} { + # set mapped_subcmd "${raw_origin}::$resolved_q" + # set docid $mapped_subcmd + #} else { + # if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} { + # namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"] + # } + # if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} { + # set mapped_subcmd ${raw_origin}::$resolved_q + # set docid (autodef)${raw_origin}::$resolved_q + # } + #} } - } else { - set is_subcommand_resolved 0 - set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] - set mapped_subcmd "" - foreach inf $cinfo { - if {[lindex $inf 0] eq "resolved"} { - set mapped_subcmd [lindex $inf 1] - set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] - puts "---> resolve_next: $resolve_next" - set sub_resolution [punk::ns::resolve_command {*}$resolve_next] - - set sub_args_remaining [dict get $sub_resolution args_remaining] - set sub_args_full [dict get $sub_resolution args_full] - #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] - set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] - - puts stderr "---> $sub_resolution" - puts stderr "---> $f" - dict set sub_resolution args_full $f - return $sub_resolution - - - #puts stderr "---> $sub_resolution" - #return $sub_resolution - } + } + #puts "----------$mapped_subcmd" + if {$mapped_subcmd ne ""} { + lappend resolvedargs $resolved_q + #ledit queryargs_untested 0 0 + lpop queryargs_untested 0 + + #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] + if {[llength $queryargs_untested] == 0} { + return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid] + } + + set origin [yield [list 0 $mapped_subcmd $resolvedargs $queryargs_untested $docid]] + #set resolvedargs [list] + incr i [expr {-1 * [llength $resolvedargs]+1}] + #puts stderr "... yield-result $origin i:$i" + + set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] + set origin [dict get $whichinfo origin] + set cmdtype [dict get $whichinfo origintype] + punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" } - #We can get no further with custom defs - #It is possible we have a documented lower level subcommand but missing the intermediate - #e.g if ::trace remove command was specified and is documented - it will be found above - #but if ::trace remove is not documented and the query is "::trace remove com" - #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. - #that's probably ok. break + } else { + #test with: i namespace which -v x + return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] } } + } else { + #?? + puts stderr "cmdinfo.cmd_traverse returning 8 $origin $resolvedargs [lrange $args $i end] $docid" + return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] } - #puts "--->origin $specid queryargs: $specargs" - set origin $specid - set queryargs $specargs + } else { + #puts stderr "origin $origin not documented" + return [list 9 $origin {} [lrange $args $i end] ""] } } - - if {[string match (autodef)* $origin]} { - set origin [string range $origin 9 end] - } - - - return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + #REVIEW!!! + puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" + return [list 10 $origin $resolvedargs $queryargs_untested $docid] } + punk::args::define { @id -id ::punk::ns::forms @cmd -name punk::ns::forms\ @@ -2604,16 +3748,17 @@ tcl::namespace::eval punk::ns { "List command forms."\ -help\ "Return names for each form of a command. - Most commands are single-form and will only return the name '_default'." + Most commands are single-form and will only return the name '_default'. + An example of a multiform command is the Tcl builtin '::after'." @opts @values -min 1 -max -1 cmditem -multiple 1 -optional 0 } proc forms {args} { set argd [::punk::args::parse $args withid ::punk::ns::forms] - set cmdmembers [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set id [dict get $cmdinfo origin] + set cmdwords [dict get $argd values cmditem] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + set id [dict get $resolveinfo origin] ::punk::args::forms $id } @@ -2631,9 +3776,9 @@ tcl::namespace::eval punk::ns { } proc eg {args} { set argd [::punk::args::parse $args withid ::punk::ns::eg] - set cmdmembers [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set resolved_id [dict get $cmdinfo origin] + set cmdwords [dict get $argd values cmditem] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + set resolved_id [dict get $resolveinfo origin] set result [::punk::args::eg $resolved_id] } @@ -2650,7 +3795,8 @@ tcl::namespace::eval punk::ns { the synopsis for that form. " @opts - -form -type string -default * + -form -type string -default * -help\ + "Ordinal index or name of command form." -return -type string -default full -choices {full summary dict} @values -min 1 -max -1 cmditem -multiple 1 -optional 0 @@ -2659,20 +3805,35 @@ tcl::namespace::eval punk::ns { set argd [::punk::args::parse $args withid ::punk::ns::synopsis] set form [dict get $argd opts -form] set opt_return [dict get $argd opts -return] - set cmdmembers [dict get $argd values cmditem] + set cmdwords [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set resolved_id [dict get $cmdinfo origin] - set unresolved_args [dict get $cmdinfo args_remaining] - set full_args [dict get $cmdinfo args_full] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + + set resolved_id [dict get $resolveinfo origin] + set doc_id [dict get $resolveinfo docid] + set unresolved_args [dict get $resolveinfo args_remaining] + set resolved_args [dict get $resolveinfo args_resolved] - #puts "---punk::args::synopsis resolve_command result: $cmdinfo" #REVIEW - set n [llength $unresolved_args] - set idparts [lrange $full_args 0 end-$n] + #set n [llength $unresolved_args] + #set cmdargs [lrange $args 1 end] + #set consumedargs [lrange $cmdargs 0 end-$n] + set synopsis_args [lrange $cmdwords 1 end] + set excess 0 + if {[llength $unresolved_args] > [llength $synopsis_args]} { + #we can get excess args_remaining due to alias currying - REVIEW + #This isn't quite right.. e.g see: s pse + #we need to use something like punk::args::parse against the command with the unresolved_args + synopsis_args ?? + set excess [expr {[llength $unresolved_args] - [llength $synopsis_args]}] + } - set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + + if {$doc_id eq ""} { + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + } else { + set syn [::punk::args::synopsis -return $opt_return -form $form $doc_id] + } if {$syn eq ""} { return } @@ -2685,8 +3846,10 @@ tcl::namespace::eval punk::ns { if {[string range $synline 0 1] eq "# "} { append resultstr $synline \n } else { - #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n - append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + #puts stderr [textblock::frame $syn] + #set replaceuntil [expr {[llength $resolved_id]-1}] + set replaceuntil [expr {[llength $resolved_id]-1+$excess}] + append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n } } set resultstr [string trimright $resultstr \n] @@ -2701,19 +3864,16 @@ tcl::namespace::eval punk::ns { proc synopsis_raw {args} { set argd [::punk::args::parse $args withid ::punk::ns::synopsis] set form [dict get $argd opts -form] - set cmdmembers [dict get $argd values cmditem] - set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context - set id [dict get $cmdinfo origin] + set cmdwords [dict get $argd values cmditem] + set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context + set id [dict get $resolveinfo origin] ::punk::args::synopsis -form $form $id } - #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? - # - as this is interactive generally introspection should be ok at the top level - # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? punk::args::define { @dynamic - @id -id ::punk::ns::arginfo - @cmd -name punk::ns::arginfo\ + @id -id ::punk::ns::cmdhelp + @cmd -name punk::ns::cmdhelp\ -summary\ "Command usage/help."\ -help\ @@ -2733,7 +3893,7 @@ tcl::namespace::eval punk::ns { generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without - calling them. arginfo deliberately avoids calling commands to elicit + calling them. cmdhelp deliberately avoids calling commands to elicit usage information as this is inherently risky. (could create a file, exit the interp etc) " @@ -2744,8 +3904,8 @@ tcl::namespace::eval punk::ns { -form -default 0 -help\ "Ordinal index or name of command form" -grepstr -default "" -type list -typesynopsis regex -help\ - "list consisting of regex, optionally followed by ANSI names for highlighting - (incomplete - todo)" + "Case insensitive grep for pattern in the output. + list consisting of regex, optionally followed by ANSI names for highlighting" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2756,372 +3916,481 @@ tcl::namespace::eval punk::ns { "subcommand if commandpath is an ensemble. Multiple subcommands can be supplied if ensembles are further nested" } - proc arginfo {args} { - lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received + proc cmdhelp {args} { set nscaller [uplevel 1 [list ::namespace current]] - #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part - #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. + lassign [dict values [punk::args::parse $args withid ::punk::ns::cmdhelp]] leaders opts values received if {![dict exists $received -scheme]} { #dict set opts -scheme info set scheme_received 0 } else { set scheme_received 1; #so we know not to override caller's explicit choice } - set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] - set grepstr [dict get $opts -grepstr] - set opts [dict remove $opts -grepstr] - #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" + set opt_grepstr [dict get $opts -grepstr] + set opt_form [dict get $opts -form] + set opt_return [dict get $opts -return] + switch -- $opt_return { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + set nextopts [dict remove $opts -grepstr] + #JJJ + set whichinfo [uplevel 1 [list cmdwhich $querycommand]] + set rootorigin [dict get $whichinfo origin] + set which [dict get $whichinfo which] + set rootorigintype [dict get $whichinfo origintype] + set whichtype [dict get $whichinfo whichtype] + + + set rootinfo [uplevel 1 [list cmdinfo $which]] + set rootdoc [dict get $rootinfo docid] + #NOTE - we can get 'args_remaining' due to cmdinfo resolving to a curried alias target + set args_remaining [dict get $rootinfo args_remaining] + if {$rootdoc ne ""} { + if {$whichtype eq "alias"} { + #test if we could resolve further + set testinfo [punk::ns::cmdinfo $querycommand {*}$queryargs] + set testresolved [dict get $testinfo args_resolved] + if {[llength $testresolved] == 1} { + #only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand + ledit queryargs -1 -1 {*}$args_remaining ;#prepend + if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { + if {$opt_return eq "tableobject"} { + set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] + } else { + set result $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0 -parsedargs $parseresult] + } + if {$opt_grepstr ne ""} { + if {[llength $opt_grepstr] == 1} { + set result [punk::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] + } else { + set result [punk::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] + } + } + return $result + } + } + } - #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented - if {[string match ::* $querycommand]} { - set targetns [nsprefix $querycommand] - set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global - #when arginfo given a fully qualified path - we only want an answer for that exact command - set nscommands [info commands ${targetns}::*] - if {[lsearch -exact $nscommands $querycommand] >= 0} { - #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths - if {[catch { - set origin [nseval_ifexists $targetns [list ::namespace origin $name]] - set resolved [nseval_ifexists $targetns [list ::namespace which $name]] - }]} { - set origin $querycommand - set resolved $querycommand + #----------------------------------------------------------------------------------------------------------------------------- + #review! + #only divert to target script/alias if rootorigin undocumented + #if we were to jump straight to the alias or script target - we preclude the opportunity + #to lookup any user documentation that was specifically supplied for the alias at $which !!! + + switch -- $rootorigintype { + script { + #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + set scriptargs [lrange $rootorigin 1 end] ;#arguments that were curried into the alias script + set scriptcmd [lindex $rootorigin 0] + set nextqueryargs [list {*}$scriptargs {*}$queryargs] + #puts stderr "cmdhelp $nextopts $scriptcmd $nextqueryargs" + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] + } + alias { + #e.g alias to an alias + #JJJ2 + #puts "JJJ2 rootorigin:$rootorigin" + if {[string match >* [nstail $rootorigin]] && [package provide pattern] ne ""} { + if {![catch {pattern::which_alias $rootorigin} alias_target]} { + #review - todo? + set targetcmd [lindex $alias_target 0] + set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts {*}$targetcmd {*}$queryargs]] + } + } + if {$which eq $rootorigin} { + #origin points to self which is an alias - can happen if an alias has been renamed + } else { + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts {*}$rootorigin {*}$queryargs]] } - } else { - #fully qualified command specified but doesn't exist - set origin $querycommand - set resolved $querycommand } - } else { - #relative comandpath - if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup - set origin $querycommand - set resolved $querycommand - } else { - set thispath [uplevel 1 [list ::nsthis $querycommand]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + } + #----------------------------------------------------------------------------------------------------------------------------- + + #puts "-----> rootorigin $rootorigin queryargs $queryargs" + set cinfo [uplevel 1 [list cmdinfo $rootorigin {*}$queryargs]] + + + set origin [dict get $cinfo origin] + set origindoc [dict get $cinfo docid] + set args_remaining [dict get $cinfo args_remaining] + set origintype [dict get $cinfo cmdtype] + + switch -- $origintype { + script { + #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script + set scriptcmd [lindex $origin 0] + set nextqueryargs [list {*}$scriptargs {*}$args_remaining] + #puts stderr "cmdhelp $nextopts $scriptcmd $args_remaining" + return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] + } + } + if {$origindoc ne ""} { + + + if {[catch {punk::args::parse $args_remaining -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { + if {$opt_return eq "tableobject"} { + set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { - set valid_ns [namespace exists $targetns] + set result $parseresult } - if {$valid_ns} { - if {[catch { - set origin [nseval_ifexists $targetns [list ::namespace origin $name]] - set resolved [nseval_ifexists $targetns [list ::namespace which $name]] - }]} { - set thiscmd [nsjoin $targetns $name] - #relative querycommand specified - but Tcl didn't find a match in namespace path - #assume global (todo - look for namespace match in auto_index first ?) - set origin ::$name - set resolved ::$name - } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set nextopts -scheme info + } + set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0 -parsedargs $parseresult] + } + if {$opt_grepstr ne ""} { + if {[llength $opt_grepstr] == 1} { + set result [punk::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] } else { - #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global + set result [punk::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] + } + } + return $result + } else { + return "Undocumented command $origin. Type: $origintype" + } + + #return [cmdinfo $origin {*}$queryargs] + } + + + + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? + # - as this is interactive generally introspection should be ok at the top level + # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? + #TODO - make obsolete - (replaced by punk::ns::cmdhelp) + punk::args::define { + @dynamic + @id -id ::punk::ns::arginfo + @cmd -name punk::ns::arginfo\ + -summary\ + "Command usage/help."\ + -help\ + "Show usage info for a command. + It supports the following: + 1) Procedures or builtins for which a punk::args definition has + been loaded. + 2) tepam procedures (returns string form only) + 3) ensemble commands - auto-generated unless documented via punk::args + (subcommands will show with an indicator if they are + explicitly documented or are themselves ensembles) + 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 5) dereferencing of aliases to find underlying command + (will not work with some renamed aliases) + + Note that native commands commands not explicitly documented will + generally produce no useful info. For example sqlite3 dbcmd objects + could theoretically be documented - but as 'info cmdtype' just shows + 'native' they can't (?) be identified as belonging to sqlite3 without + calling them. arginfo deliberately avoids calling commands to elicit + usage information as this is inherently risky. (could create a file, + exit the interp etc) + " + -return -type string -default table -choices {string table tableobject} + + + } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { + -form -default 0 -help\ + "Ordinal index or name of command form" + -grepstr -default "" -type list -typesynopsis regex -help\ + "list consisting of regex, optionally followed by ANSI names for highlighting + (incomplete - todo)" + -- -type none -help\ + "End of options marker + Use this if the command to view begins with a -" + @values -min 1 + commandpath -help\ + "command (may be alias, ensemble, tcl::oo object, tepam proc etc)" + subcommand -optional 1 -multiple 1 -default {} -help\ + "subcommand if commandpath is an ensemble. + Multiple subcommands can be supplied if ensembles are further nested" + } + proc arginfo {args} { + lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received + set nscaller [uplevel 1 [list ::namespace current]] + #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part + #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. + if {![dict exists $received -scheme]} { + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice + } - #set numvals [expr {[llength $queryargs]+1}] - ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" - #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] - if {$nscaller ne "::"} { - if {!$scheme_received} { - dict unset opts -scheme - } - return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] - } + set querycommand [dict get $values commandpath] + set queryargs [dict get $values subcommand] + set grepstr [dict get $opts -grepstr] + set opts [dict remove $opts -grepstr] + #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" - set origin $querycommand - set resolved $querycommand + #todo - similar to corp? review corp resolution process + #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented - } + set cinfo [uplevel 1 [list cmdwhich $querycommand]] + set origin [dict get $cinfo origin] + set resolved [dict get $cinfo which] + set cmdtype [dict get $cinfo origintype] + switch -- $cmdtype { + script { + #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script + set origin [lindex $origin 0] + set queryargs [list {*}$scriptargs {*}$queryargs] + return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] + } + alias { + #alias to an alias + return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] } } + #JJJ #check for a direct match first - if {[info commands ::punk::args::id_exists] ne ""} { - if {![llength $queryargs]} { - #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" - punk::args::update_definitions [list [namespace qualifiers $origin]] - if {[punk::args::id_exists $origin]} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] - } - } + if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" + punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: + if {![punk::args::id_exists $origin] && ![punk::args::id_exists (autodef)$origin]} { + uplevel 1 [list punk::ns::generate_autodef $origin] } - } - #ns::cmdtype only detects alias type on 8.7+? - set initial_cmdtype [punk::ns::cmdtype $origin] - switch -- $initial_cmdtype { - na - alias { - #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) - set tgt [interp alias "" $origin] - if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft $origin :]] + if {[punk::args::id_exists (autodef)$origin]} { + set origin (autodef)$origin + } + if {[punk::args::id_exists $origin]} { + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } } - #first word of tgt may be namespace relative or absolute - if {$tgt ne ""} { - set word1 [lindex $tgt 0] - if {$word1 eq "punk::mix::base::_cli"} { - #special case for punk deck - REVIEW - #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set targetword [lindex $tgt end] + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] } else { - #todo - alias may have prefilled some leading args - so usage report should reflect that??? - #(possible curried arguments) - #review - curried arguments could be for ensembles! - set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] - #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" - #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] - if {!$scheme_received} { - dict unset opts -scheme - } - return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + return $parseresult } - - - set origin $targetword - #retest cmdtype on modified origin - set cmdtype [punk::ns::cmdtype $origin] } else { - set cmdtype $initial_cmdtype - } - if {$cmdtype eq "na"} { - #tcl 8.6 - if {[info object isa object $origin]} { - set cmdtype "object" + if {!$scheme_received} { + dict set opts -scheme info } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] } } - default { - set cmdtype $initial_cmdtype - } } set id $origin - if {[info commands ::punk::args::id_exists] ne ""} { + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] - #check longest first checking for id matching ::cmd ?subcmd..? - #REVIEW - this doesn't cater for prefix callable subcommands - set argcopy $queryargs - if {[llength $queryargs]} { - #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" - punk::args::update_definitions [list [namespace qualifiers $id]] - if {[punk::args::id_exists [list $id {*}$queryargs]]} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } + #check longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands + if {[llength $queryargs]} { + if {[punk::args::id_exists [list $id {*}$queryargs]]} { + switch -- [dict get $opts -return] { + string { + set estyle "basic" } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] - } else { - return $parseresult - } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + return $parseresult } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] } } - #while {[llength $argcopy]} { - # if {[punk::args::id_exists [list $id {*}$argcopy]]} { - # return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] - # } - # lpop argcopy - #} + } - #didn't find any exact matches - #traverse from other direction taking prefixes into account + #didn't find any exact matches + #traverse from other direction taking prefixes into account + set specid "" + if {[punk::args::id_exists $id]} { + set specid $id + } elseif {[punk::args::id_exists (autodef)$id]} { + set specid (autodef)$id + } - #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" - punk::args::update_definitions [list [namespace qualifiers $id]] - if {[punk::args::id_exists $id]} { - #cycle forward through leading values - set specid $id - set specargs $queryargs - if {[llength $queryargs]} { - #jjj - set spec [punk::args::get_spec $id] - #--------------------------------------------------------------------------- - set form_names [dict get $spec form_names] - if {[llength $form_names] == 1} { - set fid [lindex $form_names 0] + if {$specid ne "" && [punk::args::id_exists $specid]} { + #cycle forward through leading values + set specargs $queryargs + if {[llength $queryargs]} { + #jjj + set spec [punk::args::get_spec $specid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] } else { - #review - -form only applies to final command? - # -form must be a list if we have multiple levels of multi-form commands? - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid [lindex $form_names $opt_form] - } else { - if {$opt_form ni $form_names} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid $opt_form + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" } + set fid $opt_form } - #--------------------------------------------------------------------------- - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs - set queryargs_untested $queryargs - foreach q $queryargs { - if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { - #todo: fix - set subitems [dict get $spec FORMS $fid LEADER_NAMES] - if {[llength $subitems]} { - set next [lindex $subitems 0] - set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - - set allchoices [list] - set choices [punk::args::system::Dict_getdef $arginfo -choices {}] - set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] - #maintenance smell - similar/dup of some punk::args logic - review - #-choiceprefixdenylist ?? - set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices {*}$clist - } - set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] - if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { - break + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + #todo: fix + set subitems [dict get $spec FORMS $fid LEADER_NAMES] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + #maintenance smell - similar/dup of some punk::args logic - review + #-choiceprefixdenylist ?? + set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] + if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { + break + } + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + #ledit queryargs_untested 0 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] + #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" + if {!$scheme_received} { + dict unset opts -scheme } - lappend nextqueryargs $resolved_q - #lpop queryargs_untested 0 - ledit queryargs_untested 0 0 - if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] - #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] - #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - if {!$scheme_received} { - dict unset opts -scheme - } - return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] - } - #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list {*}$specid {*}$nextqueryargs] - if {[punk::args::id_exists $currentid]} { - set spec [punk::args::get_spec $currentid] - #--------------------------------------------------------------------------- - set form_names [dict get $spec form_names] - if {[llength $form_names] == 1} { - set fid [lindex $form_names 0] + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] } else { - #review - -form only applies to final command? - # -form must be a list if we have multiple levels of multi-form commands? - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid [lindex $form_names $opt_form] - } else { - if {$opt_form ni $form_names} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid $opt_form + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" } + set fid $opt_form } - #--------------------------------------------------------------------------- - set specid $currentid - set specargs $queryargs_untested - set nextqueryargs [list] - } else { - #We can get no further with custom defs - #It is possible we have a documented lower level subcommand but missing the intermediate - #e.g if ::trace remove command was specified and is documented - it will be found above - #but if ::trace remove is not documented and the query is "::trace remove com" - #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. - #that's probably ok. - break } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + } else { + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break } - } else { - #review - break } + } else { + #review + break } - } else { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } + } + } else { + switch -- [dict get $opts -return] { + string { + set estyle "basic" } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] - } else { - return $parseresult - } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] } - #puts "--->origin $specid queryargs: $specargs" - set origin $specid - set queryargs $specargs } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } if {[string match "(autodef)*" $origin]} { @@ -3130,6 +4399,7 @@ tcl::namespace::eval punk::ns { set resolved $origin } + set autoid "" switch -- $cmdtype { object { #class is also an object @@ -3345,7 +4615,7 @@ tcl::namespace::eval punk::ns { set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -name "${$location} ${$c1}" -help\ - "(autogenerated) + "(autogenerated by arginfo) arglist:${$arglist}" @values }] @@ -3393,19 +4663,27 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - if {$location eq "object"} { + if {$location eq $origin} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" - dict set choiceinfodict $cmd {{doctype ooo}} + dict set choiceinfodict $cmd {{doctype objectmethod}} + } elseif {$location eq $class} { + set id "$class $cmd" + dict set choiceinfodict $cmd {{doctype classmethod}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" - dict set choiceinfodict $cmd {{doctype ooc}} + if {[string match "core method:*" $methodtype]} { + dict lappend choiceinfodict $cmd {doctype coremethod} + } else { + dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] + } } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" dict lappend choiceinfodict $cmd {doctype punkargs} + dict lappend choiceinfodict $cmd [list subhelp {*}$id] } } break @@ -3423,16 +4701,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" - set idauto "(autodef)$origin" + set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$autoid} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 }] append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $idauto] + } privateObject { return "Command is a privateObject - no info currently available" @@ -3443,172 +4721,151 @@ tcl::namespace::eval punk::ns { interp { #todo } - } + script { + #todo + } + ensemble { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? - #check ensemble before testing punk::arg::id_exists - #we want to recalculate ensemble usage info in case ensemble has been modified + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] - if {[namespace ensemble exists $origin]} { - #review - #todo - check -unknown - #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. - #presumably -choiceprefix should be zero in that case?? - - set ensembleinfo [namespace ensemble configure $origin] - set parameters [dict get $ensembleinfo -parameters] - set prefixes [dict get $ensembleinfo -prefixes] - set map [dict get $ensembleinfo -map] - set ns [dict get $ensembleinfo -namespace] - - #review - we can have a combination of commands from -map as well as those exported from -namespace - # if and only if -subcommands is specified - - set subcommand_dict [dict create] - set commands [list] - set nscommands [list] - if {[llength [dict get $ensembleinfo -subcommands]]} { - #set exportspecs [namespace eval $ns {namespace export}] - #foreach pat $exportspecs { - # lappend nscommands {*}[info commands ${ns}::$pat] - #} - #when using -subcommands, even unexported commands are available - set nscommands [info commands ${ns}::*] - foreach sub [dict get $ensembleinfo -subcommands] { - if {[dict exists $map $sub]} { - #-map takes precence over same name exported from -namespace - dict set subcommand_dict $sub [dict get $map $sub] - } elseif {"${ns}::$sub" in $nscommands} { - dict set subcommand_dict $sub ${ns}::$sub - } else { - #subcommand probably supplied via -unknown handler? - dict set subcommand_dict $sub "" + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } } - } - } else { - if {[dict size $map]} { - set subcommand_dict $map } else { - set exportspecs [namespace eval $ns {namespace export}] - foreach pat $exportspecs { - lappend nscommands {*}[info commands ${ns}::$pat] - } - foreach fqc $nscommands { - dict set subcommand_dict [namespace tail $fqc] $fqc + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } } } - } - set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $queryargs]} { - set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand - if {$posn_subcommand > 0} { - set params [lrange $queryargs 0 $posn_subcommand-1] - set remaining_queryargs [lrange $queryargs $posn_subcommand end] - } else { - set params [list] - set remaining_queryargs $queryargs - } - if {[llength $remaining_queryargs]} { - if {$prefixes} { - set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + set subcommands [lsort [dict keys $subcommand_dict]] + if {[llength $queryargs]} { + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] } else { - set match [lindex $remaining_queryargs 0] + set params [list] + set remaining_queryargs $queryargs } - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - if {!$scheme_received} { - dict unset opts -scheme + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } - #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] - #use tailcall so %caller% is reported properly in error msg - tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } - } - set have_usageinfo [list] - set is_ensemble [list] - set is_object [list] - set is_class [list] - set is_native [list] - set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set targetfirstword [lindex $subwhat 0] - set ns [::namespace which $targetfirstword] - set ns [nsprefix $ns] - set targettail [namespace tail $targetfirstword] - if {![dict exists $namespaces $ns]} { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] - dict set namespaces $ns $nsinfo - } else { - set nsinfo [dict get $namespaces $ns] - } - if {$targettail in [dict get $nsinfo usageinfo]} { - lappend have_usageinfo $sub - } - if {$targettail in [dict get $nsinfo ensembles]} { - lappend is_ensemble $sub - } - if {$targettail in [dict get $nsinfo ooobjects]} { - lappend is_object $sub - } - if {$targettail in [dict get $nsinfo ooclasses]} { - lappend is_class $sub - } - if {$targettail in [dict get $nsinfo native]} { - lappend is_native $sub - } - } + #todo - synopsis? + set choicelabeldict [dict create] - #todo - synopsis? - set choicelabeldict [dict create] + set choiceinfodict [dict create] - set choiceinfodict [dict create] - foreach sub $subcommands { + dict for {sub subwhat} $subcommand_dict { + if {[llength $subwhat] > 1} { + #TODO - resolve using cmdinfo? + puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" + } + set targetfirstword [lindex $subwhat 0] + set targetinfo [cmdwhich $targetfirstword] + set targetorigin [dict get $targetinfo origin] + set targetcmdtype [dict get $targetinfo origintype] + set nstarget [nsprefix $targetorigin] - if {$sub in $is_ensemble} { - dict lappend choiceinfodict $sub {doctype ensemble} - } + dict lappend choiceinfodict $sub [list doctype $targetcmdtype] - if {$sub in $is_object} { - if {$sub in $is_class} { - dict lappend choiceinfodict $sub {doctype ooc} + if {[punk::args::id_exists [list $origin $sub]]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] + } elseif {[punk::args::id_exists $targetorigin]} { + dict lappend choiceinfodict $sub {doctype punkargs} + dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] } else { - dict lappend choiceinfodict $sub {doctype ooo} + #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" } - } - if {$sub in $is_native} { - dict lappend choiceinfodict $sub {doctype native} } - if {$sub in $have_usageinfo} { - #dict set choiceinfodict $sub [list {doctype punkargs}] - dict lappend choiceinfodict $sub {doctype punkargs} + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + puts "ENSEMBLE auto def $autoid (arginfo)" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated by arginfo) + ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } } + append argdef \n $vline + punk::args::define $argdef } + } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] - set autoid "(autodef)$origin" - set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} - @cmd -help\ - "(autogenerated) - ensemble: ${$origin}" - @leaders -min 1 - }] - if {[llength $parameters] == 0} { - append argdef \n "@leaders -min 1" - } else { - append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" - foreach p $parameters { - append argdef \n "$p -type string -help { (leading ensemble parameter)}" - } - } - append argdef \n $vline - punk::args::define $argdef + #if {$autoid ne ""} { + # return [punk::args::usage {*}$opts $autoid] + #} + + + #check ensemble before testing punk::arg::id_exists + #we want to recalculate ensemble usage info in case ensemble has been modified + + if {$autoid ne ""} { switch -- [dict get $opts -return] { string { set estyle "basic" @@ -3670,7 +4927,7 @@ tcl::namespace::eval punk::ns { } set origin_ns [nsprefix $origin] - set parts [nsparts $origin_ns] + set parts [nsparts_cached $origin_ns] set weird_ns 0 if {[lsearch $parts :*] >=0} { set weird_ns 1 @@ -3825,8 +5082,10 @@ tcl::namespace::eval punk::ns { set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] - #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! - if {$origin ni [info procs $origin]} { + #A renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! + #set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x + set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] + if {$origin ni $iproc} { #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. @@ -3861,17 +5120,32 @@ tcl::namespace::eval punk::ns { append body \n } if {![catch {package require textutil::tabify} errpkg]} { - set bodytext [info body $origin] + #set bodytext [info body $origin] + set bodytext [nseval $targetns [list ::info body $name]] #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { - append body [info body $origin] + #append body [info body $origin] + #relevant test test::punk::ns SUITE ns corp.test corp_leadingcolon_functionname + append body [nseval $targetns [list ::info body $name]] } set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set argnames [nseval $targetns [list ::info args $name]] + foreach a $argnames { + #if {[info default $origin $a defvar]} { + # lappend a $defvar + #} + set result [nseval $targetns [string map [list %n% $name %a% $a] { + #qualify all command names when running in arbitrary namespace + ::if {[::info default "%n%" "%a%" punk_ns_corp_defvar]} { + ::return [::list default $punk_ns_corp_defvar][::unset punk_ns_corp_defvar] ;#keep the targetns tidy + } else { + ::return [::list none] + } + }]] + if {[lindex $result 0] eq "default"} { + lappend a [lindex $result 1] } lappend argl $a } @@ -4165,13 +5439,13 @@ tcl::namespace::eval punk::ns { set ns_populated 0 set i 0 set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing - set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] + set ns_depth [llength [punk::ns::nsparts_cached [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base #e.g if we are loading ::x::y #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] - set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] + set k_depth [llength [punk::ns::nsparts_cached [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { set auto_source [set ::auto_index($k)] if {$auto_source ni $already_sourced} { @@ -4228,7 +5502,7 @@ tcl::namespace::eval punk::ns { } } return [dict create vars $capturevars arrs $capturearrs] - } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) + } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) (could use 'nsjoin [namespace current] *') } ] @@ -4282,7 +5556,7 @@ tcl::namespace::eval punk::ns { -targetnamespace -optional 1 -help\ "Namespace in which to import commands. If namespace is relative (no leading ::), - the namespace is relative to the caller'd namespace. + the namespace is relative to the caller's namespace. If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" @@ -4339,6 +5613,13 @@ tcl::namespace::eval punk::ns { if {[tcl::dict:::exists $received -prefix]} { #import via temporary/intermediate namespace set pfx [dict get $opts -prefix] + set import_via_temp 1 + } else { + set pfx "" + set import_via_temp 0 + } + set import_via_temp 1; #import to weirdns only works with tempns + if {$import_via_temp} { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp @@ -4350,7 +5631,11 @@ tcl::namespace::eval punk::ns { if {![catch {::tcl::namespace::eval $tmpns [list ::namespace import ${srcns}::$func]}]} { #renaming will fail if target already exists #renaming a command into another namespace still results in a command with 'info cmdtype' = 'import' - if {![catch {::tcl::namespace::eval $tmpns [list ::rename $func [::punk::ns::nsjoin $tgtns $pfx$func]]}]} { + #if {![catch {::tcl::namespace::eval $tmpns [list ::rename $func [::punk::ns::nsjoin $tgtns $pfx$func]]}]} { + # set cmd $pfx$func + #} + if {![catch {punk::ns::nseval $tgtns [list ::rename ${tmpns}::$func $pfx$func]}]} { + #renaming into a weirdns only works if run in the target ns. set cmd $pfx$func } } @@ -4367,7 +5652,15 @@ tcl::namespace::eval punk::ns { foreach e $a_exported_tails { set imported [apply {{tgtns func srcns} { set cmd "" - if {![catch {tcl::namespace::eval $tgtns [list namespace import ${srcns}::$func]}]} { + #if {![catch {tcl::namespace::eval $tgtns [list namespace import ${srcns}::$func]}]} { + # set cmd $func + #} + #namespace import doesn't seem to import into some weirdly named namespaces + #even if evaluated in that namespace + #e.g ns with leading colon. + #e.g ::jjj:::::aaa (jjj -> : -> aaa) + #will instead create new ns at ::jjj::aaa and import there. + if {![catch {punk::ns::nseval $tgtns [list namespace import ${srcns}::$func]}]} { set cmd $func } set cmd @@ -4397,6 +5690,10 @@ tcl::namespace::eval punk::ns { interp alias {} nslist {} punk::ns::nslist interp alias {} nslist_dict {} punk::ns::nslist_dict + interp alias {} cmdwhich {} punk::ns::cmdwhich + interp alias {} cmdinfo {} punk::ns::cmdinfo + interp alias {} cmdtype {} punk::ns::cmdtype + #extra slash implies more verbosity (ie display commands instead of just nschildren) interp alias {} n/ {} punk::ns::ns/ / interp alias {} n// {} punk::ns::ns/ // @@ -4415,7 +5712,8 @@ tcl::namespace::eval punk::ns { interp alias {} corp {} punk::ns::corp - interp alias {} i {} punk::ns::arginfo + interp alias {} i {} punk::ns::cmdhelp + interp alias {} j {} punk::ns::arginfo ;#todo - make obsolete #An example of using punk::args in a pipeline punk::args::define { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm index dabf7f8e..5b504e58 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm @@ -328,7 +328,7 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::$dp + $COMMANDSTACKNEXT require punk::args::moduledoc::$dp } } #--------------------------------------------------------------- diff --git a/src/vfs/_vfscommon.vfs/modules/punk/pcon-1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/pcon-1.0.tm index 7e9455cd..c3c36f64 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/pcon-1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/pcon-1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::pcon 0 1.0] +#[manpage_begin punkshell_module_punk::pcon 0 1.0] #[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/pdf-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/pdf-0.1.0.tm index 1ee63f53..111cd728 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/pdf-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/pdf-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::pdf 0 0.1.0] +#[manpage_begin punkshell_module_punk::pdf 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -114,7 +114,7 @@ namespace eval ::punk::pdf { " @leaders -min 0 -max 0 @opts -min 0 -max 2 - -p|-page_indexes -parsekey -page_indexes -type string -default "0.." -help\ + -p|-page_indexes -parsekey -page_indexes -type indexset -default "0.." -help\ "Comma delimited list of indexes and/or ranges specifying which pages to output. The indexes are 0-based. Ranges must be specified with .. as the separator. @@ -127,8 +127,9 @@ namespace eval ::punk::pdf { 0..2,end output the first 3 pages, and the last page. end-1..0 - output the pages in reverse order from 2nd last page to first page." - -b|-block_indexes -parsekey -block_indexes -type string -default "0.." -help\ + output the pages in reverse order from 2nd last page to first page. + see also 'punk::lib::resolve_indexset'" + -b|-block_indexes -parsekey -block_indexes -type indexset -default "0.." -help\ "Comma delimited list of indexes and/or ranges specifying which blocks to output. Format is as per -page_indexes" -merge_yblocks -default false -help\ @@ -1390,6 +1391,8 @@ namespace eval ::punk::pdf { return } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::pdf ---}] } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/pipe-1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/pipe-1.0.tm index 2b0500b8..eac7df81 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/pipe-1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/pipe-1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::pipe 0 1.0] +#[manpage_begin punkshell_module_punk::pipe 0 1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -61,48 +61,16 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::pipe::class { - #*** !doctools - #[subsection {Namespace punk::pipe::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::pipe { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools #[subsection {Namespace punk::pipe}] - #[para] Core API functions for punk::pipe + #[para] Core API functions for punk::pipe #[list_begin definitions] @@ -110,13 +78,13 @@ tcl::namespace::eval punk::pipe { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} #https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ @@ -735,16 +703,6 @@ tcl::namespace::eval punk::pipe::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::pipe::system { - #*** !doctools - #[subsection {Namespace punk::pipe::system}] - #[para] Internal functions that are not part of the API - - - -#} # == === === === === === === === === === === === === === === diff --git a/src/vfs/_vfscommon.vfs/modules/punk/pluginmgr-0.5.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/pluginmgr-0.5.1.tm new file mode 100644 index 00000000..6bdf3fec --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/pluginmgr-0.5.1.tm @@ -0,0 +1,441 @@ +# plugin.tcl -- +# +# Generic plugin management. +# +# Copyright (c) 2005 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ### ### ### ######### ######### ######### +## Description + +# Each instance of the plugin manager can be configured with data +# which specifies where to find plugins, and how to validate +# them. With that it can then be configured to load and provide access +# to a specific plugin, doing all required checks and +# initialization. Users for specific plugin types simply have to +# encapsulate the generic class, providing all the specifics, leaving +# their users only the task of naming the requested actual plugin. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 9 +package require snit +package require file::home ;# file home forward compatibility + +# ### ### ### ######### ######### ######### +## Implementation + +snit::type ::punk::pluginmgr { + + # ### ### ### ######### ######### ######### + ## Public API - Options + + # - Pattern to match package name. Exactly one '*'. No default. + # - List of commands the plugin has to provide. Empty list default. + # - Callback for additional checking after the API presence has + # been verified. Empty list default. + # - Dictionary of commands to put into the plugin interpreter. + # Key: cmds for plugin, value is cmds to invoke for them. + # - Interpreter to use for the -cmds (invoked commands). Default + # is current interp. + # - Callback for additional setup actions on the plugin + # interpreter after its creation, but before plugin is loaded into + # it. Empty list default. + + option -pattern {} + option -api {} + option -check {} + option -cmds {} + option -cmdip {} + option -setup {} + + # ### ### ### ######### ######### ######### + ## Public API - Methods + + method do {args} { + if {$plugin eq ""} { + return -code error "No plugin defined" + } + return [$sip eval $args] + } + + method interpreter {} { + return $sip + } + + method plugin {} { + return $plugin + } + + method load {name} { + if {$name eq $plugin} return + + if {$options(-pattern) eq ""} { + return -code error "Translation pattern is not configured" + } + + set save $sip + + $self SetupIp + if {![$self LoadPlugin $name]} { + set sip $save + return -code error "Unable to locate or load plugin \"$name\" ($myloaderror)" + } + + if {![$self CheckAPI missing]} { + set sip $save + return -code error \ + "Cannot use plugin \"$name\", API incomplete: \"$missing\" missing" + } + + set savedname $plugin + set plugin $name + if {![$self CheckExternal]} { + set sip $save + set plugin $savedname + return -code error \ + "Cannot use plugin \"$name\", API bad" + } + $self SetupExternalCmds + + if {$save ne ""} {interp delete $save} + return + } + + method unload {} { + if {$sip eq ""} return + interp delete $sip + set sip "" + set plugin "" + return + } + + method list {} { + if {$options(-pattern) eq ""} { + return -code error "Translation pattern is not configured" + } + + set save $sip + $self SetupIp + + set result {} + set pattern [string map [list \ + + \\+ ? \\? \ + \[ \\\[ \] \\\] \ + ( \\( ) \\) \ + . \\. \* {(.*)} \ + ] $options(-pattern)] + set bogus [string map {* bogus-package} $pattern] + # @mdgen NODEP: bogus-package + $sip eval [list catch [list package require $bogus]] + foreach p [$sip eval {package names}] { + if {![regexp $pattern $p -> plugintail]} continue + lappend result $plugintail + } + + interp delete $sip + set sip $save + return $result + } + + method path {path} { + set path [file join [pwd] $path] + if {[lsearch -exact $paths $path] < 0} { + lappend paths $path + } + return + } + + method paths {} { + return $paths + } + + method clone {} { + set o [$type create %AUTO% \ + -pattern $options(-pattern) \ + -api $options(-api) \ + -check $options(-check) \ + -cmds $options(-cmds) \ + -cmdip $options(-cmdip) \ + -setup $options(-setup)] + + $o __clone__ $paths $sip $plugin + + # Clone has become owner of the interp. + set sip {} + set plugin {} + + return $o + } + + method __clone__ {_paths _sip _plugin} { + set paths $_paths + set sip $_sip + set plugin $_plugin + return + } + + # ### ### ### ######### ######### ######### + ## Internal - Configuration and state + + variable paths {} ; # List of paths to provide the sip with. + variable sip {} ; # Safe interp used for plugin execution. + variable plugin {} ; # Name of currently loaded plugin. + variable myloaderror {} ; # Last error reported by the Safe base + + # ### ### ### ######### ######### ######### + ## Internal - Object construction and descruction. + + constructor {args} { + $self configurelist $args + return + } + + destructor { + if {$sip ne ""} {interp delete $sip} + return + } + + # ### ### ### ######### ######### ######### + ## Internal - Option management + + onconfigure -pattern {newvalue} { + set current $options(-pattern) + if {$newvalue eq $current} return + + set n [regexp -all "\\*" $newvalue] + if {$n < 1} { + return -code error "Invalid pattern, * missing" + } elseif {$n > 1} { + return -code error "Invalid pattern, too many *'s" + } + + set options(-pattern) $newvalue + return + } + + onconfigure -api {newvalue} { + set current $options(-api) + if {$newvalue eq $current} return + set options(-api) $newvalue + return + } + + onconfigure -cmds {newvalue} { + set current $options(-cmds) + if {$newvalue eq $current} return + set options(-cmds) $newvalue + return + } + + onconfigure -cmdip {newvalue} { + set current $options(-cmdip) + if {$newvalue eq $current} return + set options(-cmdip) $newvalue + return + } + + + # ### ### ### ######### ######### ######### + ## Internal - Helper commands + + method SetupIp {} { + set sip [::safe::interpCreate] + foreach p $paths { + ::safe::interpAddToAccessPath $sip $p + } + + if {![llength $options(-setup)]} return + uplevel \#0 [linsert $options(-setup) end $self $sip] + return + } + + method LoadPlugin {name} { + #if {[file exists $name]} { + # # Plugin files are loaded directly. + # $sip invokehidden source $name + # return 1 + #} + + #JN - diverging from tcllib - review + foreach p $paths { + set fp [file join $p $name] + #This won't load .tm files + if {[file exists $fp.tcl] && [file type $fp.tcl] eq "file"} { + # Plugin files can be loaded directly without pkgIndex.tcl + # This allows dropping of a single plugin.tcl file into a home or env based plugin path + # Such a file may override libs here or on auto_path, and may override modules already in tm path. + $sip invokehidden source $fp.tcl + return 1 + } + #if {[file exists [file join $p pkgIndex.tcl]]} { + # $sip invokehidden source [file join $p pkgIndex.tcl] + # #and pkgIndex.tcl one level deep - review + # set subdirs [glob -nocomplain -directory $p -types d -tails *] + # foreach s $subdirs { + # if {[file exists [file join $p $s pkgIndex.tcl]]} { + # $sip invokehidden source [file join $p $s pkgIndex.tcl] + # } + # } + # #continue below to load packages + #} + } + + # Otherwise the name is transformed into a package name + # and loaded thorugh the package management. + + set pluginpackage [string map \ + [list * $name] $options(-pattern)] + + ::safe::setLogCmd [mymethod PluginError] + if {[catch { + $sip eval [list package require $pluginpackage] + } res]} { + ::safe::setLogCmd {} + return 0 + } + ::safe::setLogCmd {} + return 1 + } + + method CheckAPI {mv} { + upvar 1 $mv missing + if {![llength $options(-api)]} {return 1} + + # Check the plugin for useability. + + foreach p $options(-api) { + if {[llength [$sip eval [list info commands $p]]] == 1} continue + interp delete $sip + set missing $p + return 0 + } + return 1 + } + + method CheckExternal {} { + if {![llength $options(-check)]} {return 1} + return [uplevel \#0 [linsert $options(-check) end $self]] + } + + + method SetupExternalCmds {} { + if {![llength $options(-cmds)]} return + + set cip $options(-cmdip) + foreach {pcmd ecmd} $options(-cmds) { + eval [linsert $ecmd 0 interp alias $sip $pcmd $cip] + #interp alias $sip $pcmd $cip {*}$ecmd + } + return + } + + method PluginError {message} { + if {[string match {*script error*} $message]} return + set myloaderror $message + return + } + + # ### ### ### ######### ######### ######### + + proc paths {pmgr args} { + if {[llength $args] == 0} { + return -code error "wrong#args: Expect \"[info level 0] object name...\"" + } + foreach name $args { + AddPaths $pmgr $name + } + return + } + + proc AddPaths {pmgr name} { + global env tcl_platform + + if {$tcl_platform(platform) eq "windows"} { + set sep \; + } else { + set sep : + } + + #puts "$pmgr += ($name) $sep" + + regsub -all {::+} [string trim $name :] \000 name + set name [split $name \000] + + # Environment variables + + set prefix {} + foreach part $name { + lappend prefix $part + set ev [string toupper [join $prefix _]]_PLUGINS + + #puts "+? env($ev)" + + if {[info exists env($ev)]} { + foreach path [split $env($ev) $sep] { + $pmgr path $path + } + } + } + + # Windows registry + + if { + ($tcl_platform(platform) eq "windows") && + ![catch {package require registry}] + } { + foreach root { + HKEY_LOCAL_MACHINE + HKEY_CURRENT_USER + } { + set prefix {} + foreach part $name { + lappend prefix $part + set rk $root\\SOFTWARE\\[join $prefix \\]PLUGINS + + #puts "+? registry($rk)" + + if {![catch {set data [registry get $rk {}]}]} { + foreach path [split $data $sep] { + $pmgr path $path + } + } + } + } + } + + # Home directory dot path + + set prefix {} + foreach part $name { + lappend prefix $part + set pd [file join [file home] .[join $prefix /] plugin] + #puts "+? path($pd)" + + if {[file exists $pd]} { + $pmgr path $pd + } + + # Cover for the goof in the example found in the docs. + # Note that supporting the directory name 'plugins' is + # also more consistent with the environment variables + # above, where we also use plugins, plural. + + set pd [file join [file home] .[join $prefix /] plugins] + #puts "+? path($pd)" + + if {[file exists $pd]} { + $pmgr path $pd + } + } + return + } +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide punk::pluginmgr 0.5.1 \ No newline at end of file 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 7d93d529..a5027d7b 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 @@ -3063,6 +3063,11 @@ namespace eval repl { return $stack } } + + #autodoc for ensemble, or a punk::args::define doc here + #will not alow discovery of the documentation from within an interp that has + #only alias access to this - as the docs (indeed even the namespace) won't + #exist in the calling interp. namespace eval ::repl::interphelpers::subshell_ensemble { namespace export {[a-z]*} namespace ensemble create @@ -3259,7 +3264,7 @@ namespace eval repl { debug\ punk::ns\ textblock\ - punk::args::tclcore\ + punk::args::moduledoc::tclcore\ punk::aliascore\ ] @@ -3333,8 +3338,8 @@ namespace eval repl { #review code alias ::shellfilter::stack ::shellfilter::stack #code alias ::punk::lib::set_clone ::punk::lib::set_clone - #code alias ::aliases ::punk::lib::aliases - code alias ::punk::lib::aliases ::punk::lib::aliases + #code alias ::aliases ::punk::ns::aliases + code alias ::punk::ns::aliases ::punk::ns::aliases namespace eval ::codeinterp {} code alias ::md5::md5 ::repl::interphelpers::md5 @@ -3443,7 +3448,7 @@ namespace eval repl { interp eval code { package require punk::lib package require punk::args - catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical + catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical package require textblock } @@ -3614,7 +3619,7 @@ namespace eval repl { }} [punk::config::configure running] package require textblock - catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical + catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical } errM]} { puts stderr "========================" puts stderr "code interp error:" @@ -3632,6 +3637,16 @@ namespace eval repl { } } code alias repl ::repl::interphelpers::repl_ensemble + code eval { + punk::args::define { + @id -id ::subshell + @cmd -name ::subshell\ + -summary "Launch in-process subshell"\ + -help "Launch a thread-based subshell" + shellname -type string -optional 0 -choices {punk punksafe safe safebase} + } + + } code alias subshell ::repl::interphelpers::subshell_ensemble code alias quit ::repl::interphelpers::quit code alias editbuf ::repl::interphelpers::editbuf diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ubl-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ubl-0.1.0.tm index 0bf1f671..52df2356 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ubl-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ubl-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::ubl 0 0.1.0] +#[manpage_begin punkshell_module_punk::ubl 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm index 38b99b8b..ee6b00bd 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::winshell 0 0.1.0] +#[manpage_begin punkshell_module_punk::winshell 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/tarjar-2.4.2.tm b/src/vfs/_vfscommon.vfs/modules/tarjar-2.4.2.tm new file mode 100644 index 00000000..c2c8464e Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/tarjar-2.4.2.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/termscheme-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/termscheme-0.1.0.tm index 0701c964..1d80803c 100644 --- a/src/vfs/_vfscommon.vfs/modules/termscheme-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/termscheme-0.1.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 # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,10 +18,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_termscheme 0 0.1.0] +#[manpage_begin punkshell_module_termscheme 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require termscheme] #[keywords module] #[description] @@ -61,38 +61,6 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval termscheme::class { - #*** !doctools - #[subsection {Namespace termscheme::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 ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -103,7 +71,7 @@ tcl::namespace::eval termscheme { #*** !doctools #[subsection {Namespace termscheme}] - #[para] Core API functions for termscheme + #[para] Core API functions for termscheme #[list_begin definitions] @@ -111,13 +79,13 @@ tcl::namespace::eval termscheme { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -137,14 +105,14 @@ tcl::namespace::eval termscheme::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace termscheme::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -160,19 +128,20 @@ tcl::namespace::eval termscheme::lib { #*** !doctools #[section Internal] #tcl::namespace::eval termscheme::system { + #*** !doctools #[subsection {Namespace termscheme::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide termscheme [tcl::namespace::eval termscheme { variable pkg termscheme variable version - set version 0.1.0 + set version 0.1.0 }] return 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 b8140b8f..0394959e 100644 Binary files a/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm and b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/ns-0.1.0.tm new file mode 100644 index 00000000..1b9c443f Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/test/punk/ns-0.1.0.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm index 43311b9e..81fd9bc1 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -58,7 +58,6 @@ package require punk::args package require punk::char package require punk::ansi package require punk::lib -catch {package require patternpunk} package require overtype package require struct::set diff --git a/src/vfs/_vfscommon.vfs/modules/vfs/inmem-0.1.tm b/src/vfs/_vfscommon.vfs/modules/vfs/inmem-0.1.tm deleted file mode 100644 index e1aa76cc..00000000 --- a/src/vfs/_vfscommon.vfs/modules/vfs/inmem-0.1.tm +++ /dev/null @@ -1,495 +0,0 @@ - -#START-tarpack-loadscript-header---------------------------------------------------------------------------- -# -#If there is data above this header, then this is a tarpack. Do not edit the code whilst in 'packed' form. -# -#If there is no data above the header, it is an unpacked fragment of a tarpack and may be edited. -#Make sure however that your editor preserves the trailing comment (#) as the final character. -# -# A tarpack is a valid tar archive in which the first archived file consists of tcl script -# containing a leading newline and a trailing comment (#) character. -# The comment character hides the tar-header for the next file from Tcl. -# This first file in the tarball must be named with the prefix #tarpack-loadscript -# -# The next file is named #z and contains a final ctrl-z to tell Tcl it has reached the end of scripts -# (and thus to stop interpreting). -# The #z file is separate from the initial script file because some editors may not be able to handle the -# ctrl-z character. -# The tarball should have its contents within a single directory named #tarpack-- -# -# This header and the call to tarpack::disconnect are needed to: -# a) redirect to the unwrapped version of the tarpack -# b) enable sourcing & loading of other files contained in the tarpack - - -set TEMP_auto_path $::auto_path; set ::auto_path [list] -if {![catch {package require tarpack}]} { - #Do not wrap 'tarpack::connect' in its own 'catch'! - #for unwrapped execution, tarpack::connect may need to abort the 'source' operation using returneval. - set ::auto_path $TEMP_auto_path; unset TEMP_auto_path - ::tarpack::connect [info script] -} else { - set ::auto_path $TEMP_auto_path; unset TEMP_auto_path -} - - -# -#END-tarpack-loadscript-header------------------------------------------------------------------------------ - - - - -#START-tarpack-loadscript-tidy------------------------------------------------------------------------------ -# -::tarpack::disconnect [info script] -# -#END-tarpack-loadscript-tidy-------------------------------------------------------------------------------- -#This tarpack initially generated using tarpack::wrap inmem-1.0.tcl -#-------------------------script + tarpack footer follow------------------------- - -# Package vfs::inmem provides an in-memory file system; this is -# useful if you want a small file system on which you can -# mount other kinds of files and store small amounts of data. - -package provide vfs::inmem 0.1 - -# We use dicts, so we need Tcl 8.5 or later. - -package require Tcl 8.5- -package require vfs 1.0- - -# The "fsdata" array contains dicts describing file systems. The dicts -# represents a file structure. The file structure uses the following keys: -# -# data the file's data; what this is depends on the "type" -# attribute of the "stat" entry for the file. (See below.) -# For type "directory", it is a dict whose keys are directory -# names; the dict entries will be file structures. -# -# stat file attributes: file type, access permissions, etc. -# The data associated with this key is a dictionary -# containing data in the form returned by the "file stat" -# command. The only mandatory info is the file type. -# -# meta metadata associated with this file. This could be -# anything. -# -# fsdata is indexed by an arbitrarily-selected key supplied by the -# "Mount" command. - -namespace eval vfs::inmem { - variable fsdata - variable localmap -} - - -################################# -# # -# U T I L I T I E S # -# # -################################# - -# _dictpath converts "relpath" to a list of keys that indexes -# into the nested file structures. "relpath" is assumed to be -# a list of pathname components. (Basicly, this consists of putting -# the word "data" before the list element names.) No checking -# is done to ensure that the path is valid. - -proc vfs::inmem::_dictpath {relpath} { - set keylist [list] - foreach component $relpath { - lappend keylist data $component - } - return $keylist -} - -# _checkpath checks a relative path to make sure that all components -# except the last exist and are directories. It returns 1 on success, -# and throws an error otherwise. - -proc vfs::inmem::_checkpath {fsname relpath} { - variable fsdata - - if {![info exists fsdata($fsname)]} { - return -code error "File system \"$fsname\" doesn't exist." - } - - set dirdata $fsdata($fsname) - set reldir [lrange $relpath 0 end-1] - set file [lindex $relpath end] - - foreach component $reldir { - if {![string equal [dict get $dirdata stat type] "directory"]} { - return -code error "Path component is not a directory" - } - - set dirdata [dict get $dirdata data] - set dirdata [dict get $dirdata $component] - } - - return 1 -} - -# _getfiledict returns the dictionary associated with the file -# within file system "fsname" that is specified by "relpath". - -proc vfs::inmem::_getfiledict {fsname relpath} { - variable fsdata - - set dictpath [_dictpath $relpath] - if {[llength $dictpath] == 0} { - return $fsdata($fsname) - } - #return [eval [list dict get $fsdata($fsname)] $dictpath] - dict get $fsdata($fsname) {expand}$dictpath -} - -# _newstatinfo creates a dictionary appropriate for use as the "stat" -# entry for a file of type "type". - -proc vfs::inmem::_newstatinfo {type} { - return [dict create \ - atime [clock seconds] \ - ctime [clock seconds] \ - dev -1 \ - gid -1 \ - ino -1 \ - mode 0777 \ - mtime [clock seconds] \ - nlink 1 \ - size 0 \ - type $type \ - uid -1 \ - ] -} - -# _updatetime updates access/creation/modification times for -# the file given by "relpath". Which time to update is determined -# by the "timetype" argument, which should be one of "atime", -# "ctime", or "mtime". (This argument is NOT checked, so be careful!) - -proc vfs::inmem::_updatetime {fsname relpath timetype} { - variable fsdata - - set fpath [_dictpath $relpath] - dict set fsdata($fsname) {expand}$fpath stat $timetype [clock seconds] -} - -################################# -# # -# V F S P R O C S # -# # -################################# - -# The procs that follow are the ones required by the Tcl vfs package. - - -# Mount mounts an in-memory file system named "fsname" on the -# local mount point "local". "fsname" is an arbitrary key; -# it must be unique among all inmem vfs file systems. It returns -# the mount point. - -proc vfs::inmem::Mount {fsname local} { - variable fsdata - variable localmap - - # Make an empty directory. - - set fsdata($fsname) [dict create \ - data [dict create] \ - stat [_newstatinfo directory] \ - meta "" \ - ] - - vfs::filesystem mount $local [list vfs::inmem::handler $fsname] - vfs::RegisterMount $local [list vfs::inmem::Unmount] - set localmap($local) $fsname - - return $local -} - -# Unmount unmounts file system "local". - -proc vfs::inmem::Unmount {local} { - variable fsdata - variable localmap - - set fsname $localmap($local) - catch [list unset fsdata(fsname)] - vfs::filesystem unmount $local -} - -# This is the generic handler for file system commands. It dispatches -# calls to other handler functions. - -proc vfs::inmem::handler {fsname cmd root relative actualpath args} { - variable fsdata - - set relative [file split $relative] - - if {$cmd == "matchindirectory"} { - #eval [list $cmd $fsname $relative $actualpath] $args - $cmd $fsname $relative $actualpath {expand}$args - } else { - #eval [list $cmd $fsname $relative] $args - $cmd $fsname $relative {expand}$args - } -} - -# "stat" implements the "file stat" command. It accepts the -# file system name and the path name as arguments, and -# returns the file's status info as a dict. - -proc vfs::inmem::stat {fsname name} { - _checkpath $fsname $name - set fdict [_getfiledict $fsname $name] - return [dict get $fdict stat] -} - -proc vfs::inmem::access {fsname name mode} { - variable fsdata - - _checkpath $fsname $name - - set fdict [_getfiledict $fsname $name] - - set statInfo [dict get $fdict stat] - set fmode [dict get $statInfo mode] - - # We're assuming the file is owned by us and has our own - # gid. (Since it's seen only within this app, that has - # to be true.) - - return [expr {($mode & $fmode) != 0}] -} - -# vfs::inmem::exists returns 1 if file "name" exists on file -# system "fsname"; it returns zero otherwise. - -proc vfs::inmem::exists {fsname name} { - set ecode [catch [list _getfiledict $fsname $name] fdict] - - if {$ecode} { - return 0 - } - return 1 -} - -# Open a file. This returns a list containing two elements: -# 1. the Tcl channel name which has been opened -# 2. (optional) a command to evaluate when the channel is closed. - -proc vfs::inmem::open {fsname name mode permissions} { - variable fsdata - - - switch -- $mode { - "" - - "r" { - # The file was opened for read; we'll read the - # data out of the filesystem's dict and stuff - # it into a memchan file descriptor. We pass - # the memchan file descriptor back so that the - # data can be read from it. - - set nfd [vfs::memchan] - fconfigure $nfd -translation binary - set fdict [_getfiledict $fsname $name] - puts -nonewline $nfd [dict get $fdict data] - _updatetime $fsname $name atime - fconfigure $nfd -translation auto - seek $nfd 0 - return [list $nfd] - } - "w" { - # Open for write; we pass back an empty memchan, - # and on close we read the data out of it and put - # it into the file. - - set dictpath [_dictpath $name] - if {![exists $fsname $name]} { - set emptydata [dict create data {} \ - stat [_newstatinfo file] \ - meta {}] - dict set fsdata($fsname) {expand}$dictpath $emptydata - _updatetime $fsname $name ctime - _updatetime $fsname $name atime - } - _updatetime $fsname $name mtime - dict set fsdata($fsname) {expand}$dictpath stat size 0 - set nfd [vfs::memchan] - return [list $nfd [list ::vfs::inmem::_close $fsname $name $nfd]] - } - "a" { - # Open for append; this is pretty much like write, except - # that we put the data in it initially. - - set dictpath [_dictpath $name] - if {![exists $fsname $name]} { - set emptydata [dict create data {} \ - stat [_newstatinfo file] \ - meta {}] - dict set fsdata($fsname) {expand}$dictpath $emptydata - set initData "" - _updatetime $fsname $name ctime - _updatetime $fsname $name atime - } else { - set initData [dict get $fsdata($fsname) {expand}$dictpath data] - } - _updatetime $fsname $name mtime - dict set fsdata($fsname) {expand}$dictpath stat size \ - [string bytelength $initData] - set nfd [vfs::memchan] - fconfigure $nfd -translation binary - puts -nonewline $nfd $initData - _updatetime $fsname $name atime - fconfigure $nfd -translation auto - return [list $nfd [list ::vfs::inmem::_close $fsname $name $nfd]] - } - default { - return -code error "illegal or unimplemented access mode \"$mode\"" - } - } -} - - -# _close is called when we close a file we're writing to. It reads -# the data out of the memchan it was written to and puts it into -# the filesystem's dict. - -proc vfs::inmem::_close {fsname name nfd} { - variable fsdata - - set fpath [_dictpath $name] - seek $nfd 0 - set filedata [read $nfd] - dict set fsdata($fsname) {expand}$fpath data $filedata - dict set fsdata($fsname) {expand}$fpath stat size \ - [string bytelength $filedata] - _updatetime $fsname $name mtime - - close $nfd -} - - -# vfs::inmem::matchindirectory does a glob-style match on a single -# directory in an inmem filesystem. - -proc vfs::inmem::matchindirectory {fsname path actualpath pattern type} { - set dirdict [_getfiledict $fsname $path] - - # "res" will contain the matched directory. - - set res [list] - set filelist [dict get $dirdict data] - foreach f [dict keys $filelist] { - if {[string length $pattern] == 0 || [string match $pattern $f]} { - set ftype [dict get $filelist $f stat type] - switch $ftype { - directory { - if {[::vfs::matchDirectories $type]} { - lappend res $f - } - } - file { - if {[::vfs::matchFiles $type]} { - lappend res $f - } - } - link { - #@@@ NOT YET IMPLEMENTED @@@# - } - } - } - } - - # Prepend the directory name onto every name in the list. - - set realres [list] - foreach r $res { - lappend realres [file join $actualpath $r] - } - - return $realres -} - - -# vfs::inmem::createdirectory creates a directory entry for -# an inmem filesystem. It creates an entry in the filesystem's -# dict. - -proc vfs::inmem::createdirectory {fsname name} { - variable fsdata - - if {[string equal "" $name]} { - return - } - - if {[exists $fsname $name]} { - return - } - - set parent [lrange $name 0 end-1] - set dirname [lindex $name end] - set dictpath [_dictpath $parent] - lappend dictpath data - set newdir [dict create \ - data {} \ - stat [_newstatinfo directory] \ - ] - - dict set fsdata($fsname) {expand}$dictpath $dirname $newdir - _updatetime $fsname $parent mtime -} - - -# Remove a directory. - -proc vfs::inmem::removedirectory {fsname name recursive} { - variable fsdata - - set parent [lrange $name 0 end-1] - set dictpath [_dictpath $name] - dict unset fsdata($fsname) {expand}$dictpath - _updatetime $fsname $parent mtime -} - - -# Delete a file. - -proc vfs::inmem::deletefile {fsname name} { - variable fsdata - - set parent [lrange $name 0 end-1] - set dictpath [_dictpath $name] - dict unset fsdata($fsname) {expand}$dictpath - _updatetime $fsname $parent mtime -} - - -# fileattributes returns or sets filesystem-dependent file attributes. - -proc vfs::inmem::fileattributes {fsname name args} { - switch -- [llength $args] { - 0 { - # list strings - return [list "Unimplemented"] - } - 1 { - # get value - } - 2 { - # set value - } - } -} - - -#@@@ I don't know if this is necessary... @@@# - -proc vfs::inmem::utime {what name actime mtime} { - error "" -} - -#Do not remove the trailing comment character from this file. -# \ No newline at end of file