# -*- 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: 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::nav::ns 0.1.0 # Meta platform tcl # Meta license MIT # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ package require Tcl 8.6- tcl::namespace::eval punk::nav::ns { variable PUNKARGS variable ns_current #allow presetting if {![info exists ::punk::nav::ns::ns_current]} { set ns_current :: } namespace path {::punk::ns} namespace eval argdoc { lappend PUNKARGS [list { @id -id ::punk::nav::ns::ns/ @cmd -name punk::nav::ns::ns/\ -summary\ "Navigate and list namespaces and commands"\ -help\ {Navigate/List namespaces or namespaces and commands in the current namespace or in the targets specified with the nsglob pattern(s). This function is provided via aliases as n/ n// and n/// with v being inferred from the alias The n/ n// and n/// forms are more convenient for interactive use. examples: n/ - list namespaces below current namespace n// - list namespaces and commands below current namespace n/ p* - list namespaces below current matching p* n// p* - list namespaces below current and commands in current matching p* } @values -min 1 -max -1 -type string v -type string\ -choices {/ // ///}\ -choicelabels { /\ "list namespaces only" //\ "list namespaces and commands" ///\ "list namespaces, commands and commands resolvable via 'namespace path'" }\ -help\ "The form of navigation/listing to perform." nsglob -type string -optional true -multiple true -help\ "A glob pattern supporting placeholders * and ?, to filter results. If multiple patterns are supplied, then a listing for each pattern is returned. If no patterns are supplied, then all items are listed." }] } proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current set ns_caller [uplevel 1 {::tcl::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 -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? 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 -types $types -nspathcommands $nspathcommands $ns_or_glob] } } 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 -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] } } } 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. #don't rely on a+ alias here. set ns_display "\n[punk::ansi::a+ yellow bold]$ns_current (ensemble)[punk::ansi::a+]" } } } } append out $ns_display return $out } #create possibly nested namespace structure(s) - todo: allow specifying namespaces or which already or partially already exist. #todo - sync with newdir behaviour. namespace eval argdoc { lappend PUNKARGS [list { @id -id ::punk::nav::ns::newns @cmd -name punk::nav::ns::newns\ -summary\ "Create namespace or namespaces at the specified path(s)."\ -help\ "This command creates namespaces at the specified path(s). If any part of the specified path does not exist, then it will be created as well. If a specified path already exists, then it will be left as-is and no error will be raised. A summary line is returned for each created namespace, with the full path of the created namespace and a status line indicating the number of child namespaces, commands and vars in the namespace if it already existed (or showing 0 for all if it was just created). (summary incomplete - todo)" -force -type none\ -help\ "Allows creation of namespaces which may be unwise/problematic, such as empty string or namespaces with leading colons. Use with caution and only when you know what you are doing. If -force is not supplied, then an error will be raised if any supplied path is problematic and no namespaces will be created." @values -min 1 -max -1 -type string path -type string -multiple 1 -optional 0 -help\ "Path(s) (possibly with namespace separator ::) to create. Can be absolute or relative to current namespace. If any path is rejected, then no namespaces will be created. If a namespace or part of a namespace already exists, then it will be left as-is and no error will be raised. If despite passing the name tests, a namespace cannot be created for some reason then an error will be raised and processing of any remaining paths will be aborted." }] } proc newns {args} { set argd [punk::args::parse $args withid ::punk::nav::ns::newns] lassign [dict values $argd] _leaders opts values _received if {[dict exists $opts -force]} { set opt_force [dict get $opts -force] } else { set opt_force 0 } set paths [dict get $values path] variable ns_current #todo: like newdir we want to try to perform an all-or-nothing operation - so first validate all namespaces to be created before creating any of them. set ns [lindex $paths 0] ;#temporary - full implementation will loop through $paths. set is_absolute [string match ::* $ns] if {$is_absolute} { set nspath $ns } else { if {[string match :* $ns]} { #todo - disallow by default and require flag to force. #we also should disallow by default ::: (or any odd multiple? perhaps even :::: for empty ns should require -force) in between segments. puts stderr "newns WARNING namespace with leading colon '$ns' is likely to have unexpected results" } set nspath [nsjoin $ns_current $ns] } 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] {}] #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. set query_paths [lmap v $paths {string cat $v "::*"}] ns/ / {*}$query_paths } proc newns_old {args} { variable ns_current if {![llength $args]} { error "usage: newns \[ ...\]" } 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 "newns 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 } } } #extra slash implies more verbosity (ie display commands instead of just nschildren) interp alias {} n/ {} punk::nav::ns::ns/ / interp alias {} n// {} punk::nav::ns::ns/ // interp alias {} n/// {} punk::nav::ns::ns/ /// interp alias {} newns {} punk::nav::ns::newns interp alias {} nn/ {} punk::nav::ns::nsup/ / interp alias {} nn// {} punk::nav::ns::nsup/ // if 0 { interp alias {} :/ {} punk::nav::ns::ns/ / interp alias {} :// {} punk::nav::ns::ns/ // #we can't have ::/ without just plain / which is confusing. interp alias {} ::/ {} punk::nav::ns::nsup/ / interp alias {} ::// {} punk::nav::ns::nsup/ // } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::nav::ns::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #tcl::namespace::eval punk::nav::ns::system { #} # == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation # == === === === === === === === === === === === === === === tcl::namespace::eval punk::nav::ns { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS variable PUNKARGS_aliases lappend PUNKARGS [list { @id -id "(package)punk::nav::ns" @package -name "punk::nav::ns" -help\ "Package Description" }] namespace eval argdoc { #namespace for custom argument documentation proc package_name {} { return punk::nav::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 punk::nav::ns description to come.. } \n] } proc get_topic_License {} { return "MIT" } proc get_topic_Version {} { return "$::punk::nav::ns::version" } proc get_topic_Contributors {} { set 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 "::punk::nav::ns::about" dict set overrides @cmd -name "punk::nav::ns::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { About punk::nav::ns }] \n] dict set overrides topic -choices [list {*}[punk::nav::ns::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 dict set overrides topic -default [punk::nav::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 ::punk::nav::ns::about] lassign [dict values $argd] _leaders opts values _received punk::args::package::standard_about -package_about_namespace ::punk::nav::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 ::punk::nav::ns } # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::nav::ns [tcl::namespace::eval punk::nav::ns { variable pkg punk::nav::ns variable version set version 0.1.0 }] return