2 changed files with 303 additions and 0 deletions
@ -0,0 +1,302 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-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} |
||||||
|
|
||||||
|
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. |
||||||
|
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 <ns> \[<ns> ...\]" |
||||||
|
} |
||||||
|
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 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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 {} n/new {} punk::nav::ns::n/new |
||||||
|
interp alias {} nn/ {} punk::nav::ns::nsup/ / |
||||||
|
interp alias {} nn// {} punk::nav::ns::nsup/ // |
||||||
|
if 0 { |
||||||
|
#we can't have ::/ without just plain / which is confusing. |
||||||
|
interp alias {} :/ {} punk::nav::ns::ns/ / |
||||||
|
interp alias {} :// {} punk::nav::ns::ns/ // |
||||||
|
interp alias {} :/new {} punk::nav::ns::n/new |
||||||
|
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 {<unspecified>} |
||||||
|
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 |
||||||
|
|
||||||
Loading…
Reference in new issue