122 changed files with 27519 additions and 11036 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,3 @@
|
||||
0.1.1 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -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 <pkg>-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 <unspecified> |
||||
# @@ 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 "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::args::testcmd::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {<unspecified>} |
||||
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 |
||||
|
||||
@ -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 <pkg>-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 |
||||
@ -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 <pkg>-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 |
||||
|
||||
@ -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 <pkg>-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 |
||||
@ -1,3 +1,3 @@
|
||||
0.1.0 |
||||
0.1.2 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,441 @@
|
||||
# plugin.tcl -- |
||||
# |
||||
# Generic plugin management. |
||||
# |
||||
# Copyright (c) 2005 Andreas Kupries <andreas_kupries@sourceforge.net> |
||||
# |
||||
# 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 |
||||
@ -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\ |
||||
] |
||||
|
||||
} |
||||
@ -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 |
||||
] |
||||
|
||||
|
||||
|
||||
} |
||||
@ -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 |
||||
] |
||||
} |
||||
@ -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 <pkg>-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 <julian@precisium.com.au>"} |
||||
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 |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
||||
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
Binary file not shown.
@ -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-<package>-<version> |
||||
# |
||||
# 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. |
||||
# |
||||
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
||||
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
@ -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 <pkg>-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 <julian@precisium.com.au>} {test <test@example.com}} |
||||
set contact "" |
||||
foreach a $authors { |
||||
append contact $a \n |
||||
} |
||||
return $contact |
||||
} |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@dynamic |
||||
@id -id "pipe::about" |
||||
@cmd -name "pipe::about" -help\ |
||||
"About pipe |
||||
... |
||||
" |
||||
-return -type string\ |
||||
-default table\ |
||||
-choices {string table tableobject}\ |
||||
-choicelabels { |
||||
string "basic layout type" |
||||
table "layout in table borders |
||||
(requires package: textblock)" |
||||
tableobject "textblock::class::table object instance" |
||||
} |
||||
-help\ |
||||
"Choose the return type of the 'about' information" |
||||
topic -choices {license version contact *}\ |
||||
-choicelabels { |
||||
|
||||
}\ |
||||
-multiple 1\ |
||||
-help\ |
||||
"Topic to display. Omit or specify as * to see all" |
||||
}] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::get_by_id pipe::about $args] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set opt_return [dict get $opts -return] |
||||
if {![dict exists $received topic]} { |
||||
set val_topics [pipe::argdoc::about_topics] |
||||
} else { |
||||
set val_topics [dict get $values topic] ;#if -multiple is true, this is a list |
||||
} |
||||
if {$opt_return ne "string"} { |
||||
package require textblock ;#table support |
||||
set is_table 1 |
||||
set t [textblock::class::table create pipe::argdoc::tbl_about] |
||||
$t configure -frametype double |
||||
|
||||
} else { |
||||
set topiclens [lmap t $val_topics {string length $t}] |
||||
set widest_topic [tcl::mathfunc::max {*}$topiclens] |
||||
set is_table 0 |
||||
} |
||||
set about "" |
||||
foreach topic $val_topics { |
||||
if {[info commands pipe::argdoc::get_topic_$topic] ne ""} { |
||||
set topic_contents [pipe::argdoc::get_topic_$topic] |
||||
} else { |
||||
set topic_contents "<unavailable>" |
||||
} |
||||
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] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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 <pkg>-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 <unspecified> |
||||
# @@ 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 "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::args::testcmd::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {<unspecified>} |
||||
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 |
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue