jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

ensure punk::nav::ns included in bootsupport

master
Julian Noble 4 weeks ago
parent
b809905a99
commit
6439b5e9d7
2 changed files with 303 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1
      src/bootsupport/modules/include_modules.config
  2. 302
      src/bootsupport/modules/punk/nav/ns-0.1.0.tm

1
src/bootsupport/modules/include_modules.config
Unescape View File

@ -81,6 +81,7 @@ set bootsupport_modules [list\
modules punk::mix::commandset::scriptwrap\
modules punk::mod\
modules punk::nav::fs\
modules punk::nav::ns\
modules punk::ns\
modules punk::overlay\
modules punk::path\

302
src/bootsupport/modules/punk/nav/ns-0.1.0.tm
Unescape View File

@ -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
Write Preview
Loading…
Cancel
Save