jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
554 Commits
1 Branch
1 Tag
257 MiB
 
 
 
 
 
 
Tree: 8dfae55673
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '8dfae55673'
${ noResults }
punkshell/src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm

417 lines
17 KiB
Raw Blame History

# -*- 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}
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 <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 "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 {<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