21 changed files with 2273 additions and 546 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,412 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::assertion 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::assertion 0 999999.0a1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::assertion] |
||||||
|
#[keywords module assertion assert debug] |
||||||
|
#[description] |
||||||
|
#[para] The punk::assertion library has the same semantics as Tcllib's control::assert library for the assert command itself. |
||||||
|
#[para] The main difference is the way in which assert is enabled/disabled in namespaces. |
||||||
|
#[para] Due to commands such as 'namespace path' - the assert command could be available in arbitrary namespaces unrelated by tree structure to namespaces where assert has been directly imported. |
||||||
|
#[para] punk::assertion::active 0|1 allows activating and deactivating assertions in any namespace where the assert command is available - but only affecting the activations state of the namespace in which it is called. |
||||||
|
#[para] If such a non-primary assertion namespace never had active set to 0 or 1 - then it will activate/deactivate when the namespace corresponding to the found assert command (primary) is activated/deactivated. |
||||||
|
#[para] Once marked active or inactive - such a non-primary namespace will no longer follow the primary |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::assertion |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::assertion |
||||||
|
#[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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::assertion::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [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 ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin |
||||||
|
namespace eval punk::assertion::primary { |
||||||
|
|
||||||
|
namespace export * |
||||||
|
proc assertActive {expr args} { |
||||||
|
|
||||||
|
set code [catch {uplevel 1 [list expr $expr]} res] |
||||||
|
if {$code} { |
||||||
|
return -code $code $res |
||||||
|
} |
||||||
|
if {![string is boolean -strict $res]} { |
||||||
|
return -code error "invalid boolean expression: $expr" |
||||||
|
} |
||||||
|
|
||||||
|
if {$res} {return} |
||||||
|
|
||||||
|
if {[llength $args]} { |
||||||
|
#set msg "[join $args]" |
||||||
|
set msg "$args punk::assertion failed expr $expr" |
||||||
|
} else { |
||||||
|
set msg "punk::assertion failed expr $expr" ;#give a clue in the default msg about which assert lib is in use |
||||||
|
} |
||||||
|
|
||||||
|
upvar ::punk::assertion::CallbackCmd CallbackCmd |
||||||
|
# Might want to catch this |
||||||
|
namespace eval :: $CallbackCmd [list $msg] |
||||||
|
} |
||||||
|
proc assertInactive args {} |
||||||
|
|
||||||
|
} |
||||||
|
namespace eval punk::assertion::secondary { |
||||||
|
namespace export * |
||||||
|
#we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. |
||||||
|
proc assertActive {expr args} [info body ::punk::assertion::primary::assertActive] |
||||||
|
proc assertInactive args {} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::assertion { |
||||||
|
variable CallbackCmd [list return -code error] |
||||||
|
namespace import ::punk::assertion::primary::assertActive |
||||||
|
rename assertActive assert |
||||||
|
|
||||||
|
namespace export * |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion}] |
||||||
|
#[para] Core API functions for punk::assertion |
||||||
|
#[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" |
||||||
|
#} |
||||||
|
|
||||||
|
#like tcllib's control::assert - we are limited to the same callback for all namespaces. |
||||||
|
#review - a per namespace - or per assert command callback may be tricky to do performantly. |
||||||
|
#Would probably involve rewriting the proc body - otherwise we have a runtime penalty in the assert of looking it up. |
||||||
|
proc callback {args} { |
||||||
|
#set nscaller [uplevel 1 [list namespace current]] |
||||||
|
#set which_assert [namespace eval $nscaller {namespace which assert}] |
||||||
|
|
||||||
|
upvar ::punk::assertion::CallbackCmd cb |
||||||
|
set n [llength $args] |
||||||
|
if {$n > 1} { |
||||||
|
return -code error "wrong # args: should be\ |
||||||
|
\"[lindex [info level 0] 0] ?command?\"" |
||||||
|
} |
||||||
|
if {$n} { |
||||||
|
set cb [lindex $args 0] |
||||||
|
return |
||||||
|
} |
||||||
|
return $cb |
||||||
|
} |
||||||
|
|
||||||
|
proc active {{on_off ""}} { |
||||||
|
set nscaller [uplevel 1 [list namespace current]] |
||||||
|
set which_assert [namespace eval $nscaller {namespace which assert}] |
||||||
|
#puts "nscaller:'$nscaller'" |
||||||
|
#puts "which_assert: $which_assert" |
||||||
|
|
||||||
|
if {$on_off eq ""} { |
||||||
|
if {$which_assert eq ""} {return 0} |
||||||
|
set assertorigin [namespace origin $which_assert] |
||||||
|
#puts "ns which assert: $which_assert" |
||||||
|
#puts "ns origin assert: $assertorigin" |
||||||
|
return [expr {"assertActive" eq [namespace tail $assertorigin]}] |
||||||
|
} |
||||||
|
if {![string is boolean -strict $on_off]} { |
||||||
|
error "invalid boolean value : $on_off" |
||||||
|
} else { |
||||||
|
set info_command [namespace eval $nscaller {info commands assert}] |
||||||
|
if {$on_off} { |
||||||
|
#Enable it in calling namespace |
||||||
|
if {"assert" eq $info_command} { |
||||||
|
#There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) |
||||||
|
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { |
||||||
|
namespace eval $nscaller { |
||||||
|
set assertorigin [namespace origin assert] |
||||||
|
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||||
|
switch -- $assertorigin_ns { |
||||||
|
::punk::assertion { |
||||||
|
#original import - switch to primary origin |
||||||
|
rename assert {} |
||||||
|
namespace import ::punk::assertion::primary::assertActive |
||||||
|
rename assertActive assert |
||||||
|
} |
||||||
|
::punk::assertion::primary - ::punk::assertion::secondary { |
||||||
|
#keep using from same origin ns |
||||||
|
rename assert {} |
||||||
|
namespace import ${assertorigin_ns}::assertActive |
||||||
|
rename assertActive assert |
||||||
|
} |
||||||
|
default { |
||||||
|
error "The assert command in this namespace is not from punk::assertion package. Use the enable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
#assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace |
||||||
|
namespace eval $nscaller { |
||||||
|
set assertorigin [namespace origin assert] |
||||||
|
if {[string match ::punk::assertion::* $assertorigin]} { |
||||||
|
namespace import ::punk::assertion::secondary::assertActive |
||||||
|
rename assertActive assert |
||||||
|
} else { |
||||||
|
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" |
||||||
|
} |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#no assert command reachable |
||||||
|
puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#Disable |
||||||
|
if {"assert" eq $info_command} { |
||||||
|
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { |
||||||
|
#assert is present in callers NS |
||||||
|
namespace eval $nscaller { |
||||||
|
set assertorigin [namespace origin assert] |
||||||
|
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||||
|
switch -glob -- $assertorigin_ns { |
||||||
|
::punk::assertion { |
||||||
|
#original import |
||||||
|
rename assert {} |
||||||
|
namespace import punk::assertion::primary::assertInactive |
||||||
|
rename assertInactive assert |
||||||
|
} |
||||||
|
::punk::assertion::primary - ::punk::assertion::secondary { |
||||||
|
#keep using from same origin ns |
||||||
|
rename assert {} |
||||||
|
namespace import ${assertorigin_ns}::assertInactive |
||||||
|
rename assertInactive assert |
||||||
|
} |
||||||
|
default { |
||||||
|
error "The assert command in this namespace is not from punk::assertion package. Use the disable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} else { |
||||||
|
#assert not present in callers NS - first install of secondary (if assert is from punk::assertion::*) |
||||||
|
namespace eval $nscaller { |
||||||
|
set assertorigin [namespace origin assert] |
||||||
|
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||||
|
if {[string match ::punk::assertion::* $assertorigin]} { |
||||||
|
namespace import ::punk::assertion::secondary::assertInactive |
||||||
|
rename assertInactive assert |
||||||
|
} else { |
||||||
|
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" |
||||||
|
} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no assert command reachable |
||||||
|
#If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path |
||||||
|
puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::assertion ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::assertion::lib { |
||||||
|
namespace export * |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::assertion::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::assertion::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
#Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version |
||||||
|
#nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system |
||||||
|
proc nsprefix {{nspath {}}} { |
||||||
|
#normalize the common case of :::: |
||||||
|
set nspath [string map [list :::: ::] $nspath] |
||||||
|
set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] |
||||||
|
if {$rawprefix eq "::"} { |
||||||
|
return $rawprefix |
||||||
|
} else { |
||||||
|
if {[string match *:: $rawprefix]} { |
||||||
|
return [string range $rawprefix 0 end-2] |
||||||
|
} else { |
||||||
|
return $rawprefix |
||||||
|
} |
||||||
|
#return [string trimright $rawprefix :] |
||||||
|
} |
||||||
|
} |
||||||
|
#see also punk::ns - keep in sync |
||||||
|
proc nstail {nspath args} { |
||||||
|
#normalize the common case of :::: |
||||||
|
set nspath [string map [list :::: ::] $nspath] |
||||||
|
set mapped [string map [list :: \u0FFF] $nspath] |
||||||
|
set parts [split $mapped \u0FFF] |
||||||
|
|
||||||
|
set defaults [list -strict 0] |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set strict [dict get $opts -strict] |
||||||
|
|
||||||
|
if {$strict} { |
||||||
|
foreach p $parts { |
||||||
|
if {[string match :* $p]} { |
||||||
|
error "nstail unpaired colon ':' in $nspath" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. |
||||||
|
return [lindex $parts end] |
||||||
|
} |
||||||
|
proc nsjoin {prefix name} { |
||||||
|
if {[string match ::* $name]} { |
||||||
|
if {"$prefix" ne ""} { |
||||||
|
error "nsjoin: won't join non-empty prefix to absolute namespace path '$name'" |
||||||
|
} |
||||||
|
return $name |
||||||
|
} |
||||||
|
if {"$prefix" eq "::"} { |
||||||
|
return ::$name |
||||||
|
} |
||||||
|
#if {"$name" eq ""} { |
||||||
|
# return $prefix |
||||||
|
#} |
||||||
|
#nsjoin ::x::y "" should return ::x::y:: - this is the correct fully qualified form used to call a command that is the empty string |
||||||
|
return ${prefix}::$name |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::assertion [namespace eval punk::assertion { |
||||||
|
variable pkg punk::assertion |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,3 @@ |
|||||||
|
0.1.0 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
Loading…
Reference in new issue