# -*- 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]