# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt # module template: punkshell/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 0.1.0 # Meta platform tcl # Meta license # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[manpage_begin punkshell_module_punk::assertion 0 0.1.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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::assertion::class { #*** !doctools #[subsection {Namespace punk::assertion::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 ---}] } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { #tcl::namespace::export {[a-z]*} tcl::namespace::export assertActive assertInactive proc assertActive {expr args} { set code [catch {uplevel 1 [list expr $expr]} res] if {$code} { return -code $code $res } if {![tcl::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 tcl::namespace::eval :: $CallbackCmd [list $msg] } proc assertInactive args {} } tcl::namespace::eval punk::assertion::secondary { tcl::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} [tcl::info::body ::punk::assertion::primary::assertActive] proc assertInactive args {} } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::assertion { variable CallbackCmd [list return -code error] #puts --------AAA #*very* slow in safe interp - why? #tcl::namespace::import ::punk::assertion::primary::assertActive proc do_ns_import {} { uplevel 1 [list tcl::namespace::import ::punk::assertion::primary::assertActive] } do_ns_import #puts --------BBB rename assertActive assert } tcl::namespace::eval punk::assertion { tcl::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 [tcl::info::level 0] 0] ?command?\"" } if {$n} { set cb [lindex $args 0] return } return $cb } proc active {{on_off ""}} { set nscaller [uplevel 1 [list tcl::namespace::current]] set which_assert [tcl::namespace::eval $nscaller {tcl::namespace::which assert}] #puts "nscaller:'$nscaller'" #puts "which_assert: $which_assert" if {$on_off eq ""} { if {$which_assert eq ""} {return 0} set assertorigin [tcl::namespace::origin $which_assert] #puts "ns which assert: $which_assert" #puts "ns origin assert: $assertorigin" return [expr {"assertActive" eq [tcl::namespace::tail $assertorigin]}] } if {![tcl::string::is boolean -strict $on_off]} { error "invalid boolean value : $on_off" } else { set info_command [tcl::namespace::eval $nscaller {tcl::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]} { tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] switch -- $assertorigin_ns { ::punk::assertion { #original import - switch to primary origin rename assert {} tcl::namespace::import ::punk::assertion::primary::assertActive rename assertActive assert } ::punk::assertion::primary - ::punk::assertion::secondary { #keep using from same origin ns rename assert {} tcl::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 tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { tcl::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 tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] switch -glob -- $assertorigin_ns { ::punk::assertion { #original import rename assert {} tcl::namespace::import punk::assertion::primary::assertInactive rename assertInactive assert } ::punk::assertion::primary - ::punk::assertion::secondary { #keep using from same origin ns rename assert {} tcl::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::*) tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { tcl::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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::assertion::lib { tcl::namespace::export * tcl::namespace::path [tcl::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] tcl::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 [tcl::string::map [list :::: ::] $nspath] set rawprefix [tcl::string::range $nspath 0 end-[tcl::string::length [nstail $nspath]]] if {$rawprefix eq "::"} { return $rawprefix } else { if {[tcl::string::match *:: $rawprefix]} { return [tcl::string::range $rawprefix 0 end-2] } else { return $rawprefix } #return [tcl::string::trimright $rawprefix :] } } #see also punk::ns - keep in sync proc nstail {nspath args} { #normalize the common case of :::: set nspath [tcl::string::map [list :::: ::] $nspath] set mapped [tcl::string::map [list :: \u0FFF] $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] set opts [tcl::dict::merge $defaults $args] set strict [tcl::dict::get $opts -strict] if {$strict} { foreach p $parts { if {[tcl::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 {[tcl::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 [tcl::namespace::eval punk::assertion { variable pkg punk::assertion variable version set version 0.1.0 }] return #*** !doctools #[manpage_end]