# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) 2023 # # @@ Meta Begin # Application punk::ns 0.1.0 # Meta platform tcl # Meta license # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz package require punk::lib package require punk::args tcl::namespace::eval ::punk::ns::evaluator { #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ns { variable ns_current "::" variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp catch { package require debug debug define punk.ns.compile #debug on punk.ns.compile #debug level punk.ns.compile 3 } #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current set ns_caller [uplevel 1 {::namespace current}] #puts stderr "ns_cur:$ns_current ns_call:$ns_caller" set types [list all] set nspathcommands 0 if {$v eq "/"} { set types [list children] } if {$v eq "///"} { set nspathcommands 1 } set ns_or_glob [string map {:::: ::} $ns_or_glob] #todo - cooperate with repl? set out "" if {$ns_or_glob eq ""} { set is_absolute 1 set ns_queried $ns_current set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] if {$is_absolute} { if {!$has_globchars} { if {![nsexists $ns_or_glob]} { error "cannot change to namespace $ns_or_glob" } set ns_current $ns_or_glob set ns_queried $ns_current tailcall ns/ $v "" } else { set ns_queried $ns_or_glob set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] } } else { if {!$has_globchars} { set nsnext [nsjoin $ns_current $ns_or_glob] if {![nsexists $nsnext]} { error "cannot change to namespace $ns_or_glob" } set ns_current $nsnext set ns_queried $nsnext set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] } } } set ns_display "\n$ns_queried" if {$ns_current eq $ns_queried} { if {$ns_current in [info commands $ns_current] } { if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { if {[llength $ensemble_info] > 0} { #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" } } } } append out $ns_display return $out } #create possibly nested namespace structure - but only if not already existant proc n/new {args} { variable ns_current if {![llength $args]} { error "usage: :/new \[ ...\]" } set a1 [lindex $args 0] set is_absolute [string match ::* $a1] if {$is_absolute} { set nspath [nsjoinall {*}$args] } else { if {[string match :* $a1]} { puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" } set nspath [nsjoinall $ns_current {*}$args] } set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] if {$ns_exists} { error "Namespace $nspath already exists" } #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] n/ $nspath } #nn/ ::/ nsup/ - back up one namespace level proc nsup/ {v args} { variable ns_current if {$ns_current eq "::"} { puts stderr "Already at global namespace '::'" } else { set out "" set nsq [nsprefix $ns_current] if {$v eq "/"} { set out [get_nslist -match [nsjoin $nsq *] -types [list children]] } else { set out [get_nslist -match [nsjoin $nsq *] -types [list all]] } #set out [nslist [nsjoin $nsq *]] set ns_current $nsq append out "\n$ns_current" return $out } } #todo - walk up each ns - testing for possibly weirdly named namespaces #needed to use n/ to change to an oddly named namespace such as ":x" proc nsexists {nspath} { if {$nspath eq ""} {return 0} set parts [nsparts $nspath] if {[lindex $parts 0] ne ""} { #relative set ns_caller [uplevel 1 {::namespace current}] set fq_nspath [nsjoin $ns_caller $nspath] } else { set fq_nspath $nspath } if {[catch {nseval_ifexists $fq_nspath {}}]} { return 0 } else { return 1 } } #recursive nseval - for introspection of weird namespace trees #approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection #WARNING: creates namespaces if they don't exist proc nseval_getscript {location} { set parts [nsparts $location] if {[lindex $parts 0] eq ""} { lset parts 0 :: } if {[lindex $parts end] eq ""} { set parts [lrange $parts 0 end-1] } set body "" set i 0 set tails [lrepeat [llength $parts] ""] foreach ns $parts { set cmdlist [list ::tcl::namespace::eval $ns] set t "" if {$i > 0} { append body " " } append body $cmdlist if {$i == ([llength $parts] -1)} { append body "