Browse Source

tclcore doc updates, punk::args fixes, cmdtrace

master
Julian Noble 4 months ago
parent
commit
bc9bacd82b
  1. 27
      src/modules/argparsingtest-999999.0a1.0.tm
  2. 2
      src/modules/poshinfo-999999.0a1.0.tm
  3. 396
      src/modules/proctrace-999999.0a1.0.tm
  4. 3
      src/modules/proctrace-buildversion.txt
  5. 533
      src/modules/punk-0.1.tm
  6. 3
      src/modules/punk/aliascore-999999.0a1.0.tm
  7. 368
      src/modules/punk/ansi-999999.0a1.0.tm
  8. 471
      src/modules/punk/args-999999.0a1.0.tm
  9. 490
      src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm
  10. 6
      src/modules/punk/console-999999.0a1.0.tm
  11. 9
      src/modules/punk/fileline-999999.0a1.0.tm
  12. 2
      src/modules/punk/fileline-buildversion.txt
  13. 617
      src/modules/punk/lib-999999.0a1.0.tm
  14. 2
      src/modules/punk/lib-buildversion.txt
  15. 24
      src/modules/punk/libunknown-0.1.tm
  16. 2
      src/modules/punk/mix/util-999999.0a1.0.tm
  17. 94
      src/modules/punk/netbox-999999.0a1.0.tm
  18. 111
      src/modules/punk/netbox/man-999999.0a1.0.tm
  19. 1968
      src/modules/punk/ns-999999.0a1.0.tm
  20. 29
      src/modules/punk/repl-999999.0a1.0.tm
  21. 104
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  22. 16
      src/modules/punk/safe-999999.0a1.0.tm
  23. 37
      src/modules/punk/trie-999999.0a1.0.tm
  24. 17
      src/modules/punkcheck-0.1.0.tm
  25. 68
      src/modules/test/punk/#modpod-lib-999999.0a1.0/files/testscript_parsing.tcl
  26. 22
      src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/index_functions.test
  27. 43
      src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/parse.test
  28. 0
      src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/tests/parse.test#..+lib+parse.test.fauxlink
  29. 15
      src/modules/textblock-999999.0a1.0.tm
  30. 4892
      src/vendormodules/overtype-1.7.2.tm

27
src/modules/argparsingtest-999999.0a1.0.tm

@ -314,34 +314,13 @@ namespace eval argparsingtest {
@values @values
} }
proc test1_punkargs_by_id {args} { proc test1_punkargs_by_id {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs_by_id $args] set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs_by_id]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }
punk::args::define {
@id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@leaders -min 0 -max 0
@opts -anyopts 0
-return -default string -type string
-frametype -default \uFFEF -type string
-show_edge -default \uFFEF -type string
-show_seps -default \uFFEF -type string
-join -type none -multiple 1
-x -default "" -type string
-y -default b -type string
-z -default c -type string
-1 -default 1 -type boolean
-2 -default 2 -type integer
-3 -default 3 -type integer
@values -min 0 -max 0
}
proc test1_punkargs2 {args} {
set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs2]
return [tcl::dict::get $argd opts]
} }
proc test1_punkargs2_parsecache {args} { proc test1_punkargs_parsecache {args} {
set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs2] set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }

2
src/modules/poshinfo-999999.0a1.0.tm

@ -211,7 +211,7 @@ tcl::namespace::eval poshinfo {
globs -multiple 1 -default * -help "" globs -multiple 1 -default * -help ""
} }
proc themes {args} { proc themes {args} {
set argd [punk::args::get_by_id ::poshinfo::themes $args] set argd [punk::args::parse $args withid ::poshinfo::themes]
set return_as [dict get $argd opts -as] set return_as [dict get $argd opts -as]
set formats [dict get $argd opts -format] ;#multiple set formats [dict get $argd opts -format] ;#multiple
if {"yaml" in $formats} { if {"yaml" in $formats} {

396
src/modules/proctrace-999999.0a1.0.tm

@ -0,0 +1,396 @@
# -*- 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 proctrace 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
package require Tcl 8.6-
##################
## Module Name -- proctrace.tcl
## Original Author -- Emmanuel Frecon
## Description:
##
## This module is meant to be a last resort debugging facility. It will
## arrange for being able to trace execution either at the entry of
## procedure, either of all commands within procedures. The defaults are to
## trace all procedures, except the one from a few packages known to slow
## execution down. See beginning of library for an explanation of the
## options.
##
##################
tcl::namespace::eval ::proctrace {
variable PUNKARGS
namespace eval vars {
# File to trace execution to (if no file is specified, tracing will
# occur on the standard error)
variable -file ""
# List of pattern to match against the name of current and future
# procedures. Only the procedures matching the patterns in this list
# will be considered for tracing.
variable -allowed {*}
# List of patterns to match against the name of procedure that should
# not be considered for tracing. This is a subset of the ones allowed.
variable -denied {::tcl::* ::aes::* ::logger::*}
# A boolean, turn it on to trace the execution of each command block
# within the procedures.
variable -detailed off
variable fd stderr; # File descriptor where to trace
variable version 0.2; # Current package version.
variable enabled 1; # Is tracing enabled
}
# Automatically export all procedures starting with lower case and
# create an ensemble for an easier API.
namespace export {[a-z]*}
namespace ensemble create
}
# ::proctrace::init -- Init and start tracing
#
# Arrange to trace the execution of code either at the entry of procedure,
# either of all commands within procedures. This command takes a number of
# dash led options, these are described a the beginning of the library.
#
# Arguments:
# args List of dash-led options and arguments.
#
# Results:
# None.
#
# Side Effects:
# Will start tracing, which means a LOT of output!
proc ::proctrace::init { args } {
# Detect all options available to the procedure, out of the variables that
# are dash-led.
set opts [list]
foreach o [info vars vars::-*] {
set i [string last "::-" $o]
lappend opts [string trimleft [string range $o $i end] :]
}
# "parse" the options, i.e. set the values if they should exist...
foreach {k v} $args {
if { $k in $opts } {
set vars::$k $v
} else {
return -code error "$k unknown options, should be [join $opts ,\ ]"
}
}
# Open the file for output, if relevant.
if { ${vars::-file} ne "" } {
set vars::fd [open ${vars::-file} w]
}
# Arrange to reroute procedure declaration through our command so we can
# automagically install execution traces.
rename ::proc ::proctrace::RealProc
interp alias {} ::proc {} ::proctrace::Proc
# Catch up with the current set of existing procedure to make sure we can
# also capture execution within procedure that would have been created
# before ::proctrace::init was called.
foreach p [AllProcs] {
if { [Tracable $p]} {
Follow $p 2
}
}
}
proc ::proctrace::terminate {} {set ::proctrace::vars::enabled 0}
proc ::proctrace::resume {} {set ::proctrace::vars::enabled 1}
# ::proctrace::AllProcs -- List all declared procedures
#
# Returns a list of all declared procedures, in all namespaces currently
# defined in the interpreter. The implementation recursively list all
# procedures in all sub-namespaces.
#
# Arguments:
# base Namespace at which to start.
#
# Results:
# List of all procedure in current and descendant namespaces.
#
# Side Effects:
# None.
proc ::proctrace::AllProcs { { base "::" } } {
# Get list of procedures in current namespace.
set procs [info procs [string trimright ${base} :]::*]
# Recurse in children namespaces.
foreach ns [namespace children $base] {
set procs [concat $procs [AllProcs $ns]]
}
return $procs
}
# ::proctrace::Follow -- Install traces
#
# Install traces to be able to get notified whenever procedures are
# entered or commands within procedures are executed.
#
# Arguments:
# name Name (fully-qualified) of procedure.
# lvl Call stack level at which to execute trace installation
#
# Results:
# None.
#
# Side Effects:
# Arrange for Trace procedure to be called
proc ::proctrace::Follow { name {lvl 1}} {
if { [string is true ${vars::-detailed}] } {
uplevel $lvl [list trace add execution $name enter [list ::proctrace::Trace $name]]
uplevel $lvl [list trace add execution $name enterstep [list ::proctrace::Trace $name]]
} else {
uplevel $lvl [list trace add execution $name enter [list ::proctrace::Trace $name]]
}
}
# ::proctrace::Proc -- Capturing procedure
#
# This is our re-implementation of the proc command. It calls the original
# command and also arranges to install traces if appropriate.
#
# Arguments:
# name Name of procedure
# arglist List of arguments to procedure
# body Procedure body.
#
# Results:
# None.
#
# Side Effects:
# Creates a new procedure, possibly arrange for tracing its execution.
proc ::proctrace::Proc { name arglist body } {
uplevel 1 [list ::proctrace::RealProc $name $arglist $body]
if { [Tracable $name]} {
Follow $name 2
}
}
variable tinfo
# ::proctrace::Trace -- Perform trace
#
# Trace procedure/command execution.
#
# Arguments:
# target Name of procedure
# command Command being executed
# op Operation (should be enter or enterstep, not used)
#
# Results:
# None.
#
# Side Effects:
# Trace execution on globally allocated file descriptor.
proc ::proctrace::Trace { target command op } {
if {!$::proctrace::vars::enabled} {return}
variable tinfo
if {$op eq "enter"} {
dict set tinfo($target) firstline -1
dict set tinfo($target) procoffset 0
dict set tinfo($target) level [expr {[info level]+1}]
dict set tinfo($target) subcmds 0
puts $vars::fd "ENTER $target >> $command"
return
} else {
if {[tcl::info::level] != [tcl::dict::get $tinfo($target) level]} {
return
}
}
puts $vars::fd "STEP $target >> $command"
flush $vars::fd
}
# ::proctrace::Tracable -- Should procedure be traced
#
# Decide if a procedure should be traced according to the -allowed and
# -denied options that are global to this library.
#
# Arguments:
# name Fully-qualified procedure name
#
# Results:
# 1 if the procedure should be traced, 0 otherwise.
#
# Side Effects:
# None.
proc ::proctrace::Tracable { name } {
# Traverse -allow(ance) list to allow procedure.
set allow 0
foreach ptn ${vars::-allowed} {
if { [string match $ptn $name] } {
set allow 1
break
}
}
# Possibly negate previous allowance through matching the name against the
# patterns in the -denied list.
foreach ptn ${vars::-denied} {
if { [string match $ptn $name] } {
set allow 0
break
}
}
# Return final decision.
return $allow
}
package provide proctrace $::proctrace::vars::version
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval proctrace::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval proctrace::system {
#}
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval proctrace {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
lappend PUNKARGS [list {
@id -id "(package)proctrace"
@package -name "proctrace" -help\
"Package
Description"
}]
namespace eval argdoc {
#namespace for custom argument documentation
proc package_name {} {
return proctrace
}
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 proctrace
description to come..
} \n]
}
proc get_topic_License {} {
return "<unspecified>"
}
proc get_topic_Version {} {
return "$::proctrace::version"
}
proc get_topic_Contributors {} {
set authors {{Emmanuel Frecon}}
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 "::proctrace::about"
dict set overrides @cmd -name "proctrace::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About proctrace
}] \n]
dict set overrides topic -choices [list {*}[proctrace::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [proctrace::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 ::proctrace::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::proctrace::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 ::proctrace
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide proctrace [tcl::namespace::eval proctrace {
variable pkg proctrace
variable version
set version 999999.0a1.0
}]
return

3
src/modules/proctrace-buildversion.txt

@ -0,0 +1,3 @@
0.2
#First line must be a semantic version number
#all other lines are ignored.

533
src/modules/punk-0.1.tm

@ -398,8 +398,8 @@ if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring namespace import punk::ansi::ansistring
} }
#require aliascore after punk::lib & punk::ansi are loaded #require aliascore after punk::lib & punk::ansi are loaded
package require punk::aliascore ;#mostly punk::lib aliases #package require punk::aliascore ;#mostly punk::lib aliases
punk::aliascore::init -force 1 #punk::aliascore::init -force 1
package require punk::repl::codethread package require punk::repl::codethread
package require punk::config package require punk::config
@ -533,25 +533,6 @@ namespace eval punk {
proc ::punk::K {x y} { return $x} proc ::punk::K {x y} { return $x}
#todo ansigrep? e.g grep using ansistripped value
proc grepstr1 {pattern data} {
set data [string map {\r\n \n} $data]
set lines [split $data \n]
set matches [lsearch -all -regexp $lines $pattern]
set max [lindex $matches end]
set w1 [string length $max]
set result ""
set H [a+ green bold overline]
set R \x1b\[m
foreach m $matches {
set ln [lindex $lines $m]
set ln [regsub -all $pattern $ln $H&$R]
append result [format %${w1}s $m] " $ln" \n
}
set result [string trimright $result \n]
return $result
}
#---------------------- #----------------------
#todo - fix overtype #todo - fix overtype
#create test #create test
@ -559,330 +540,6 @@ namespace eval punk {
#---------------------- #----------------------
punk::args::define {
@id -id ::punk::grepstr
@cmd -name punk::grepstr\
-summary\
"Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\
-help\
"The grepstr command can find strings in ANSI text even if there are interspersed
ANSI colour codes etc. Even if a word has different coloured/styled letters, the
regex can match the plaintext. (Search is performed on ansistripped text, and then
the matched sections are highlighted and overlayed on the original styled/colourd
input.
If the input string has ANSI movement codes - the resultant text may not be directly
searchable because the parts of a word may be separated by various codes and other
plain text. To search such an input string, the string should first be 'rendered' to
a form where the ANSI only represents SGR styling (and perhaps other non-movement
codes) using something like overtype::renderline or overtype::rendertext."
@leaders -min 0 -max 0
@opts
-returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
"matched"\
" Return only lines that matched."
"breaksandmatches"\
" Return configured --break= lines in between non-consecutive matches"
"all"\
" Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines."
}
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
"Print num lines of leading and trailing context surrounding each match."
-A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num
--break= -type string -default "-- %c%\U2260" -help\
"When returning matched lines and there is a break in consecutive output,
display the break with the given string. %c% is a placeholder for the
number of lines skipped.
Use empty-string for an empty line as a break display.
grepstr --break= needle $haystacklines
The unix grep utility commonly uses -- for this indicator.
grepstr --break=-- needle $haystacklines
Customisation example:
grepstr -n \"--break=(skipped %c% lines)\" needle $haystacklines
"
-ansistrip -type none -help\
"Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\
"Each output line is preceded by its relative line number in the file, starting at line 1.
For lines that matched the regex, the line number will be suffixed with a * indicator
with the same highlighting as the matched string(s).
The number of matches in the line immediately follows the *
For lines with no matches the * indicator is present with no highlighting and suffixed
with zeros."
-i|--ignore-case -type none -help\
"Perform case insensitive matching."
-highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\
"list of ANSI SGR style codes as supported by and documented in punk::ansi::a?"
-- -type none
@values
pattern -type string -help\
{regex pattern to match in plaintext portion of ANSI string
The pattern may contain bracketed capturing groups, which
will be highlighted in the result. If there is no capturing
group, the entire match will be highlighted.
Note that if we were to attempt to highlight curly braces based
on the regexp {\{|\}} then the inserted ansi would come between
the backslash and brace in cases where a curly brace is escaped
ie \{ or \}
Depending on how the output is used, this can break the syntactic
structure causing problems.
Instead a pair of regexes such as
{^\{|[^\\](\{+)}
{[^\\](\}+)}
should be used to
exclude braces that are escaped.
(note the capturing groups around each curly brace)
}
string -type string
}
proc grepstr {args} {
lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received
set pattern [dict get $values pattern]
set data [dict get $values string]
set do_strip 0
if {[dict exists $received -ansistrip]} {
set data [punk::ansi::ansistrip $data]
}
set highlight [dict get $opts -highlight]
set opt_returnlines [dict get $opts -returnlines]
set context [dict get $opts --context] ;#int
set beforecontext [dict get $opts --before-context]
set beforecontext [expr {max($beforecontext,$context)}]
set aftercontext [dict get $opts --after-context]
set aftercontext [expr {max($aftercontext,$context)}]
set break [dict get $opts --break]
set ignorecase [dict exists $received --ignore-case]
if {$ignorecase} {
set nocase "-nocase"
} else {
set nocase ""
}
if {[dict exists $received --line-number]} {
set do_linenums 1 ;#display lineindex+1
} else {
set do_linenums 0
}
if {[llength $highlight] == 0} {
set H ""
set R ""
} else {
set H [a+ {*}$highlight]
set R \x1b\[m
}
set data [string map {\r\n \n} $data]
if {[punk::ansi::ta::detect $data]} {
set raw_has_ansi 1
set plain [punk::ansi::ansistrip $data]
} else {
set raw_has_ansi 0
set plain $data
}
set plainlines [split $plain \n]
set lines [split $data \n]
set matched_line_indices [lsearch -all {*}$nocase -regexp $plainlines $pattern]
if {$opt_returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1]
} else {
set returnlines $matched_line_indices
}
set max [lindex $returnlines end]
if {[string is integer -strict $max]} {
#if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary.
incr max
}
set w1 [string length $max]
set result ""
set placeholder \UFFEF ;#review
set resultlines [dict create]
foreach lineindex $returnlines {
set ln [lindex $lines $lineindex]
set col1 ""
if {$do_linenums} {
set col1 [format "%${w1}s " [expr {$lineindex+1}]]
}
if {$lineindex in $matched_line_indices} {
set plain_ln [lindex $plainlines $lineindex]
#first - determine the number of capturing groups (subexpressions)
#option 1: test the regexp with a single match
#set testparts [regexp {*}$nocase -inline -- $pattern $plain_ln] ;#get fullmatch capturegroup...
#set numgroups [expr {[llength $testparts] -1}]
#option 2: use the regexp -about flag
set numgroups [lindex [regexp -about $pattern] 0]
set allparts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln]
#allparts includes each full match as well as each capturing group
#early versions of tcl 8.6 still didn't support 'lsearch -stride' - avoid for now.
set matchcount [expr {[llength $allparts] / ($numgroups + 1)}]
#set matchcount [llength $allparts]
if {$matchcount == 0} {
#This probably can't happen (?)
#If it does.. it's more likely to be an issue with our line index than with regexp
puts stderr "Unexpected regex mismatch in grepstr (shouldn't happen) regex: $pattern lineindex: $lineindex"
set matchshow "??? $ln"
dict set resultlines $lineindex $matchshow
continue
}
# ------------------------------------
if {$numgroups > 0} {
# restrict ourself to just the capture groups, excluding the full match (if there are capture groups)
set highlight_ranges [list]
set i 0
#{-1 -1} returned for non-matching group when there are capture-group alternatives
#e.g {(a)|(b)}
foreach range $allparts {
if {($i % ($numgroups+1)) != 0} {
lassign $range a b
if {$range ne {-1 -1} & $a <= $b} {
lappend highlight_ranges $range
}
}
incr i
}
} else {
#No capture group in the regex, each index range is just a full match
set highlight_ranges $allparts
}
# ------------------------------------
#puts stderr "numgroups : $numgroups"
#puts stderr "grepstr pattern : $pattern"
#puts stderr "grepstr allparts: $allparts"
#puts stderr "highlight_ranges: $highlight_ranges"
if {$do_linenums} {
append col1 $H*$R[format %03s $matchcount]
}
if {$raw_has_ansi} {
set overlay ""
set i 0
foreach hrange $highlight_ranges {
lassign $hrange s e
set prelen [expr {$s - $i}]
#append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R
append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]
set i [expr {$e + 1}]
}
set tail [string range $plain_ln $e+1 end]
append overlay [string repeat $placeholder [string length $tail]]
#puts "$overlay"
#puts "$ln"
#set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay]
set rendered [overtype::renderspace -transparent $placeholder -insert_mode 0 $ln $overlay]
} else {
set rendered ""
set i 0
foreach hrange $highlight_ranges {
lassign $hrange s e
set prelen [expr {$s - $i}]
#append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]
append rendered [string range $plain_ln $i $s-1] $H [string range $plain_ln $s $e] $R
set i [expr {$e + 1}]
}
append rendered [string range $plain_ln $e+1 end]
}
if {$do_linenums} {
set matchshow "$col1 $rendered"
} else {
set matchshow $rendered
}
#---------------------------------------------------------------
set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1]
set s [expr {$lineindex-$beforecontext-1}]
if {$s < -1} {set s -1}
foreach p $prelines {
incr s
#append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format "%${w1}s " [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
}
#---------------------------------------------------------------
dict set resultlines $lineindex $matchshow
#---------------------------------------------------------------
set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext]
set s $lineindex
foreach p $postlines {
incr s
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format "%${w1}s " [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
}
#---------------------------------------------------------------
} else {
if {$do_linenums} {
append col1 "*000"
set show "$col1 $ln"
} else {
set show $ln
}
dict set resultlines $lineindex $show
}
}
set ordered_resultlines [lsort -integer [dict keys $resultlines]]
set result ""
set i -1
set do_break 0
if {$opt_returnlines eq "breaksandmatches"} {
set do_break 1
}
if {$do_break} {
foreach r $ordered_resultlines {
incr i
if {$r > $i} {
set c [expr {$r - $i}]
append result [string map [list %c% $c] $break] \n
}
append result [dict get $resultlines $r] \n
set i $r
}
if {$i<[llength $lines]-1} {
set c [expr {[llength $lines]-1-$i}]
append result [string map [list %c% $c] $break] \n
}
} else {
foreach r $ordered_resultlines {
append result [dict get $resultlines $r] \n
}
}
set result [string trimright $result \n]
return $result
}
proc stacktrace {} { proc stacktrace {} {
set stack "Stack trace:\n" set stack "Stack trace:\n"
for {set i 1} {$i < [info level]} {incr i} { for {set i 1} {$i < [info level]} {incr i} {
@ -909,38 +566,6 @@ namespace eval punk {
return $stack return $stack
} }
#review - there are various type of uuid - we should use something consistent across platforms
#twapi is used on windows because it's about 5 times faster - but is this more important than consistency?
#twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway
#(counterpoint: in the case of punk - we currently need twapi anyway on windows)
#does tcllib's uuid use the same mechanisms on different platforms anyway?
proc ::punk::uuid {} {
set has_twapi 0
if 0 {
if {"windows" eq $::tcl_platform(platform)} {
if {![catch {
set loader [zzzload::pkg_wait twapi]
} errM]} {
if {$loader in [list failed loading]} {
catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"}
}
} else {
package require twapi
}
if {[package provide twapi] ne ""} {
set has_twapi 1
}
}
}
if {!$has_twapi} {
if {[catch {package require uuid} errM]} {
error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows"
}
return [uuid::uuid generate]
} else {
return [twapi::new_uuid]
}
}
namespace eval argdoc { namespace eval argdoc {
punk::args::define { punk::args::define {
@id -id ::punk::get_runchunk @id -id ::punk::get_runchunk
@ -4183,7 +3808,7 @@ namespace eval punk {
#pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created
proc pipealias {targetcmd args} { proc pipealias {targetcmd args} {
set cmdcopy [punk::valcopy $args] set cmdcopy [punk::valcopy $args]
set nscaller [uplevel 1 [list namespace current]] set nscaller [uplevel 1 [list ::tcl::namespace::current]]
tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller]
} }
proc pipealias_extract {targetcmd} { proc pipealias_extract {targetcmd} {
@ -4194,7 +3819,7 @@ namespace eval punk {
#although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower
proc pipealias2 {targetcmd args} { proc pipealias2 {targetcmd args} {
set cmdcopy [punk::valcopy $args] set cmdcopy [punk::valcopy $args]
set nscaller [uplevel 1 [list namespace current]] set nscaller [uplevel 1 [list ::tcl::namespace::current]]
tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller]
} }
@ -4224,9 +3849,9 @@ namespace eval punk {
if {$pipecmd in [info commands $pipecmd]} { if {$pipecmd in [info commands $pipecmd]} {
#puts "==nscaller: '[uplevel 1 [list namespace current]]'" #puts "==nscaller: '[uplevel 1 [list namespace current]]'"
#uplevel 1 [list ::namespace import $pipecmd] #uplevel 1 [list ::namespace import $pipecmd]
set existing_path [uplevel 1 [list ::namespace path]] set existing_path [uplevel 1 [list ::tcl::namespace::path]]
if {$cmdns ni $existing_path} { if {$cmdns ni $existing_path} {
uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]]
} }
tailcall $pipecmd {*}$args tailcall $pipecmd {*}$args
} }
@ -4394,9 +4019,9 @@ namespace eval punk {
debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2
uplevel 1 [list ::proc $pipecmd args $script] uplevel 1 [list ::proc $pipecmd args $script]
set existing_path [uplevel 1 [list ::namespace path]] set existing_path [uplevel 1 [list ::tcl::namespace::path]]
if {$cmdns ni $existing_path} { if {$cmdns ni $existing_path} {
uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]]
} }
tailcall $pipecmd {*}$args tailcall $pipecmd {*}$args
} }
@ -5090,7 +4715,7 @@ namespace eval punk {
} }
debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4
set ns [uplevel 1 {::namespace current}] set ns [uplevel 1 {::tcl::namespace::current}]
if {!$add_argsdata} { if {!$add_argsdata} {
debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4
#puts stderr " script: $script" #puts stderr " script: $script"
@ -5399,7 +5024,7 @@ namespace eval punk {
} }
set UnknownPending($name) pending set UnknownPending($name) pending
set ret [catch { set ret [catch {
auto_load $name [uplevel 1 {::namespace current}] auto_load $name [uplevel 1 {::tcl::namespace::current}]
} msg opts] } msg opts]
unset UnknownPending($name) unset UnknownPending($name)
if {$ret != 0} { if {$ret != 0} {
@ -5492,6 +5117,7 @@ namespace eval punk {
} }
if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) if {$isrepl || (([info level] == 1) && (([info script] eq "" ) )
&& ([info exists tcl_interactive] && $tcl_interactive))} { && ([info exists tcl_interactive] && $tcl_interactive))} {
if {![info exists auto_noexec]} { if {![info exists auto_noexec]} {
set new [auto_execok $name] set new [auto_execok $name]
if {$new ne ""} { if {$new ne ""} {
@ -5803,10 +5429,10 @@ namespace eval punk {
if {[string length $ns] && ![namespace exists $ns]} { if {[string length $ns] && ![namespace exists $ns]} {
error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)"
} else { } else {
set nscaller [uplevel 1 [list ::namespace current]] set nscaller [uplevel 1 [list ::tcl::namespace::current]]
#jmn #jmn
set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs]
set commands [uplevel 1 [list ::info commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk set commands [uplevel 1 [list ::tcl::info::commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk
#we must check for exact match of the command in the list - because command could have glob chars. #we must check for exact match of the command in the list - because command could have glob chars.
if {"$pattern=$rhsmapped" in $commands} { if {"$pattern=$rhsmapped" in $commands} {
puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'"
@ -6015,7 +5641,7 @@ namespace eval punk {
} }
proc ispipematch {args} { proc ispipematch {args} {
expr {[lindex [uplevel 1 [list pipematch {*}$args]] 0] eq "ok"} expr {[lindex [uplevel 1 [list ::punk::pipematch {*}$args]] 0] eq "ok"}
} }
#pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}}
@ -6255,7 +5881,7 @@ namespace eval punk {
} }
} }
lappend binding [list switchargs $args] lappend binding [list switchargs $args]
apply [list $binding $pipescript [uplevel 1 {::namespace current}]] apply [list $binding $pipescript [uplevel 1 {::tcl::namespace::current}]]
} }
proc pipedata {data args} { proc pipedata {data args} {
@ -7085,7 +6711,7 @@ namespace eval punk {
#apply [list $binding $pipescript [uplevel 1 ::namespace current]] #apply [list $binding $pipescript [uplevel 1 ::namespace current]]
foreach item $listval { foreach item $listval {
set bindlist [list {*}$binding [list item $item]] set bindlist [list {*}$binding [list item $item]]
if {[apply [list $bindlist $itemcond [uplevel 1 ::namespace current]] ]} { if {[apply [list $bindlist $itemcond [uplevel 1 ::tcl::namespace::current]] ]} {
lappend filtered_list $item lappend filtered_list $item
} }
} }
@ -7553,7 +7179,7 @@ namespace eval punk {
proc ooinspect {obj} { proc ooinspect {obj} {
set obj [uplevel 1 [list namespace which -command $obj]] set obj [uplevel 1 [list ::tcl::namespace::which -command $obj]]
set isa [lmap type {object class metaclass} { set isa [lmap type {object class metaclass} {
if {![info object isa $type $obj]} continue if {![info object isa $type $obj]} continue
set type set type
@ -7696,7 +7322,7 @@ namespace eval punk {
foreach {k v} $flags { foreach {k v} $flags {
if {$k ni [dict keys $defaults]} { if {$k ni [dict keys $defaults]} {
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
punk::args::get_by_id ::punk::inspect $args punk::args::parse $args -errorstyle minimal withid ::punk::inspect
} }
} }
set opts [dict merge $defaults $flags] set opts [dict merge $defaults $flags]
@ -7824,6 +7450,16 @@ namespace eval punk {
proc help {args} {
set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]]
foreach chunk $chunks {
lassign $chunk chan text
puts -nonewline $chan $text
}
puts -nonewline stdout \n
}
#return list of {chan chunk} elements
namespace eval argdoc { namespace eval argdoc {
punk::args::define { punk::args::define {
@id -id ::punk::help_chunks @id -id ::punk::help_chunks
@ -7838,14 +7474,6 @@ namespace eval punk {
arg -type any -optional 1 -multiple 1 arg -type any -optional 1 -multiple 1
} }
} }
proc help {args} {
set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]]
foreach chunk $chunks {
lassign $chunk chan text
puts -nonewline $chan $text
}
}
#return list of {chan chunk} elements
proc help_chunks {args} { proc help_chunks {args} {
set argd [punk::args::parse $args withid ::punk::help_chunks] set argd [punk::args::parse $args withid ::punk::help_chunks]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
@ -7877,7 +7505,7 @@ namespace eval punk {
} }
set title "[a+ brightgreen] Help System: " set title "[a+ brightgreen] Help System: "
set cmdinfo [list] set cmdinfo [list]
lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\n\n\n\n"] lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"]
set t [textblock::class::table new -minwidth 51 -show_seps 0] set t [textblock::class::table new -minwidth 51 -show_seps 0]
foreach row $cmdinfo { foreach row $cmdinfo {
$t add_row $row $t add_row $row
@ -7993,35 +7621,40 @@ namespace eval punk {
catch { catch {
append text \n "Tcl build-info: [::tcl::build-info]" append text \n "Tcl build-info: [::tcl::build-info]"
} }
if {[punk::lib::check::has_tclbug_script_var]} { #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check
append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*]
} foreach bp $bugcheck_procs {
if {[punk::lib::check::has_tclbug_safeinterp_compile]} { set buginfo [$bp]
if {[dict get $buginfo bug]} {
set level unknown
if {[dict exists $buginfo level]} {
set level [dict get $buginfo level]
}
switch -- $level {
minor {set highlight [punk::ansi::a+ cyan]}
medium {set highlight [punk::ansi::a+ yellow]}
major {set highlight [punk::ansi::a+ red bold]}
default {set highlight ""}
}
append warningblock \n $highlight "warning level: $level $bp triggered."
if {[dict exists $buginfo description]} {
set indent " " set indent " "
append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]"
append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n }
append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} {
set bugref [dict get $buginfo bugref]
append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]"
}
append warningblock [a] append warningblock [a]
} }
}
if {[catch {lsearch -stride 2 {a b} b}]} { if {[catch {lsearch -stride 2 {a b} b}]} {
#has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it.
set indent " " set indent " "
append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n
append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n
append warningblock [a] append warningblock [a]
} else {
if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} {
set indent " "
append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n
append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n
append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]"
append warningblock [a]
}
}
if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} {
set indent " "
append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n
append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n
append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]"
} }
lappend chunks [list stdout $text] lappend chunks [list stdout $text]
} }
@ -8231,7 +7864,7 @@ namespace eval punk {
} }
default { default {
set text "" set text ""
set cinfo [uplevel 1 [list punk::ns::cmdwhich [lindex $topicparts 0]]] set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]]
set wtype [dict get $cinfo whichtype] set wtype [dict get $cinfo whichtype]
if {$wtype eq "notfound"} { if {$wtype eq "notfound"} {
set externalinfo [auto_execok [lindex $topicparts 0]] set externalinfo [auto_execok [lindex $topicparts 0]]
@ -8246,7 +7879,7 @@ namespace eval punk {
} else { } else {
set text "[dict get $cinfo which] [lrange $topicparts 1 end]" set text "[dict get $cinfo which] [lrange $topicparts 1 end]"
append text \n "Base type: $wtype" append text \n "Base type: $wtype"
set synopsis [uplevel 1 [list punk::ns::synopsis {*}$topicparts]] set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]]
set synshow "" set synshow ""
foreach sline [split $synopsis \n] { foreach sline [split $synopsis \n] {
if {[regexp {\s*#.*} $sline]} { if {[regexp {\s*#.*} $sline]} {
@ -8276,12 +7909,16 @@ namespace eval punk {
#this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it.
interp alias {} mode {} punk::mode interp alias {} mode {} punk::mode
proc aliases {{glob *}} {
tailcall punk::ns::aliases $glob
} #proc aliases {{glob *}} {
proc alias {{aliasorglob ""} args} { # tailcall punk::ns::aliases $glob
tailcall punk::ns::alias $aliasorglob {*}$args #}
}
##review
#proc alias {{aliasorglob ""} args} {
# tailcall punk::ns::alias $aliasorglob {*}$args
#}
#pipeline-toys - put in lib/scriptlib? #pipeline-toys - put in lib/scriptlib?
@ -8492,24 +8129,24 @@ namespace eval punk {
} }
proc repl {startstop} { #proc repl {startstop} {
switch -- $startstop { # switch -- $startstop {
stop { # stop {
if {[punk::repl::codethread::is_running]} { # if {[punk::repl::codethread::is_running]} {
puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" # puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter"
set ::repl::done 1 # set ::repl::done 1
} # }
} # }
start { # start {
if {[punk::repl::codethread::is_running]} { # if {[punk::repl::codethread::is_running]} {
repl::start stdin # repl::start stdin
} # }
} # }
default { # default {
error "repl unknown action '$startstop' - must be start or stop" # error "repl unknown action '$startstop' - must be start or stop"
} # }
} # }
} #}
} }

3
src/modules/punk/aliascore-999999.0a1.0.tm

@ -116,12 +116,12 @@ tcl::namespace::eval punk::aliascore {
pdict ::punk::lib::pdict\ pdict ::punk::lib::pdict\
plist {::punk::lib::pdict -roottype list}\ plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\
grepstr ::punk::grepstr\
rehash ::punk::rehash\ rehash ::punk::rehash\
showdict ::punk::lib::showdict\ showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\ ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\
ansiwrap ::punk::ansi::ansiwrap\ ansiwrap ::punk::ansi::ansiwrap\
grepstr ::punk::ansi::grepstr\
colour ::punk::console::colour\ colour ::punk::console::colour\
color ::punk::console::colour\ color ::punk::console::colour\
ansi ::punk::console::ansi\ ansi ::punk::console::ansi\
@ -138,6 +138,7 @@ tcl::namespace::eval punk::aliascore {
eg ::punk::ns::eg\ eg ::punk::ns::eg\
aliases ::punk::ns::aliases\ aliases ::punk::ns::aliases\
alias ::punk::ns::alias\ alias ::punk::ns::alias\
use ::punk::ns::pkguse\
] ]
#*** !doctools #*** !doctools

368
src/modules/punk/ansi-999999.0a1.0.tm

@ -148,16 +148,14 @@ tcl::namespace::eval punk::ansi::class {
method render_to_input_line {args} { method render_to_input_line {args} {
if {[llength $args] < 1} { if {[llength $args] < 1} {
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args punk::args::parse $args -cache 1 withid "::punk::ansi::class::class_ansi render_to_input_line"
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return return
} }
set x [lindex $args end] set x [lindex $args end]
set arglist [lrange $args 0 end-1] set arglist [lrange $args 0 end-1]
if {[llength $arglist] %2 != 0} { if {[llength $arglist] %2 != 0} {
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args punk::args::parse $args -cache 1 withid "::punk::ansi::class::class_ansi render_to_input_line"
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return return
} }
set opts [tcl::dict::create\ set opts [tcl::dict::create\
@ -171,7 +169,7 @@ tcl::namespace::eval punk::ansi::class {
} }
default { default {
puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" punk::args::parse $args -cache 1 withid "::punk::ansi::class::class_ansi render_to_input_line"
return return
} }
} }
@ -197,7 +195,8 @@ tcl::namespace::eval punk::ansi::class {
if {$opt_minus ne "0"} { if {$opt_minus ne "0"} {
set chunk [tcl::string::range $chunk 0 end-$opt_minus] set chunk [tcl::string::range $chunk 0 end-$opt_minus]
} }
set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] #set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk]
set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk]
set marker "" set marker ""
for {set i 1} {$i <= $w} {incr i} { for {set i 1} {$i <= $w} {incr i} {
if {$i % 10 == 0} { if {$i % 10 == 0} {
@ -212,13 +211,15 @@ tcl::namespace::eval punk::ansi::class {
set xline [lindex $rlines $x]\n set xline [lindex $rlines $x]\n
set xlinev [ansistring VIEWSTYLE $xline] set xlinev [ansistring VIEWSTYLE $xline]
set xlinev [tcl::string::map $maplf $xlinev] set xlinev [tcl::string::map $maplf $xlinev]
set xlinedisplay [overtype::renderspace -wrap 1 -width $w -height 1 "" $xlinev] #set xlinedisplay [overtype::renderspace -wrap 1 -width $w -height 1 "" $xlinev]
set xlinedisplay [overtype::renderspace -cp437 1 -wrap 1 -width $w -height 1 "" $xlinev]
::append rendered \n $xlinedisplay ::append rendered \n $xlinedisplay
set chunk [ansistring VIEWSTYLE $chunk] set chunk [ansistring VIEWSTYLE $chunk]
set chunk [tcl::string::map $maplf $chunk] set chunk [tcl::string::map $maplf $chunk]
#keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths #keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths
set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk] #set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk]
set chunkdisplay [overtype::renderspace -cp437 1 -wrap 1 -width 80 -height 1 "" $chunk]
set renderheight [llength [split $rendered \n]] set renderheight [llength [split $rendered \n]]
set chunkdisplay_lines [split $chunkdisplay \n] set chunkdisplay_lines [split $chunkdisplay \n]
set chunkdisplay_tail [lrange $chunkdisplay_lines end-$renderheight end] set chunkdisplay_tail [lrange $chunkdisplay_lines end-$renderheight end]
@ -925,6 +926,347 @@ tcl::namespace::eval punk::ansi {
return $result return $result
} }
lappend PUNKARGS [list {
@id -id ::punk::ansi::grepstr
@cmd -name punk::ansi::grepstr\
-summary\
"Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\
-help\
"The grepstr command can find strings in ANSI text even if there are interspersed
ANSI colour codes etc. Even if a word has different coloured/styled letters, the
regex can match the plaintext. (Search is performed on ansistripped text, and then
the matched sections are highlighted and overlayed on the original styled/colourd
input.
If the input string has ANSI movement codes - the resultant text may not be directly
searchable because the parts of a word may be separated by various codes and other
plain text. To search such an input string, the string should first be 'rendered' to
a form where the ANSI only represents SGR styling (and perhaps other non-movement
codes) using something like overtype::renderline or overtype::rendertext."
@leaders -min 0 -max 0
@opts
-returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
"matched"\
" Return only lines that matched."
"breaksandmatches"\
" Return configured --break= lines in between non-consecutive matches"
"all"\
" Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines."
}
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
"Print num lines of leading and trailing context surrounding each match."
-A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num
--break= -type string -default "-- %c%\U2260" -help\
"When returning matched lines and there is a break in consecutive output,
display the break with the given string. %c% is a placeholder for the
number of lines skipped.
Use empty-string for an empty line as a break display.
grepstr --break= needle $haystacklines
The unix grep utility commonly uses -- for this indicator.
grepstr --break=-- needle $haystacklines
Customisation example:
grepstr -n \"--break=(skipped %c% lines)\" needle $haystacklines
"
-ansistrip -type none -help\
"Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\
"Each output line is preceded by its relative line number in the file, starting at line 1.
For lines that matched the regex, the line number will be suffixed with a * indicator
with the same highlighting as the matched string(s).
The number of matches in the line immediately follows the *
For lines with no matches the * indicator is present with no highlighting and suffixed
with zeros."
-i|--ignore-case -type none -help\
"Perform case insensitive matching."
-highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\
"list of ANSI SGR style codes as supported by and documented in punk::ansi::a?"
-- -type none
@values
pattern -type string -help\
{regex pattern to match in plaintext portion of ANSI string
The pattern may contain bracketed capturing groups, which
will be highlighted in the result. If there is no capturing
group, the entire match will be highlighted.
Note that if we were to attempt to highlight curly braces based
on the regexp {\{|\}} then the inserted ansi would come between
the backslash and brace in cases where a curly brace is escaped
ie \{ or \}
Depending on how the output is used, this can break the syntactic
structure causing problems.
Instead a pair of regexes such as
{^\{|[^\\](\{+)}
{[^\\](\}+)}
should be used to
exclude braces that are escaped.
(note the capturing groups around each curly brace)
}
string -type string
}]
proc grepstr {args} {
lassign [dict values [punk::args::parse $args withid ::punk::ansi::grepstr]] leaders opts values received
set pattern [dict get $values pattern]
set data [dict get $values string]
set do_strip 0
if {[dict exists $received -ansistrip]} {
set data [punk::ansi::ansistrip $data]
}
set highlight [dict get $opts -highlight]
set opt_returnlines [dict get $opts -returnlines]
set context [dict get $opts --context] ;#int
set beforecontext [dict get $opts --before-context]
set beforecontext [expr {max($beforecontext,$context)}]
set aftercontext [dict get $opts --after-context]
set aftercontext [expr {max($aftercontext,$context)}]
set break [dict get $opts --break]
set ignorecase [dict exists $received --ignore-case]
if {$ignorecase} {
set nocase "-nocase"
} else {
set nocase ""
}
if {[dict exists $received --line-number]} {
set do_linenums 1 ;#display lineindex+1
} else {
set do_linenums 0
}
if {[llength $highlight] == 0} {
set H ""
set R ""
} else {
set H [a+ {*}$highlight]
set R \x1b\[m
}
#REVIEW
set data [string map {\r\n \n} $data]
if {[punk::ansi::ta::detect $data]} {
set raw_has_ansi 1
set plain [punk::ansi::ansistrip $data]
} else {
set raw_has_ansi 0
set plain $data
}
set plainlines [split $plain \n]
set lines [split $data \n]
set matched_line_indices [lsearch -all {*}$nocase -regexp $plainlines $pattern]
if {$opt_returnlines eq "all"} {
if {[llength $lines] > 0} {
set return_line_indices [punk::lib::range 0 [llength $lines]-1]
} else {
set return_line_indices 0
}
} else {
set return_line_indices $matched_line_indices
}
set max [lindex $return_line_indices end]
if {[string is integer -strict $max]} {
#if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary.
incr max
}
set w1 [string length $max]
set result ""
set placeholder \UFFEF ;#review
set resultlines [dict create]
foreach lineindex $return_line_indices {
set ln [lindex $lines $lineindex]
set col1 ""
if {$do_linenums} {
set col1 [format "%${w1}s " [expr {$lineindex+1}]]
}
if {$lineindex in $matched_line_indices} {
set plain_ln [lindex $plainlines $lineindex]
#first - determine the number of capturing groups (subexpressions)
#option 1: test the regexp with a single match
#set testparts [regexp {*}$nocase -inline -- $pattern $plain_ln] ;#get fullmatch capturegroup...
#set numgroups [expr {[llength $testparts] -1}]
#option 2: use the regexp -about flag
set numgroups [lindex [regexp -about $pattern] 0]
set allparts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln]
#allparts includes each full match as well as each capturing group
#early versions of tcl 8.6 still didn't support 'lsearch -stride' - avoid for now.
set matchcount [expr {[llength $allparts] / ($numgroups + 1)}]
#set matchcount [llength $allparts]
if {$matchcount == 0} {
#This probably can't happen (?)
#If it does.. it's more likely to be an issue with our line index than with regexp
puts stderr "Unexpected regex mismatch in grepstr (shouldn't happen) regex: $pattern lineindex: $lineindex"
set matchshow "??? $ln"
dict set resultlines $lineindex $matchshow
continue
}
# ------------------------------------
if {$numgroups > 0} {
# restrict ourself to just the capture groups, excluding the full match (if there are capture groups)
set highlight_ranges [list]
set i 0
#{-1 -1} returned for non-matching group when there are capture-group alternatives
#e.g {(a)|(b)}
foreach range $allparts {
if {($i % ($numgroups+1)) != 0} {
lassign $range a b
if {$range ne {-1 -1} & $a <= $b} {
lappend highlight_ranges $range
}
}
incr i
}
} else {
#No capture group in the regex, each index range is just a full match
set highlight_ranges $allparts
}
# ------------------------------------
#puts stderr "numgroups : $numgroups"
#puts stderr "grepstr pattern : $pattern"
#puts stderr "grepstr allparts: $allparts"
#puts stderr "highlight_ranges: $highlight_ranges"
if {$do_linenums} {
append col1 $H*$R[format %03s $matchcount]
}
if {$raw_has_ansi} {
set overlay ""
set i 0
foreach hrange $highlight_ranges {
lassign $hrange s e
set prelen [expr {$s - $i}]
#append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R
append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]
set i [expr {$e + 1}]
}
set tail [string range $plain_ln $e+1 end]
append overlay [string repeat $placeholder [string length $tail]]
#puts "$overlay"
#puts "$ln"
#set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay]
set rendered [overtype::renderspace -transparent $placeholder -insert_mode 0 $ln $overlay]
} else {
set rendered ""
set i 0
foreach hrange $highlight_ranges {
lassign $hrange s e
set prelen [expr {$s - $i}]
#append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]
append rendered [string range $plain_ln $i $s-1] $H [string range $plain_ln $s $e] $R
set i [expr {$e + 1}]
}
append rendered [string range $plain_ln $e+1 end]
}
if {$do_linenums} {
set matchshow "$col1 $rendered"
} else {
set matchshow $rendered
}
#---------------------------------------------------------------
set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1]
set s [expr {$lineindex-$beforecontext-1}]
if {$s < -1} {set s -1}
foreach p $prelines {
incr s
#append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format "%${w1}s " [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
}
#---------------------------------------------------------------
dict set resultlines $lineindex $matchshow
#---------------------------------------------------------------
set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext]
set s $lineindex
foreach p $postlines {
incr s
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format "%${w1}s " [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
}
#---------------------------------------------------------------
} else {
if {$do_linenums} {
append col1 "*000"
set show "$col1 $ln"
} else {
set show $ln
}
dict set resultlines $lineindex $show
}
}
set ordered_resultlines [lsort -integer [dict keys $resultlines]]
set result ""
set i -1
set do_break 0
if {$opt_returnlines eq "breaksandmatches"} {
set do_break 1
}
if {$do_break} {
foreach r $ordered_resultlines {
incr i
if {$r > $i} {
set c [expr {$r - $i}]
append result [string map [list %c% $c] $break] \n
}
append result [dict get $resultlines $r] \n
set i $r
}
if {$i<[llength $lines]-1} {
set c [expr {[llength $lines]-1-$i}]
append result [string map [list %c% $c] $break] \n
}
} else {
foreach r $ordered_resultlines {
append result [dict get $resultlines $r] \n
}
}
#important not to just strip all \n from tail
if {[string index $result end] eq "\n"} {
set result [string range $result 0 end-1]
}
return $result
}
# -------------------------------- # --------------------------------
# Taken from term::ansi::code::ctrl # Taken from term::ansi::code::ctrl
# -------------------------------- # --------------------------------
@ -952,7 +1294,7 @@ tcl::namespace::eval punk::ansi {
} }
unset _ unset _
# ------------------------------ # ------------------------------
#REVIEW - see forward/backward map in term::ansi::code::macros::cd::groptim - what are they for?? #REVIEW - see forward/backward map in term::ansi::code::macros::cd::groptim
proc groptim {string} { proc groptim {string} {
variable grforw variable grforw
variable grback variable grback
@ -2567,10 +2909,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
switch -- $pfx { switch -- $pfx {
web - Web - WEB { web - Web - WEB {
set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]]
set cont [string range $tail end-11 end] set cont [tcl::string::range $tail end-11 end]
switch -- $cont { switch -- $cont {
-contrasting - -contrastive { -contrasting - -contrastive {
set cname [string range $tail 0 end-12] set cname [tcl::string::range $tail 0 end-12]
} }
default { default {
set cname $tail set cname $tail
@ -3793,7 +4135,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
proc ansiwrap {args} { proc ansiwrap {args} {
if {[llength $args] < 1} { if {[llength $args] < 1} {
#throw to args::parse to get friendly error/usage display #throw to args::parse to get friendly error/usage display
punk::args::parse $args withid ::punk::ansi::ansiwrap punk::args::parse $args -cache 1 withid ::punk::ansi::ansiwrap
return return
} }
#we know there are no valid codes that start with - #we know there are no valid codes that start with -
@ -6135,7 +6477,7 @@ tcl::namespace::eval punk::ansi::ta {
} }
#perl: ta_strip #perl: ta_strip
punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip punk::args::set_idalias ::punk::ansi::ta::strip ::punk::ansi::ansistrip
proc strip {text} { proc strip {text} {
#*** !doctools #*** !doctools
#[call [fun strip] [arg text]] #[call [fun strip] [arg text]]

471
src/modules/punk/args-999999.0a1.0.tm

@ -303,7 +303,7 @@ tcl::namespace::eval ::punk::args::helpers {
proc example {args} { proc example {args} {
#only use punk::args::parse on the unhappy path #only use punk::args::parse on the unhappy path
if {[llength $args] == 0} { if {[llength $args] == 0} {
punk::args::parse $args withid ::punk::args::helpers::example punk::args::parse $args -cache 1 withid ::punk::args::helpers::example
return return
} }
set str [lindex $args end] set str [lindex $args end]
@ -350,11 +350,11 @@ tcl::namespace::eval ::punk::args::helpers {
} }
if {$opt_title ne ""} { if {$opt_title ne ""} {
set title "[a+ term-black Term-silver]$opt_title[a]" set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]"
} else { } else {
set title "" set title ""
} }
set str [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey white] -ansiborder [a+ term-black Term-silver] -titlealign $opt_titlealign -title $title -boxlimits {hl} -type block $str]] set str [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [punk::ansi::a+ Term-grey white] -ansiborder [punk::ansi::a+ term-black Term-silver] -titlealign $opt_titlealign -title $title -boxlimits {hl} -type block $str]]
#puts stderr ------------------- #puts stderr -------------------
#puts $str #puts $str
#puts stderr ------------------- #puts stderr -------------------
@ -368,21 +368,21 @@ tcl::namespace::eval ::punk::args::helpers {
#highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments #highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments
#result lines often indicated in examples by \u2192 → #result lines often indicated in examples by \u2192 →
#however - it's not present on each line of output, instead indents are used - so we can't so easily highlight all appropriate rows(?) #however - it's not present on each line of output, instead indents are used - so we can't so easily highlight all appropriate rows(?)
set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one set str [punk::ansi::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one
set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str] set str [punk::ansi::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str]
#Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between #Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between
# the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems. # the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems.
set str [punk::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str]
set str [punk::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str]
set str [punk::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str]
#puts stderr ------------------- #puts stderr -------------------
#puts $str #puts $str
#puts stderr ------------------- #puts stderr -------------------
} }
} }
set result [textblock::bookend_lines $str [a] "[a defaultbg] [a]"] set result [textblock::bookend_lines $str [punk::ansi::a] "[punk::ansi::a defaultbg] [punk::ansi::a]"]
return $result return $result
} }
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -464,13 +464,21 @@ tcl::namespace::eval ::punk::args::helpers {
# Base namespace # Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::args { tcl::namespace::eval punk::args {
if {[catch {
package require punk::assertion package require punk::assertion
}]} {
proc assert {args} {
#failed to load package 'punk::assertion'
}
} else {
#if 'package forget' was called on this package (e.g when loading test::punk::args) then assert may already exist in the namespace #if 'package forget' was called on this package (e.g when loading test::punk::args) then assert may already exist in the namespace
#namespace import will fail if target exists #namespace import will fail if target exists
catch { catch {
namespace import ::punk::assertion::assert namespace import ::punk::assertion::assert
} }
punk::assertion::active 1 punk::assertion::active 1
}
variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end.
@ -661,26 +669,23 @@ tcl::namespace::eval punk::args {
Defaults to string. If no other restrictions Defaults to string. If no other restrictions
are required, choosing -type any does the least validation. are required, choosing -type any does the least validation.
recognised types: recognised types:
any any, unknown
(unvalidated - accepts anything)
unknown
(unvalidated - accepts anything) (unvalidated - accepts anything)
none none
(used for flags/switches only. Indicates this is (used for flags/switches only. Indicates this is
a 'solo' flag ie accepts no value) a 'solo' flag ie accepts no value)
Not valid as a member of a clause's typenamelist. Not valid as a member of a clause's typenamelist.
int int, integer
integer
number number
list list
regex, regexp
indexexpression indexexpression
indexset indexset
(as accepted by punk::lib::is_indexset) (as accepted by punk::lib::is_indexset)
dict dict
double double
float float
bool bool, boolean
boolean
char char
file file
directory directory
@ -999,7 +1004,7 @@ tcl::namespace::eval punk::args {
undefine $id 0 undefine $id 0
} }
set is_dynamic [rawdef_is_dynamic $args] set is_dynamic [rawdef_is_dynamic $args]
set defspace [uplevel 1 {::namespace current}] set defspace [uplevel 1 {::tcl::namespace::current}]
dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace]
dict set id_cache_rawdef $id $args dict set id_cache_rawdef $id $args
return $id return $id
@ -1051,59 +1056,6 @@ tcl::namespace::eval punk::args {
} }
} }
proc idquery_info {id} {
variable id_cache_rawdef
variable rawdef_cache_about
if {[dict exists $id_cache_rawdef $id]} {
set sep [string repeat - 40]
set rawdef [dict get $id_cache_rawdef $id]
if {[dict exists $rawdef_cache_about $rawdef]} {
set idinfo [dict get $rawdef_cache_about $rawdef]
} else {
set idinfo ""
}
set result "raw definition:"
append result \n $sep
append result \n $rawdef
append result \n $sep
append result \n "id info:"
append result \n $idinfo
append result \n $sep
variable rawdef_cache_argdata
#lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?)
#check for and report if id is present multiple times
set argdata_records [list]
dict for {k v} $rawdef_cache_argdata {
if {[dict get $v id] eq $id} {
if {$k eq $rawdef} {
lappend argdata_records [list 1 $k $v]
} else {
lappend argdata_records [list 0 $k $v]
}
}
}
append result \n "argdata cache:"
if {![llength $argdata_records]} {
append result \n "(not present)"
} else {
append result \n "present [llength $argdata_records] time(s)"
foreach r $argdata_records {
lassign $r match k v
if {$match} {
append result \n " - present with same rawdef key"
} else {
append result \n " - present with different rawdef key"
append result \n " [punk::lib::indent $k { }]"
}
}
if {[llength $argdata_records] > 1} {
append result \n "*more than one record was not expected - review*"
}
}
append result \n $sep
return $result
}
}
proc define2 {args} { proc define2 {args} {
dict get [resolve {*}$args] id dict get [resolve {*}$args] id
@ -1162,10 +1114,6 @@ tcl::namespace::eval punk::args {
punk::args::parse {} -errorstyle minimal withid ::punk::args::define punk::args::parse {} -errorstyle minimal withid ::punk::args::define
return return
} }
#if {[lindex $args 0] eq "-dynamic"} {
# set is_dynamic [lindex $args 1]
# set textargs [lrange $args 2 end]
#}
#experimental #experimental
set LVL 2 set LVL 2
@ -1188,7 +1136,7 @@ tcl::namespace::eval punk::args {
set block [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]] set block [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]]
} else { } else {
puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)"
set block [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $block]] set block [uplevel $LVL [list ::punk::args::lib::tstr -return string -eval 1 -allowcommands $block]]
} }
} }
lappend optionspecs $block lappend optionspecs $block
@ -1217,43 +1165,95 @@ tcl::namespace::eval punk::args {
} else { } else {
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
#cached - so first round of substitution already done
set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key]
lassign $pt_params ptlist paramlist lassign $pt_params ptlist paramlist
set optionspecs "" set optionspecs ""
#subst is only being called on the parameters (contents of ${..})
foreach pt $ptlist param $paramlist { foreach pt $ptlist param $paramlist {
if {$defspace ne ""} {
append optionspecs $pt [namespace eval $defspace [list ::subst $param]]
} else {
puts stderr "punk::args::resolve (cached) (dynamic) calling subst in [uplevel $LVL [list namespace current]] (no defspace available!)"
append optionspecs $pt [uplevel $LVL [list ::subst $param]] append optionspecs $pt [uplevel $LVL [list ::subst $param]]
} }
}
} else { } else {
set normargs [list] set normargs [list]
foreach a $textargs { foreach a $textargs {
lappend normargs [tcl::string::map {\r\n \n} $a] lappend normargs [tcl::string::map {\r\n \n} $a]
} }
set optionspecs [join $normargs \n]
#dynamic - double substitution required. set optionspecs [list]
#e.g foreach block $normargs {
# set DYN_CHOICES {${[::somewhere::get_choice_list]}} if {[string first \$\{ $block] >= 0} {
# set RED [punk::ansi::a+ bold red]
# set RST [punk::ansi::a]
# punk::args::define {
# -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}"
#}
if {$defspace ne ""} { if {$defspace ne ""} {
set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] set block [namespace eval $defspace [list ::punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]]
#JJJ - review } else {
#set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -paramindents none $optionspecs]] puts stderr "punk::args::resolve (dynamic) calling tstr for id:$id with no known definition space (-defspace empty)"
set block [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $block]]
}
}
lappend optionspecs $block
} }
##dynamic - double substitution required.
##e.g
## set DYN_CHOICES {${[::somewhere::get_choice_list]}}
## set RED [punk::ansi::a+ bold red]
## set RST [punk::ansi::a]
## punk::args::define {
## -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}"
##}
set optionspecs [join $optionspecs \n]
#REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?)
if {[string first \$\{ $optionspecs] > 0} { if {[string first \$\{ $optionspecs] > 0} {
set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel
lassign $pt_params ptlist paramlist lassign $pt_params ptlist paramlist
set optionspecs "" set optionspecs ""
foreach pt $ptlist param $paramlist { foreach pt $ptlist param $paramlist {
if {$defspace ne ""} {
append optionspecs $pt [namespace eval $defspace [list ::subst $param]]
} else {
append optionspecs $pt [uplevel $LVL [list ::subst $param]] append optionspecs $pt [uplevel $LVL [list ::subst $param]]
} }
}
#key is the raw def, value is the 2 element list of textparts, paramparts
tcl::dict::set argdefcache_unresolved $cache_key $pt_params tcl::dict::set argdefcache_unresolved $cache_key $pt_params
} else {
#wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition
puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required"
} }
#set optionspecs [join $normargs \n]
#if {$defspace ne ""} {
# set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
# #JJJ - review
# #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -paramindents none $optionspecs]]
#}
##REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?)
#if {[string first \$\{ $optionspecs] > 0} {
# set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel
# lassign $pt_params ptlist paramlist
# set optionspecs ""
# foreach pt $ptlist param $paramlist {
# append optionspecs $pt [uplevel $LVL [list ::subst $param]]
# }
# tcl::dict::set argdefcache_unresolved $cache_key $pt_params
#}
} }
#rawdef_cache_argdata should be limited in some fashion or will be a big memory leak??? #rawdef_cache_argdata should be limited in some fashion or will be a big memory leak???
#optionspecs is the complete dynamically resolved value - we're caching how that parses into args
#This means each time a dynamic call has different results we accumulate data.. this seems potentially unsustainable in some cases - REVIEW.
#in many cases we use @dynamic only to ensure latest data, even though that may change rarely - eg for ensemble /object updates
#In that case - caching makes sense.
#For some other functions, the dynamic parts may change every time - which makes caching wasteful as old values are never reused.
#we should probably cache dynamic argdata based on id, and only keep 1 or 2 entries per id.
#At the very least, these keys aren't really 'raw' - so we should use a different dict?
if {[tcl::dict::exists $rawdef_cache_argdata [list $optionspecs]]} { if {[tcl::dict::exists $rawdef_cache_argdata [list $optionspecs]]} {
#resolved cache version exists #resolved cache version exists
return [tcl::dict::get $rawdef_cache_argdata [list $optionspecs]] return [tcl::dict::get $rawdef_cache_argdata [list $optionspecs]]
@ -1872,7 +1872,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_leaderspec_defaults $k $v tcl::dict::set tmp_leaderspec_defaults $k $v
} }
-choiceinfo - -choicelabels { -choiceinfo - -choicelabels {
if {[llength $v] %2 != 0} { if {![punk::args::lib::string_is_dict $v]} {
error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id"
} }
tcl::dict::set tmp_leaderspec_defaults $k $v tcl::dict::set tmp_leaderspec_defaults $k $v
@ -2007,7 +2007,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_valspec_defaults $k $v tcl::dict::set tmp_valspec_defaults $k $v
} }
-choiceinfo - -choicegroups { -choiceinfo - -choicegroups {
if {[llength $v] % 2 != 0} { if {![punk::args::lib::string_is_dict $v]} {
error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id"
} }
tcl::dict::set tmp_valspec_defaults $k $v tcl::dict::set tmp_valspec_defaults $k $v
@ -2474,8 +2474,8 @@ tcl::namespace::eval punk::args {
tcl::dict::set spec_merged $spec $specval tcl::dict::set spec_merged $spec $specval
} }
-validationtransform { -validationtransform {
#string is dict only 8.7/9+ #string is dict only 8.7/9+ - use wrapper to support 8.6 also
if {[llength $specval] % 2} { if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id"
} }
dict for {tk tv} $specval { dict for {tk tv} $specval {
@ -2806,7 +2806,7 @@ tcl::namespace::eval punk::args {
] ]
if {[llength $args] < 1} { if {[llength $args] < 1} {
#must have at least id #must have at least id
punk::args::parse $args withid ::punk::args::resolved_def punk::args::parse $args -cache 1 withid ::punk::args::resolved_def
return return
} }
set patterns [list] set patterns [list]
@ -3205,24 +3205,77 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef variable id_cache_rawdef
tcl::dict::exists $id_cache_rawdef $id tcl::dict::exists $id_cache_rawdef $id
} }
proc aliases {} { proc idaliases {} {
variable aliases variable aliases
punk::lib::showdict $aliases punk::lib::showdict $aliases
} }
proc set_alias {alias id} { proc set_idalias {alias id} {
variable aliases variable aliases
dict set aliases $alias $id dict set aliases $alias $id
} }
proc unset_alias {alias} { proc unset_idalias {alias} {
variable aliases variable aliases
dict unset aliases $alias dict unset aliases $alias
} }
proc get_alias {alias} { proc get_idalias {alias} {
variable aliases variable aliases
if {[dict exists $aliases $alias]} { if {[dict exists $aliases $alias]} {
return [tcl::dict::get $aliases $alias] return [tcl::dict::get $aliases $alias]
} }
} }
proc id_query {id} {
variable id_cache_rawdef
variable rawdef_cache_about
if {[dict exists $id_cache_rawdef $id]} {
set sep [string repeat - 40]
set rawdef [dict get $id_cache_rawdef $id]
if {[dict exists $rawdef_cache_about $rawdef]} {
set idinfo [dict get $rawdef_cache_about $rawdef]
} else {
set idinfo ""
}
set result "raw definition:"
append result \n $sep
append result \n $rawdef
append result \n $sep
append result \n "id info:"
append result \n $idinfo
append result \n $sep
variable rawdef_cache_argdata
#lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?)
#check for and report if id is present multiple times
set argdata_records [list]
dict for {k v} $rawdef_cache_argdata {
if {[dict get $v id] eq $id} {
if {$k eq $rawdef} {
lappend argdata_records [list 1 $k $v]
} else {
lappend argdata_records [list 0 $k $v]
}
}
}
append result \n "argdata cache:"
if {![llength $argdata_records]} {
append result \n "(not present)"
} else {
append result \n "present [llength $argdata_records] time(s)"
foreach r $argdata_records {
lassign $r match k v
if {$match} {
append result \n " - present with same rawdef key"
} else {
append result \n " - present with different rawdef key"
append result \n " [punk::lib::indent $k { }]"
}
}
if {[llength $argdata_records] > 1} {
append result \n "*more than one record was not expected - review*"
}
}
append result \n $sep
return $result
}
}
proc real_id {id} { proc real_id {id} {
variable id_cache_rawdef variable id_cache_rawdef
@ -3452,7 +3505,7 @@ tcl::namespace::eval punk::args {
#process list of 2-element lists #process list of 2-element lists
if {[info exists ${pkgns}::PUNKARGS_aliases]} { if {[info exists ${pkgns}::PUNKARGS_aliases]} {
foreach adef [set ${pkgns}::PUNKARGS_aliases] { foreach adef [set ${pkgns}::PUNKARGS_aliases] {
punk::args::set_alias {*}$adef punk::args::set_idalias {*}$adef
} }
} }
} errMsg]} { } errMsg]} {
@ -4968,7 +5021,7 @@ tcl::namespace::eval punk::args {
arglist -type list -optional 0 -help\ arglist -type list -optional 0 -help\
"Arguments to parse - supplied as a single list" "Arguments to parse - supplied as a single list"
@opts @opts -prefix 0
-form -type list -default * -help\ -form -type list -default * -help\
"Restrict parsing to the set of forms listed. "Restrict parsing to the set of forms listed.
Forms are the orthogonal sets of arguments a Forms are the orthogonal sets of arguments a
@ -5014,7 +5067,7 @@ tcl::namespace::eval punk::args {
set tailtype "" ;#withid|withdef set tailtype "" ;#withid|withdef
if {[llength $args] < 3} { if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args" #error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args withid ::punk::args::parse punk::args::parse $args -cache 1 withid ::punk::args::parse
} }
set opts_and_vals $args set opts_and_vals $args
set parseargs [lpop opts_and_vals 0] set parseargs [lpop opts_and_vals 0]
@ -5125,15 +5178,22 @@ tcl::namespace::eval punk::args {
variable parse_cache variable parse_cache
set key [list $parseargs $deflist [dict get $opts -form]] set key [list $parseargs $deflist [dict get $opts -form]]
if {[dict exists $parse_cache $key]} { if {[dict exists $parse_cache $key]} {
set result [dict get $parse_cache $key] set cached [dict get $parse_cache $key]
if {[dict get $cached type] eq "result"} {
return [dict get $cached value]
} else { } else {
set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] #return the error 'elist'
dict set parse_cache $key $result return {*}[dict get $cached value]
} }
} else {
set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]]
dict set parse_cache $key [dict create type "result" value $result]
return $result return $result
} }
}
} trap {PUNKARGS VALIDATION} {msg erroropts} { } trap {PUNKARGS VALIDATION} {msg erroropts} {
set opt_errorstyle [dict get $opts -errorstyle] set opt_errorstyle [dict get $opts -errorstyle]
set matched_errorstyle [tcl::prefix::match -error "" {enhanced standard basic minimal debug} $opt_errorstyle]
#samples from get_dict (review: -argspecs <dict> can be *large* especially for multi-form argument definitions) #samples from get_dict (review: -argspecs <dict> can be *large* especially for multi-form argument definitions)
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg
@ -5143,9 +5203,10 @@ tcl::namespace::eval punk::args {
set ecode [dict get $erroropts -errorcode] set ecode [dict get $erroropts -errorcode]
#punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ...
set msg [string map [list %caller% [Get_caller]] $msg] set msg [string map [list %caller% [Get_caller]] $msg]
switch -- $opt_errorstyle { switch -- $matched_errorstyle {
minimal { minimal {
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} }
basic { basic {
#No table layout - unix manpage style #No table layout - unix manpage style
@ -5155,7 +5216,8 @@ tcl::namespace::eval punk::args {
if {$argspecs ne ""} { if {$argspecs ne ""} {
set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]]
} }
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} }
standard { standard {
set customdict [lrange $ecode 3 end] set customdict [lrange $ecode 3 end]
@ -5164,7 +5226,8 @@ tcl::namespace::eval punk::args {
if {$argspecs ne ""} { if {$argspecs ne ""} {
set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]]
} }
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} }
enhanced { enhanced {
set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below)
@ -5182,23 +5245,31 @@ tcl::namespace::eval punk::args {
if {$argspecs ne ""} { if {$argspecs ne ""} {
set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]]
append msg \n "::errorCode summary: $ecode_summary" append msg \n "::errorCode summary: $ecode_summary"
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} else { } else {
#why? todo? #why? todo?
append msg \n "(enhanced error information unavailable)" append msg \n "(enhanced error information unavailable)"
append msg \n "::errorCode summary: $ecode_summary" append msg \n "::errorCode summary: $ecode_summary"
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} }
} }
debug { debug {
puts stderr "errorstyle debug not implemented" puts stderr "errorstyle debug not implemented"
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} }
default { default {
puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug"
return -options [list -code error -errorcode $ecode] $msg #return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} }
} }
set key [list $parseargs $deflist [dict get $opts -form]]
dict set parse_cache $key [dict create type "error" value $elist]
return {*}$elist
} trap {PUNKARGS} {msg erropts} { } trap {PUNKARGS} {msg erropts} {
append msg \n "Unexpected PUNKARGS error" append msg \n "Unexpected PUNKARGS error"
return -options [list -code error -errorcode $ecode] $msg return -options [list -code error -errorcode $ecode] $msg
@ -5312,7 +5383,7 @@ tcl::namespace::eval punk::args {
} }
stringstartswith { stringstartswith {
set pfx [lindex $tp_alternative 1] set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v} { if {[string match "$pfx*" $v]} {
set alloc_ok 1 set alloc_ok 1
set alloc_ok 1 set alloc_ok 1
ledit all_remaining end end ledit all_remaining end end
@ -5325,7 +5396,7 @@ tcl::namespace::eval punk::args {
} }
stringendswith { stringendswith {
set sfx [lindex $tp_alternative 1] set sfx [lindex $tp_alternative 1]
if {[string match "*$sfx" $v} { if {[string match "*$sfx" $v]} {
set alloc_ok 1 set alloc_ok 1
set alloc_ok 1 set alloc_ok 1
ledit all_remaining end end ledit all_remaining end end
@ -6263,6 +6334,16 @@ tcl::namespace::eval punk::args {
lset clause_results $c_idx $a_idx 1 lset clause_results $c_idx $a_idx 1
break break
} }
regex - regexp {
#todo - allow -min and -max to specify number of allowed subexpressions(capture groups) present in regex?
if {[catch {regexp -about $e_check} re_about_msg]} {
set msg "$argclass $argname for %caller% requires type regexp. $re_about_msg. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
indexexpression { indexexpression {
if {[catch {lindex {} $e_check}]} { if {[catch {lindex {} $e_check}]} {
set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'"
@ -6553,11 +6634,14 @@ tcl::namespace::eval punk::args {
} }
} }
dict { dict {
if {[llength $e_check] %2 != 0} { #to maintain support for tcl 8.6 - can't directly use 'string is dict'
if {![punk::args::lib::string_is_dict $e_check]} {
set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue continue
} }
#if {[llength $e_check] %2 != 0} {
#}
if {[tcl::dict::size $thisarg_checks]} { if {[tcl::dict::size $thisarg_checks]} {
if {[dict exists $thisarg_checks -minsize]} { if {[dict exists $thisarg_checks -minsize]} {
set minsizes [dict get $thisarg_checks -minsize] set minsizes [dict get $thisarg_checks -minsize]
@ -7420,7 +7504,7 @@ tcl::namespace::eval punk::args {
proc get_dict {deflist rawargs args} { proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance #see arg_error regarding considerations around unhappy-path performance
if {[llength $args] % 2 != 0} { if {![punk::args::lib::string_is_dict $args]} {
error "punk::args::get_dict args must be a dict of option value pairs" error "punk::args::get_dict args must be a dict of option value pairs"
} }
set defaults [dict create\ set defaults [dict create\
@ -9186,11 +9270,26 @@ tcl::namespace::eval punk::args {
#lappend vlist_check_validate $c_check #lappend vlist_check_validate $c_check
} else { } else {
#unhappy path #unhappy path
#if prefixes allowed, first see if c_check is an ambiguous prefix
#This is preferable to listing all (possibly many) choices in the error message.
if {$choiceprefix} { if {$choiceprefix} {
set prefixmsg " (or a unique prefix of a value)" set prefixmsg " (or a unique prefix of a value)"
#review - case
if {$nocase} {
set longermatches [lsearch -all -inline -nocase $allchoices "$c_check*"]
} else {
set longermatches [lsearch -all -inline $allchoices "$c_check*"]
}
if {[llength $longermatches]} {
set msg "$argclass '$argname' for %caller% seems to be an ambiguous prefix. Try one of:\n [join $longermatches "\n "]\n$casemsg$prefixmsg. Received: '$c_check'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg
}
} else { } else {
set prefixmsg "" set prefixmsg ""
} }
#review: $c vs $c_check for -badval? #review: $c vs $c_check for -badval?
set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg
@ -9465,26 +9564,13 @@ tcl::namespace::eval punk::args {
#synopsis potentially called repeatedly with same args? use -cache 1 #synopsis potentially called repeatedly with same args? use -cache 1
set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis] set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis]
if {[catch {package require punk::ansi} errM]} { #non-colour SGR such as bold/italic/strike - so we don't need to worry about NOCOLOR settings
set has_punkansi 0 set I "\x1b\[3m" ;#[punk::ansi::a+ italic]
} else { set NI "\x1b\[23m" ;# [punk::ansi::a+ noitalic]
set has_punkansi 1
}
if {$has_punkansi} {
set I [punk::ansi::a+ italic]
set NI [punk::ansi::a+ noitalic]
#for inner question marks marking optional type #for inner question marks marking optional type
set IS [punk::ansi::a+ italic strike] set IS "\x1b\[3\;9m" ;#[punk::ansi::a+ italic strike]
set NIS [punk::ansi::a+ noitalic nostrike] set NIS "\x1b\[23\;29m" ;#[punk::ansi::a+ noitalic nostrike]
#set RST [punk::ansi::a] set RST "\x1b\[m" ;#[punk::ansi::a]
set RST "\x1b\[m"
} else {
set I ""
set NI ""
set IS ""
set NIS ""
set RST ""
}
##set form * ##set form *
##if {[lindex $args 0] eq "-form"} { ##if {[lindex $args 0] eq "-form"} {
@ -9503,8 +9589,7 @@ tcl::namespace::eval punk::args {
set form [dict get $opts -form] set form [dict get $opts -form]
set opt_return [dict get $opts -return] set opt_return [dict get $opts -return]
set cmditems [dict get $values cmditem] set cmditems [dict get $values cmditem]
set id [lindex $cmditems 0] set cmdargs [lassign $cmditems id]
set cmdargs [lrange $cmditems 1 end]
set spec [get_spec $id] set spec [get_spec $id]
@ -9969,6 +10054,9 @@ tcl::namespace::eval punk::args {
} }
summary { summary {
set summary "" set summary ""
if {![dict exists $received -noheader]} {
set summary "# [Dict_getdef $spec cmd_info -summary ""]\n"
}
set FORMS [dict get $SYND FORMS] set FORMS [dict get $SYND FORMS]
dict for {form arglist} $FORMS { dict for {form arglist} $FORMS {
append summary $id append summary $id
@ -10001,7 +10089,13 @@ tcl::namespace::eval punk::args {
append summary \n append summary \n
} }
set summary [string trim $summary \n] set summary [string trim $summary \n]
#only return as summary if full synopsis is wider
#(e.g single option can commonly be shorter than "?options (1 defined)?"
if {[textblock::width $summary] < [textblock::width $syn]} {
return $summary return $summary
} else {
return [string trim $syn \n]
}
} }
dict { dict {
return $SYND return $SYND
@ -10022,7 +10116,7 @@ tcl::namespace::eval punk::args {
synopsis -multiple 0 -optional 0 synopsis -multiple 0 -optional 0
}] }]
proc synopsis_summary {args} { proc synopsis_summary {args} {
set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis_summary]
set synopsis [dict get $argd values synopsis] set synopsis [dict get $argd values synopsis]
set summary "" set summary ""
foreach sline [split $synopsis \n] { foreach sline [split $synopsis \n] {
@ -10092,7 +10186,7 @@ tcl::namespace::eval punk::args {
in the choices list. in the choices list.
Subcommands not assigned to a groupname will appear first Subcommands not assigned to a groupname will appear first
in an untitled subtable." in an untitled subtable."
-columns -default 4 -type integer -help\ -columns -default 2 -type integer -help\
"Max number of columns for all subtables in the choices "Max number of columns for all subtables in the choices
display area" display area"
@values -min 1 -max 1 @values -min 1 -max 1
@ -10114,7 +10208,7 @@ tcl::namespace::eval punk::args {
} }
set defaults [dict create\ set defaults [dict create\
-groupdict {}\ -groupdict {}\
-columns 4\ -columns 2\
] ]
set optlist [dict merge $defaults $optlist] set optlist [dict merge $defaults $optlist]
dict for {k v} $optlist { dict for {k v} $optlist {
@ -10131,7 +10225,42 @@ tcl::namespace::eval punk::args {
#warning - circular package dependency if we try to use this function on punk::ns! #warning - circular package dependency if we try to use this function on punk::ns!
package require punk::ns package require punk::ns
set subdict [punk::ns::ensemble_subcommands -return dict $ensemble] set subdict [uplevel 1 [list punk::ns::ensemble_subcommands -return dict $ensemble]]
set unkhandler [uplevel 1 [list ::tcl::namespace::ensemble configure $ensemble -unknown]]
# ----------------------------------------------------------------------------------------------------------------------------
#resolution for unknown if performed via another ensemble (eg see punk::lib::ensemble::extend and "ensemble extend" on wiki)
#we cannot sensibly determine subcommands for arbitrary -unknown scripts - but we can for this known (common?) method
# Note that an ensemble might have been extended this way more than once.
set resolve_unknowns 1
set next_handler $unkhandler
while {$resolve_unknowns} {
#ensure bogus isn't in already known subcommands
set n 1
set bogus "<bogussubcommand$n>"
set known_subs [dict keys $subdict]
while {$bogus in $known_subs} {
incr n
set bogus "<bogussubcommand$n>"
}
if {![catch {uplevel 1 [list {*}$next_handler] $ensemble $bogus} unk_resolver]} {
lassign $unk_resolver unk_ensemble
if {[uplevel 1 [list ::tcl::namespace::ensemble exists $unk_ensemble]]} {
set unkdict [uplevel 1 [list punk::ns::ensemble_subcommands -return dict $unk_ensemble]]
set subdict [dict merge $unkdict $subdict]
set next_handler [uplevel 1 [list ::tcl::namespace::ensemble configure $unk_ensemble -unknown]]
if {$next_handler eq ""} {
set resolve_unknowns 0
}
} else {
set resolve_unknowns 0
}
} else {
set resolve_unknowns 0
}
}
# ----------------------------------------------------------------------------------------------------------------------------
set allsubs [dict keys $subdict] set allsubs [dict keys $subdict]
# ---------------------------------------------- # ----------------------------------------------
# manually defined group members may have subcommands that are obsoleted/missing # manually defined group members may have subcommands that are obsoleted/missing
@ -10187,6 +10316,8 @@ tcl::namespace::eval punk::args {
lappend others $sc lappend others $sc
} }
} }
#sometimes the subdict we get from the namespace ensemble map is not sorted
set others [lsort $others]
#don't use full cmdinfo if $cmd is a single element #don't use full cmdinfo if $cmd is a single element
if {[llength $cmd] == 1} { if {[llength $cmd] == 1} {
@ -10218,12 +10349,15 @@ tcl::namespace::eval punk::args {
$cmd\ $cmd\
[dict get $cinfo origin]\ [dict get $cinfo origin]\
] ]
set N [punk::ansi::a+ normal]
set RST [punk::ansi::a]
foreach checkid $id_checks { foreach checkid $id_checks {
if {[punk::args::id_exists $checkid]} { if {[punk::args::id_exists $checkid]} {
dict lappend choiceinfodict $sc {doctype punkargs} dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$checkid] dict lappend choiceinfodict $sc [list subhelp {*}$checkid]
#dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::ns::synopsis $checkid][punk::ansi::a] #dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::ns::synopsis $checkid][punk::ansi::a]
dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::args::synopsis $checkid][punk::ansi::a] #dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::args::synopsis $checkid][punk::ansi::a]
dict set choicelabelsdict $sc ${N}[punk::args::synopsis -return summary $checkid]${RST}
break break
} }
} }
@ -10253,8 +10387,12 @@ tcl::namespace::eval punk::args {
#} #}
} }
set help ""
if {$unkhandler ne ""} {
set help [list -help "[punk::ansi::a+ bold]WARNING: -unknown handler exists. Not all options may be displayed.[punk::ansi::a]"]
}
set argdef "" set argdef ""
append argdef "subcommand -choicegroups \{" \n append argdef "subcommand $help -choicegroups \{" \n
append argdef " \"\" \{$others\}" \n append argdef " \"\" \{$others\}" \n
dict for {g members} $opt_groupdict { dict for {g members} $opt_groupdict {
append argdef " \"$g\" \{$members\}" \n append argdef " \"$g\" \{$members\}" \n
@ -10303,7 +10441,8 @@ tcl::namespace::eval punk::args::lib {
#tcl86 compat for string is dict - but without -strict or -failindex options #tcl86 compat for string is dict - but without -strict or -failindex options
if {[catch {string is dict {}} errM]} { if {[catch {string is dict {}} errM]} {
proc string_is_dict {args} { proc string_is_dict {args} {
#ignore opts #compatibility for tcl pre 9.0
#ignores opts
set str [lindex $args end] set str [lindex $args end]
if {[catch {llength $str} len]} { if {[catch {llength $str} len]} {
return 0 return 0
@ -10315,6 +10454,7 @@ tcl::namespace::eval punk::args::lib {
} }
} else { } else {
proc string_is_dict {args} { proc string_is_dict {args} {
#tcl 9+ version
string is dict {*}$args string is dict {*}$args
} }
} }
@ -10525,8 +10665,9 @@ tcl::namespace::eval punk::args::lib {
dict set opts -allowcommands 1 dict set opts -allowcommands 1
} }
if {[llength $arglist] % 2 != 0} { if {[llength $arglist] % 2 != 0} {
if {[info commands ::punk::args::get_by_id] ne ""} { if {[info commands ::punk::args::parse] ne ""} {
punk::args::get_by_id ::punk::args::lib::tstr $args #punk::args::get_by_id ::punk::args::lib::tstr $args
punk::args::parse $args withid ::punk::args::lib::tstr
return return
} else { } else {
error "punk::args::lib::tstr expected option/value pairs prior to last argument" error "punk::args::lib::tstr expected option/value pairs prior to last argument"
@ -10539,8 +10680,9 @@ tcl::namespace::eval punk::args::lib {
dict set opts $fullk $v dict set opts $fullk $v
} }
default { default {
if {[info commands ::punk::args::get_by_id] ne ""} { if {[info commands ::punk::args::parse] ne ""} {
punk::args::get_by_id ::punk::args::lib::tstr $args #punk::args::get_by_id ::punk::args::lib::tstr $args
punk::args::parse $args withid ::punk::args::lib::tstr
return return
} else { } else {
error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]"
@ -10576,7 +10718,6 @@ tcl::namespace::eval punk::args::lib {
set templatestring [punk::args::lib::indent $templatestring $opt_indent] set templatestring [punk::args::lib::indent $templatestring $opt_indent]
} }
#set parts [_tstr_split $templatestring]
if {[string first \$\{ $templatestring] < 0} { if {[string first \$\{ $templatestring] < 0} {
set parts [list $templatestring] set parts [list $templatestring]
} else { } else {
@ -10787,42 +10928,6 @@ tcl::namespace::eval punk::args::lib {
} }
return $parts return $parts
} }
#based on punk::ansi::ta::_perlish_split
proc _tstr_split {text} {
if {$text eq ""} {
return {}
}
set list [list]
set start 0
#ideally re should allow curlies within but we will probably need a custom parser to do it
#(js allows nested string interpolation)
#set re {\$\{[^\}]*\}}
set re {\$\{(?:(?!\$\{).)*\}}
#eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code
#We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW
while {[regexp -start $start -indices -- $re $text match]} {
lassign $match matchStart matchEnd
#puts "->start $start ->match $matchStart $matchEnd"
if {$matchEnd < $matchStart} {
puts "e:$matchEnd < s:$matchStart"
lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart]
incr start
if {$start >= [tcl::string::length $text]} {
break
}
continue
}
lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1]
set start [expr {$matchEnd+1}]
#?
if {$start >= [tcl::string::length $text]} {
break
}
}
return [lappend list [tcl::string::range $text $start end]]
}
#like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter.
proc indent {text {prefix " "}} { proc indent {text {prefix " "}} {

490
src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm

@ -1535,8 +1535,11 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::fconfigure @id -id ::fconfigure
@cmd -name "Built-in: chan configure" -help\ @cmd -name "Built-in: chan configure"\
"Query or set the configuration options of the channel named ${$I}channel${$NI} -summary\
{Query/set channel configuration options}\
-help\
{Query or set the configuration options of the channel named ${$I}channel${$NI}
If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the
command returns a list containing alternating option names and values for the command returns a list containing alternating option names and values for the
channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the
@ -1577,12 +1580,106 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
${$I}newSize${$NI} must be a number of no more than one million, allowing buffers of ${$I}newSize${$NI} must be a number of no more than one million, allowing buffers of
up to one million bytes in size. up to one million bytes in size.
${$B}-encoding${$N} ${$I}name${$NI} ${$B}-encoding${$N} ${$I}name${$NI}
This option is used to specify the encoding of the channel as one of the
named encodings returned by ${$B}encoding names${$N}, so that the data can be
converted to and from Unicode for use in Tcl. For instance, in order for
Tcl to read characters from a Japanese file in ${$B}shiftjis${$N} and properly
process and display the contents, the encoding would be set to ${$B}shiftjis${$N}.
Thereafter, when reading from the channel, the bytes in the Japanese file
would be converted to Unicode as they are read. Writing is also supported
- as Tcl strings are written to the channel they will automatically be
converted to the specified encoding on output.
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be ${$B}iso8859-1${$N}. Tcl will
then assign no interpretation to the data in the file and simply read or
write raw bytes. The Tcl ${$B}binary${$N} command can be used to manipulate this
byte-oriented data. It is usually better to set the ${$B}-translation${$B} option to
${$B}binary${$N} when you want to transfer binary data, as this turns off the other
automatic interpretations of the bytes in the stream as well.
The default encoding for newly opened channels is the same platform- and
locale-dependent system encoding used for interfacing with the operating
system, as returned by encoding system.
${$B}-eofchar${$N} ${$I}char${$NI} ${$B}-eofchar${$N} ${$I}char${$NI}
This option supports DOS file systems that use Control-z (\x1A) as an end
of file marker. If char is not an empty string, then this character signals
end-of-file when it is encountered during input. Otherwise (the default)
there is no special end of file character marker. The acceptable range for
${$B}-eofchar${$N} values is \x01 - \x7f; attempting to set ${$B}-eofchar${$N} to a value
outside of this range will generate an error.
${$B}-profile${$N} ${$I}profile${$NI} ${$B}-profile${$N} ${$I}profile${$NI}
Specifies the encoding profile to be used on the channel. The encoding
${$B}-translation${$N} ${$I}translation${$NI}" transforms in use for the channel's input and output will then be subject
to the rules of that profile. Any failures will result in a channel error.
See ${$B}PROFILES${$N} in the ${$B}encoding(n)${$N} documentation for details about encoding
profiles.
${$B}-translation${$N} ${$I}translation${$NI}
${$B}-translation${$N} {${$I}inTranslation${$NI} ${$I}outTranslation${$NI}}
In Tcl scripts the end of a line is always represented using a single
newline character (\n). However, in actual files and devices the end of a
line may be represented differently on different platforms, or even for
different devices on the same platform. For example, under UNIX newlines
are used in files, whereas carriage-return-linefeed sequences are normally
used in network connections. On input (i.e., with ${$B}chan gets${$N} and ${$B}chan read${$N})
the Tcl I/O system automatically translates the external end-of-line
representation into newline characters. Upon output (i.e., with ${$B}chan puts${$N}),
the I/O system translates newlines to the external end-of-line representation.
The default translation mode, ${$B}auto${$N}, handles all the common cases
automatically, but the ${$B}-translation${$N} option provides explicit control over the
end of line translations.
The value associated with -translation is a single item for read-only and
write-only channels. The value is a two-element list for read-write channels;
the read translation mode is the first element of the list, and the write
translation mode is the second element. As a convenience, when setting the
translation mode for a read-write channel you can specify a single value that
will apply to both reading and writing. When querying the translation mode of
a read-write channel, a two-element list will always be returned. The
following values are currently supported:
${$B}auto${$N}
As the input translation mode, ${$B}auto${$N} treats any of newline (${$B}lf${$N}), carriage
return (${$B}cr${$N}), or carriage return followed by a newline (${$B}crlf${$N}) as the end of
line representation. The end of line representation can even change from
line-to-line, and all cases are translated to a newline. As the output
translation mode, ${$B}auto${$N} chooses a platform specific representation; for
sockets on all platforms Tcl chooses ${$B}crlf${$N}, for all Unix flavors, it
chooses ${$B}lf${$N}, and for the various flavors of Windows it chooses ${$B}crlf${$N}. The
default setting for ${$B}-translation${$N} is ${$B}auto${$N} for both input and output.
${$B}binary${$N}
Like ${$B}lf${$N}, no end-of-line translation is performed, but in addition, sets
${$B}-eofchar${$N} to the empty string to disable it, and sets ${$B}-encoding${$N} to
${$B}iso8859-1${$N}. With this one setting, a channel is fully configured for binary
input and output: Each byte read from the channel becomes the Unicode
character having the same value as that byte, and each character written
to the channel becomes a single byte in the output. This makes it possible
to work seamlessly with binary data as long as each character in the data
remains in the range of 0 to 255 so that there is no distinction between
binary data and text. For example, A JPEG image can be read from a such a
channel, manipulated, and then written back to such a channel.
${$B}cr${$N}
The end of a line in the underlying file or device is represented by a
single carriage return character. As the input translation mode, ${$B}cr${$N} mode
converts carriage returns to newline characters. As the output translation
mode, ${$B}cr${$N} mode translates newline characters to carriage returns.
${$B}crlf${$N}
The end of a line in the underlying file or device is represented by a
carriage return character followed by a linefeed character. As the input
translation mode, ${$B}crlf${$N} mode converts carriage-return-linefeed sequences to
newline characters. As the output translation mode, ${$B}crlf${$N} mode translates
newline characters to carriage-return-linefeed sequences. This mode is
typically used on Windows platforms and for network connections.
${$B}lf${$N}
The end of a line in the underlying file or device is represented by a
single newline (linefeed) character. In this mode no translations occur
during either input or output. This mode is typically used on UNIX
platforms.
}
@form -form {getall} @form -form {getall}
@values -min 1 -max 1 @values -min 1 -max 1
@ -2859,7 +2956,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::tcl::file::mkdir @id -id ::tcl::file::mkdir
@cmd -name "Built-in: tcl::file::mkdir" -help\ @cmd -name "Built-in: tcl::file::mkdir"\
-summary\
{Create one or more directories.}\
-help\
"Creates each directory specified. "Creates each directory specified.
For each pathname ${$I}dir${$NI} specified, this command will create all non-existing parent directories For each pathname ${$I}dir${$NI} specified, this command will create all non-existing parent directories
as well as ${$I}dir${$NI} itself. If an existing directory is specified, then no action is taken and no as well as ${$I}dir${$NI} itself. If an existing directory is specified, then no action is taken and no
@ -2872,7 +2972,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::tcl::file::mtime @id -id ::tcl::file::mtime
@cmd -name "Built-in: tcl::file::mtime" -help\ @cmd -name "Built-in: tcl::file::mtime"\
-summary\
{Get/set file modification time.}\
-help\
"Returns a decimal string giving the time at which file ${$I}name${$NI} was last modified. "Returns a decimal string giving the time at which file ${$I}name${$NI} was last modified.
If ${$I}time${$NI} is specified, it is a modification time to set for the file (equivalent If ${$I}time${$NI} is specified, it is a modification time to set for the file (equivalent
to Unix ${$B}touch${$N}). The time is measured in the standard POSIX fashion as seconds to Unix ${$B}touch${$N}). The time is measured in the standard POSIX fashion as seconds
@ -2889,14 +2992,41 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
#pathtype #pathtype
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::tcl::file::readable @id -id ::tcl::file::readable
@cmd -name "Built-in: tcl::file::readable" -help\ @cmd -name "Built-in: tcl::file::readable"\
-summary\
{Test file readable by current user.}\
-help\
"Returns ${$B}1${$N} if the file ${$I}name${$NI} is readable by the current user, ${$B}0${$N} otherwise." "Returns ${$B}1${$N} if the file ${$I}name${$NI} is readable by the current user, ${$B}0${$N} otherwise."
@values -min 1 -max 1 @values -min 1 -max 1
name -optional 0 -type string name -optional 0 -type string
} "@doc -name Manpage: -url [manpage_tcl file]"] } "@doc -name Manpage: -url [manpage_tcl file]"]
#readlink
lappend PUNKARGS [list {
@id -id ::tcl::file::readlink
@cmd -name "Built-in: tcl::file::readlink"\
-summary\
{Get target of symbolic link.}\
-help\
"Returns the value of the symbolic link given by ${$I}name${$NI} (i.e. the name of the file it points to).
If ${$I}name${$NI} is not a symbolic link or its value cannot be read, then an error is returned.
On systems that do not support symbolic links this option is undefined."
@values -min 1 -max 1
name -optional 0 -type string
} "@doc -name Manpage: -url [manpage_tcl file]"]
#rename (2 forms) #rename (2 forms)
#rootname lappend PUNKARGS [list {
@id -id ::tcl::file::rootname
@cmd -name "Built-in: tcl::file::rootname"\
-summary\
{Name without dot and extension}\
-help\
"Returns all of the characters in ${$I}name${$NI} up to but not including the last “.” character in
the last component of name. If the last component of ${$I}name${$NI} does not contain a dot, then
returns ${$I}name${$NI}."
@values -min 1 -max 1
name -optional 0 -type string
} "@doc -name Manpage: -url [manpage_tcl file]"]
#separator #separator
#size #size
#split #split
@ -2911,7 +3041,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::tcl::file::writable @id -id ::tcl::file::writable
@cmd -name "Built-in: tcl::file::writable" -help\ @cmd -name "Built-in: tcl::file::writable"\
-summary\
{Test file writable by current user.}\
-help\
"Returns ${$B}1${$N} if the file ${$I}name${$NI} is writable by the current user, ${$B}0${$N} otherwise." "Returns ${$B}1${$N} if the file ${$I}name${$NI} is writable by the current user, ${$B}0${$N} otherwise."
@values -min 1 -max 1 @values -min 1 -max 1
name -optional 0 -type string name -optional 0 -type string
@ -8645,9 +8778,12 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::compare @id -id ::tcl::string::compare
@cmd -name "Built-in: tcl::string::compare" -help\ @cmd -name "Built-in: tcl::string::compare"\
-summary\
"Compare lexicographical order of 2 strings."\
-help\
"Perform a character-by-character comparison of strings string1 and string2. "Perform a character-by-character comparison of strings string1 and string2.
Returns -1, 0, or 1, dpending on whether string1 is lexicographically Returns -1, 0, or 1, depending on whether string1 is lexicographically
less than, equal to, or greater than string2" less than, equal to, or greater than string2"
-nocase -type none -help\ -nocase -type none -help\
@ -8667,7 +8803,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
@cmd -name "Built-in: tcl::string::equal"\ @cmd -name "Built-in: tcl::string::equal"\
-summary\ -summary\
"Compare strings."\ "Compare strings for equality."\
-help\ -help\
"Perform a character-by-character comparison of strings string1 and string2. "Perform a character-by-character comparison of strings string1 and string2.
Returns 1 if string1 and string2 are identical, or 0 when not." Returns 1 if string1 and string2 are identical, or 0 when not."
@ -8686,7 +8822,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::first @id -id ::tcl::string::first
@cmd -name "Built-in: tcl::string::first" -help\ @cmd -name "Built-in: tcl::string::first"\
-summary\
"Index of first match."\
-help\
"Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters "Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters
in ${$I}needleString${$NI}. If found, return the index of the first character in the first such in ${$I}needleString${$NI}. If found, return the index of the first character in the first such
match within ${$I}haystackString${$NI}. If there is no match, then return -1. If startIndex is match within ${$I}haystackString${$NI}. If there is no match, then return -1. If startIndex is
@ -8709,7 +8848,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::index @id -id ::tcl::string::index
@cmd -name "Built-in: tcl::string::index" -help\ @cmd -name "Built-in: tcl::string::index"\
-summary\
"Return character at ${$I}charIndex${$NI}."\
-help\
"Returns the ${$I}charIndex${$NI}'th character of the ${$I}string${$NI} argument. A ${$I}charIndex${$NI} of 0 "Returns the ${$I}charIndex${$NI}'th character of the ${$I}string${$NI} argument. A ${$I}charIndex${$NI} of 0
corresponds to the first character of the string. ${$I}charIndex${$NI} may be specified corresponds to the first character of the string. ${$I}charIndex${$NI} may be specified
as described in the STRING INDICES section." as described in the STRING INDICES section."
@ -8720,7 +8862,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::insert @id -id ::tcl::string::insert
@cmd -name "Built-in: tcl::string::insert" -help\ @cmd -name "Built-in: tcl::string::insert"\
-summary\
"Return copy of string with insertion at ${$I}index${$NI}."\
-help\
"Returns a copy of string with insertString inserted at the index'th character. "Returns a copy of string with insertString inserted at the index'th character.
If index is start-relative, the first character inserted in the returned string will be If index is start-relative, the first character inserted in the returned string will be
at the specified index. at the specified index.
@ -8741,7 +8886,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::last @id -id ::tcl::string::last
@cmd -name "Built-in: tcl::string::last" -help\ @cmd -name "Built-in: tcl::string::last"\
-summary\
"Index of last match."\
-help\
"Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters "Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters
in ${$I}needleString${$NI}. If found, return the index of the first character in the last such in ${$I}needleString${$NI}. If found, return the index of the first character in the last such
match within ${$I}haystackString${$NI}. If there is no match, then return -1. If lastIndex is match within ${$I}haystackString${$NI}. If there is no match, then return -1. If lastIndex is
@ -8763,7 +8911,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::length @id -id ::tcl::string::length
@cmd -name "Built-in: tcl::string::length" -help\ @cmd -name "Built-in: tcl::string::length"\
-summary\
"Number of characters in string."\
-help\
"Returns a decimal string giving the number of characters in ${$I}string${$NI}. Note that this is "Returns a decimal string giving the number of characters in ${$I}string${$NI}. Note that this is
not necessarily the same as the number of bytes used to store the string. If the value not necessarily the same as the number of bytes used to store the string. If the value
is a byte array value (such as those returned from reading a binary encoded channel), is a byte array value (such as those returned from reading a binary encoded channel),
@ -8774,7 +8925,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::map @id -id ::tcl::string::map
@cmd -name "Built-in: tcl::string::map" -help\ @cmd -name "Built-in: tcl::string::map"\
-summary\
"Replace substrings based on mapping dict."\
-help\
"Replaces substrings in string based on the key-value pairs in ${$I}mapping${$NI}. ${$I}mapping${$NI} is a "Replaces substrings in string based on the key-value pairs in ${$I}mapping${$NI}. ${$I}mapping${$NI} is a
list of key value key value ... as in the form returned by ${$B}array get${$N}. Each instance list of key value key value ... as in the form returned by ${$B}array get${$N}. Each instance
of a key in the string will be replaced with its corresponding value. If ${$B}-nocase${$N} is of a key in the string will be replaced with its corresponding value. If ${$B}-nocase${$N} is
@ -8801,7 +8955,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::match @id -id ::tcl::string::match
@cmd -name "Built-in: tcl::string::match" -help\ @cmd -name "Built-in: tcl::string::match"\
-summary\
"Test if glob ${$I}pattern${$NI} matches string."\
-help\
{See if pattern matches string; return 1 if it does, 0 if it does not. If -nocase is {See if pattern matches string; return 1 if it does, 0 if it does not. If -nocase is
specified, then the pattern attempts to match against the string in a case insensitive specified, then the pattern attempts to match against the string in a case insensitive
manner. For the two strings to match, their contents must be identical except that the manner. For the two strings to match, their contents must be identical except that the
@ -8829,7 +8986,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::range @id -id ::tcl::string::range
@cmd -name "Built-in: tcl::string::range" -help\ @cmd -name "Built-in: tcl::string::range"\
-summary\
"Get characters from ${$I}first${$NI} to ${$I}last${$NI} index"\
-help\
"Returns a range of consecutive characters from ${$I}string${$NI}, starting with the character whose "Returns a range of consecutive characters from ${$I}string${$NI}, starting with the character whose
index is ${$I}first${$NI} and ending with the character whose index is ${$I}last${$NI} (using the forms described index is ${$I}first${$NI} and ending with the character whose index is ${$I}last${$NI} (using the forms described
in ${$B}STRING INDICES${$N}). An index of ${$B}0${$N} refers to the first character of the string; an index of in ${$B}STRING INDICES${$N}). An index of ${$B}0${$N} refers to the first character of the string; an index of
@ -8858,7 +9018,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::replace @id -id ::tcl::string::replace
@cmd -name "Built-in: tcl::string::replace" -help\ @cmd -name "Built-in: tcl::string::replace"\
-summary\
"Replace characters from ${$I}first${$NI} to ${$I}last${$NI} index"\
-help\
"Removes a range of consecutive characters from string, starting with the character whose "Removes a range of consecutive characters from string, starting with the character whose
index is first and ending with the character whose index is last index is first and ending with the character whose index is last
(Using the forms described in STRING_INDICES). An index of 0 refers to the first (Using the forms described in STRING_INDICES). An index of 0 refers to the first
@ -8878,7 +9041,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::reverse @id -id ::tcl::string::reverse
@cmd -name "Built-in: tcl::string::reverse" -help\ @cmd -name "Built-in: tcl::string::reverse"\
-summary\
"Reverse a string."\
-help\
"Returns a string that is the same length as ${$I}string${$NI} but with its "Returns a string that is the same length as ${$I}string${$NI} but with its
characters in reverse order." characters in reverse order."
@values -min 1 -max 1 @values -min 1 -max 1
@ -8887,7 +9053,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::tolower @id -id ::tcl::string::tolower
@cmd -name "Built-in: tcl::string::tolower" -help\ @cmd -name "Built-in: tcl::string::tolower"\
-summary\
"Convert to lowercase."\
-help\
"Returns a value equal to ${$I}string${$NI} except that all upper (or title) case case letters have "Returns a value equal to ${$I}string${$NI} except that all upper (or title) case case letters have
been converted to lower case. been converted to lower case.
${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES."
@ -8903,7 +9072,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::totitle @id -id ::tcl::string::totitle
@cmd -name "Built-in: tcl::string::totitle" -help\ @cmd -name "Built-in: tcl::string::totitle"\
-summary\
"Convert to titlecase"\
-help\
"Returns a value equal to string except that the first character in string is converted to "Returns a value equal to string except that the first character in string is converted to
its Unicode title case variant (or upper case if there is no title case variant) and the its Unicode title case variant (or upper case if there is no title case variant) and the
rest of the string is converted to lower case. rest of the string is converted to lower case.
@ -8921,7 +9093,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::toupper @id -id ::tcl::string::toupper
@cmd -name "Built-in: tcl::string::toupper" -help\ @cmd -name "Built-in: tcl::string::toupper"\
-summary\
"Convert to upper case."\
-help\
"Returns a value equal to ${$I}string${$NI} except that all lower (or title) case case letters have "Returns a value equal to ${$I}string${$NI} except that all lower (or title) case case letters have
been converted to upper case. been converted to upper case.
${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES."
@ -8937,7 +9112,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::trim @id -id ::tcl::string::trim
@cmd -name "Built-in: tcl::string::trim" -help\ @cmd -name "Built-in: tcl::string::trim"\
-summary\
"Remove leading/trailing whitespace or specified chars."\
-help\
{Returns a value equal to ${$I}string${$NI} except that any leading or trailing characters {Returns a value equal to ${$I}string${$NI} except that any leading or trailing characters
present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified
then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"}
@ -8947,7 +9125,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
} "@doc -name Manpage: -url [manpage_tcl string]" } "@doc -name Manpage: -url [manpage_tcl string]"
punk::args::define { punk::args::define {
@id -id ::tcl::string::trimleft @id -id ::tcl::string::trimleft
@cmd -name "Built-in: tcl::string::trimleft" -help\ @cmd -name "Built-in: tcl::string::trimleft"\
-summary\
"Remove leading whitespace or specified chars."\
-help\
{Returns a value equal to ${$I}string${$NI} except that any leading characters {Returns a value equal to ${$I}string${$NI} except that any leading characters
present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified
then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"}
@ -8957,7 +9138,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
} "@doc -name Manpage: -url [manpage_tcl string]" } "@doc -name Manpage: -url [manpage_tcl string]"
punk::args::define { punk::args::define {
@id -id ::tcl::string::trimright @id -id ::tcl::string::trimright
@cmd -name "Built-in: tcl::string::trimright" -help\ @cmd -name "Built-in: tcl::string::trimright"\
-summary\
"Remove trailing whitespace or specified chars."\
-help\
{Returns a value equal to ${$I}string${$NI} except that any trailing characters {Returns a value equal to ${$I}string${$NI} except that any trailing characters
present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified
then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"}
@ -8969,7 +9153,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::wordend @id -id ::tcl::string::wordend
@cmd -name "Built-in: tcl::string::wordend" -help\ @cmd -name "Built-in: tcl::string::wordend"\
-summary\
"Get index of char after end of word at charIndex"\
-help\
"Returns the index of the character just after the last one in the word containing "Returns the index of the character just after the last one in the word containing
character ${$I}charIndex${$NI} of ${$I}string${$NI}. character ${$I}charIndex${$NI} of ${$I}string${$NI}.
A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits)
@ -8985,7 +9172,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define { punk::args::define {
@id -id ::tcl::string::wordstart @id -id ::tcl::string::wordstart
@cmd -name "Built-in: tcl::string::wordstart" -help\ @cmd -name "Built-in: tcl::string::wordstart"\
-summary\
"Get index of first char of word at charIndex."\
-help\
"Returns the index of the first character in the word containing "Returns the index of the first character in the word containing
character ${$I}charIndex${$NI} of ${$I}string${$NI}. character ${$I}charIndex${$NI} of ${$I}string${$NI}.
A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits)
@ -9014,7 +9204,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
punk::args::define [punk::args::lib::tstr -return string { punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is @id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is" -help\ @cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0. "Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
" "
@leaders -min 1 -max 1 @leaders -min 1 -max 1
@ -9836,7 +10029,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
CommandPrefix executes in the same context as the code that invoked CommandPrefix executes in the same context as the code that invoked
the traced operation: thus the commandPrefix, if invoked from a the traced operation: thus the commandPrefix, if invoked from a
procedure, will have access to the same local variables as code in the procedure, will have access to the same local variables as code in the
procedure. This context may be different thatn the context in which procedure. This context may be different than the context in which
the trace was created. If commandPrefix invokes a procedure (which the trace was created. If commandPrefix invokes a procedure (which
it normally does) then the procedure will have to use upvar or uplevel it normally does) then the procedure will have to use upvar or uplevel
commands if it wishes to access the local variables of the code which commands if it wishes to access the local variables of the code which
@ -10411,6 +10604,161 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
namespace eval argdoc { namespace eval argdoc {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::unload
@cmd -name "Built-in: unload"\
-summary\
{Unload machine code.}\
-help\
{This command tries to unload shared libraries previously loaded with ${$B}load${$N} from the
application's address space.
${$I}fileName${$NI} is the name of the file containing the library
file to be unloaded; it must be the same as the filename provided to ${$B}load${$N} for loading
the library.
The ${$I}prefix${$NI} argument is the prefix (as determined by or passed to ${$B}load${$N}),
and is used to compute the name of the unload procedure; if not supplied, it is
computed from fileName in the same manner as ${$B}load${$N}.
The ${$I}interp${$NI} argument is the path
name of the interpreter from which to unload the package (see the interp manual entry
for details); if interp is omitted, it defaults to the interpreter in which the
unload command was invoked.
If the initial arguments to ${$B}unload${$N} start with - then they are treated as switches.
${$T}UNLOAD OPERATION${$NT}
When a file containing a shared library is loaded through the ${$B}load${$N} command, Tcl
associates two reference counts to the library file. The first counter shows how many
times the library has been loaded into normal (trusted) interpreters while the second
describes how many times the library has been loaded into safe interpreters. As a file
containing a shared library can be loaded only once by Tcl (with the first ${$B}load${$N} call
on the file), these counters track how many interpreters use the library. Each
subsequent call to ${$B}load${$N} after the first simply increments the proper reference count.
${$B}unload${$N} works in the opposite direction. As a first step, ${$B}unload${$N} will check whether the
library is unloadable: an unloadable library exports a special unload procedure. The
name of the unload procedure is determined by ${$I}prefix${$NI} and whether or not the target
interpreter is a safe one. For normal interpreters the name of the initialization
procedure will have the form pfx_Unload, where pfx is the same as ${$I}prefix${$NI} except that
the first letter is converted to upper case and all other letters are converted to
lower case. For example, if ${$I}prefix${$NI} is foo or FOo, the initialization procedure's name
will be Foo_Unload. If the target interpreter is a safe interpreter, then the name of
the initialization procedure will be pkg_SafeUnload instead of pkg_Unload.
If ${$B}unload${$N} determines that a library is not unloadable (or unload functionality has
been disabled during compilation), an error will be returned. If the library is
unloadable, then unload will call the unload procedure. If the unload procedure
returns TCL_OK, unload will proceed and decrease the proper reference count
(depending on the target interpreter type). When both reference counts have reached 0,
the library will be detached from the process.
${$T}UNLOAD HOOK PROTOTYPE${$NT}
The unload procedure must match the following prototype:
${[example {
typedef int ${$B}Tcl_LibraryUnloadProc${$N}(
Tcl_Interp *interp,
int flags);
}]}
The ${$I}interp${$NI} argument identifies the interpreter from which the library is to be unloaded.
The unload procedure must return ${$B}TCL_OK${$N} or ${$B}TCL_ERROR${$N} to indicate whether or not it
completed successfully; in the event of an error it should set the interpreter's result
to point to an error message. In this case, the result of the ${$B}unload${$N} command will be the
result returned by the unload procedure.
The ${$I}flags${$NI} argument can be either ${$B}TCL_UNLOAD_DETACH_FROM_INTERPRETER${$N} or
${$B}TCL_UNLOAD_DETACH_FROM_PROCESS${$N}. In case the library will remain attached to the process
after the unload procedure returns (i.e. because the library is used by other
interpreters), ${$B}TCL_UNLOAD_DETACH_FROM_INTERPRETER${$N} will be defined. However, if the library
is used only by the target interpreter and the library will be detached from the
application as soon as the unload procedure returns, the flags argument will be set to
${$B}TCL_UNLOAD_DETACH_FROM_PROCESS${$N}.
${$T}NOTES${$NT}
The ${$B}unload${$N} command cannot unload libraries that are statically linked with the application.
If fileName is an empty string, then the ${$I}prefix${$NI} argument must be specified.
If ${$I}prefix${$NI} is omitted or specified as an empty string, Tcl tries to guess the prefix. This
may be done differently on different platforms. The default guess, which is used on most
UNIX platforms, is to take the last element of fileName, strip off the first three
characters if they are lib, then strip off the next three characters if they are tcl9, and
use any following wordchars but not digits, converted to titlecase as the prefix. For
example, the command ${$B}unload${$N} libxyz4.2.so uses the prefix Xyz and the command ${$B}unload${$N}
bin/last.so {} uses the prefix Last.
${$T}PORTABILITY ISSUES${$NT}
Unix
Not all unix operating systems support library unloading. Under such an operating
system unload returns an error (unless -nocomplain has been specified).
${$T}BUGS${$NT}
If the same file is loaded by different fileNames, it will be loaded into the process's
address space multiple times. The behavior of this varies from system to system (some
systems may detect the redundant loads, others may not). In case a library has been
silently detached by the operating system (and as a result Tcl thinks the library is
still loaded), it may be dangerous to use ${$B}unload${$N} on such a library (as the library will be
completely detached from the application while some interpreters will continue to use it).
}
@form -form {basic prefix prefix_interp}
@leaders -min 0 -max 0
@opts
-nocomplain -type none -help\
{Suppresses all error messages. If this switch is given,
unload will never report an error.}
-keeplibrary -type none -help\
{This switch will prevent unload from issuing the
operating system call that will unload the library
from the process.}
-- -type none -help\
{Marks the end of switches. The argument following this
one will be treated as a fileName even if it starts
with a -.}
@values
fileName -type string -help\
{The name of the file containing the library
file to be unloaded; it must be the same as the filename
provided to ${$B}load${$N} for loading the library.}
@form -form {prefix prefix_interp}
prefix -type string -help\
{The prefix (as determined by or passed to ${$B}load${$N}). It is used
to compute the name of the unload procedure; if not supplied,
it is computed from ${$I}fileName${$NI} in the same manner as ${$B}load${$N}.}
@form -form prefix_interp
interp -type string -help\
{The path name of the interpreter from which to unload the
package (see the ${$B}interp${$N} manual entry for details); if ${$I}interp${$NI}
is omitted, it defaults to the interpreter in which the ${$B}unload${$N}
command was invoked.}
} "@doc -name Manpage: -url [manpage_tcl unload]"\
{
@examples -help {
If an unloadable module in the file ${$B}foobar.dll${$N} had been loaded using the ${$B}load${$N} command like this (on Windows):
${[example {
load c:/some/dir/foobar.dll
}]}
then it would be unloaded like this:
${[example {
${$B}unload${$N} c:/some/dir/foobar.dll
}]}
This allows a C code module to be installed temporarily into a long-running Tcl program and then removed again
(either because it is no longer needed or because it is being updated with a new version) without having to
shut down the overall Tcl process.
}
}\
{
@seealso -commands {"info sharedlibextension" load safe::*}
}
]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::unset @id -id ::unset
@cmd -name "Built-in: unset"\ @cmd -name "Built-in: unset"\
@ -10569,7 +10917,32 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
level -type int|stringstartswith(#) -optional 1 -default 1 level -type int|stringstartswith(#) -optional 1 -default 1
@values -min 1 -max -1 @values -min 1 -max -1
arg -type string -optional 0 -multiple 1 arg -type string -optional 0 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl uplevel]" ] } "@doc -name Manpage: -url [manpage_tcl uplevel]"\
{
@examples -help {
As stated in the description, the ${$B}uplevel${$N} command is useful for creating new control constructs.
This example shows how (without error handling) it can be used to create a ${$B}do${$N} command that is the
counterpart of ${$B}while${$N} except for always performing the test after running the loop body:
${[example {
proc do {body while condition} {
if {$while ne "while"} {
error "required word missing"
}
set conditionCmd [list expr $condition]
while {1} {
${$B}uplevel${$N} 1 $body
if {![${$B}uplevel${$N} 1 $conditionCmd]} {
break
}
}
}
}]}
}
}\
{
@seealso -commands {apply namespace upvar}
}
]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -10617,7 +10990,29 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
If an upvar variable is unset (e.g. ${$B}x${$N} in ${$B}add2${$N} above), the ${$B}unset${$N} operation affects If an upvar variable is unset (e.g. ${$B}x${$N} in ${$B}add2${$N} above), the ${$B}unset${$N} operation affects
the variable it is linked to, not the upvar variable. There is no way to unset an the variable it is linked to, not the upvar variable. There is no way to unset an
upvar variable except by exiting the procedure in which it is defined. However, it upvar variable except by exiting the procedure in which it is defined. However, it
is possible to retarget an upvar variable by executing another ${$B}upvar${$N} command.} is possible to retarget an upvar variable by executing another ${$B}upvar${$N} command.
${$T}TRACES AND UPVAR${$NT}
Upvar interacts with traces in a straightforward but possibly unexpected manner. If a variable
trace is defined on otherVar, that trace will be triggered by actions involving myVar. However,
the trace procedure will be passed the name of myVar, rather than the name of otherVar. Thus,
the output of the following code will be “localVar” rather than “originalVar”:
${[example {
proc traceproc { name index op } {
puts $name
}
proc setByUpvar { name value } {
${$B}upvar${$N} $name localVar
set localVar $value
}
set originalVar 1
trace add variable originalVar write traceproc
setByUpvar originalVar 2
}]}
If ${$I}otherVar${$NI} refers to an element of an array, then the element name is passed as the second
argument to the trace procedure. This may be important information in case of traces set on
an entire array.
}
@leaders -min 0 -max 1 -takewhenargsmodulo 2 @leaders -min 0 -max 1 -takewhenargsmodulo 2
#consider -takewhenargsmodulo 2 ?? incompatible with various mixed @opts/@values configurations #consider -takewhenargsmodulo 2 ?? incompatible with various mixed @opts/@values configurations
#level -type int|stringstartswith(#) -optional 1 -default 1 #level -type int|stringstartswith(#) -optional 1 -default 1
@ -10632,7 +11027,22 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
level -type int|stringstartswith(#) -optional 1 -default 1 level -type int|stringstartswith(#) -optional 1 -default 1
@values -min 2 -max -1 @values -min 2 -max -1
varmapping -type {string string} -typesynopsis {${$I}otherVar${$NI} ${$I}myVar${$NI}} -optional 0 -multiple 1 varmapping -type {string string} -typesynopsis {${$I}otherVar${$NI} ${$I}myVar${$NI}} -optional 0 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl upvar]" ] } "@doc -name Manpage: -url [manpage_tcl upvar]"\
{
@examples -help {
A ${$B}decr${$N} command that works like ${$B}incr${$N} except it subtracts the value from the variable instead of adding it:
${[example {
proc decr {varName {decrement 1}} {
${$B}upvar${$N} 1 $varName var
incr var [expr {-$decrement}]
}
}]}
}
}\
{
@seealso -commands {global namespace uplevel variable}
}
]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -10702,7 +11112,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
#define subcommand documentation first #define subcommand documentation first
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define { punk::args::define {
@dynamic
@id -id "::zlib adler32" @id -id "::zlib adler32"
@cmd -name "Built-in: ::zlib adler32"\ @cmd -name "Built-in: ::zlib adler32"\
-summary\ -summary\
@ -10718,7 +11127,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define { punk::args::define {
@dynamic
@id -id "::zlib crc32" @id -id "::zlib crc32"
@cmd -name Built-in: ::zlib crc32"\ @cmd -name Built-in: ::zlib crc32"\
-summary\ -summary\
@ -10734,7 +11142,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define { punk::args::define {
@dynamic
@id -id "::zlib compress" @id -id "::zlib compress"
@cmd -name "Built-in: ::zlib compress"\ @cmd -name "Built-in: ::zlib compress"\
-summary\ -summary\
@ -10749,7 +11156,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
} "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define { punk::args::define {
@dynamic
@id -id "::zlib decompress" @id -id "::zlib decompress"
@cmd -name "Built-in: ::zlib decompress"\ @cmd -name "Built-in: ::zlib decompress"\
-summary\ -summary\

6
src/modules/punk/console-999999.0a1.0.tm

@ -118,7 +118,7 @@ namespace eval punk::console {
#punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace
#directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. #directly acting means they write to stdout to cause the console to perform the action, or they perform the action immediately via other means.
#punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence. #punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence.
#punk::console::local functions are used by punk::console commands when there is no ansi equivalent #punk::console::local functions are used by punk::console commands when there is no ansi equivalent
#ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console #ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console
@ -602,7 +602,9 @@ namespace eval punk::console {
} }
namespace eval internal { namespace eval internal {
proc abort_if_loop {{failmsg ""}} { proc abort_if_loop {{failmsg ""}} {
#obsolete
#puts "il1 [info level 1]" #puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]" #puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}] set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
@ -1081,7 +1083,7 @@ namespace eval punk::console {
#e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first
#punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ #punk::args::set_idalias ::punk::console::code_a+ ::punk::ansi::a+
lappend PUNKARGS_aliases {::punk::console::code_a+ ::punk::ansi::a+} lappend PUNKARGS_aliases {::punk::console::code_a+ ::punk::ansi::a+}
proc code_a+ {args} { proc code_a+ {args} {
variable ansi_wanted variable ansi_wanted

9
src/modules/punk/fileline-999999.0a1.0.tm

@ -1279,7 +1279,7 @@ namespace eval punk::fileline {
#[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data.
#[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes.
lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values lassign [dict values [punk::args::parse $args withid ::punk::fileline::get_textinfo]] leaders opts values
# -- --- --- --- # -- --- --- ---
set opt_file [dict get $opts -file] set opt_file [dict get $opts -file]
set opt_translation [dict get $opts -translation] set opt_translation [dict get $opts -translation]
@ -1290,8 +1290,11 @@ namespace eval punk::fileline {
if {$opt_file ne ""} { if {$opt_file ne ""} {
set filename $opt_file set filename $opt_file
set fd [open $filename r] set fd [open $filename r]
chan configure $fd -translation binary -encoding $opt_translation;#should use translation binary to get actual line-endings - but we allow caller to override chan configure $fd -translation binary -encoding $opt_translation;#should use translation binary to get actual line-endings - but we allow caller to override
#Always read encoding in binary - check for bom below and/or apply chosen opt_encoding #Always read encoding in binary - check for bom below and/or apply chosen opt_encoding
set rawchunk [read $fd] set rawchunk [read $fd]
close $fd close $fd
if {[llength $values]} { if {[llength $values]} {
@ -1359,12 +1362,12 @@ namespace eval punk::fileline {
set startdata 3 set startdata 3
} elseif {$maybe_bom eq "fbee28"} { } elseif {$maybe_bom eq "fbee28"} {
set bomid bocu-1 set bomid bocu-1
puts stderr "WARNING - bocu-1 BOM FBEE28 found. Not supported - back to binary" puts stderr "WARNING - bocu-1 BOM FBEE28 found. Not supported - Falling back to binary"
set bomenc "binary" ;# utf-8??? set bomenc "binary" ;# utf-8???
set startdata 3 set startdata 3
} elseif {$maybe_bom eq "84319533"} { } elseif {$maybe_bom eq "84319533"} {
if {![dict exists [punk::char::page_names_dict gb18030] gb18030]} { if {![dict exists [punk::char::page_names_dict gb18030] gb18030]} {
puts stderr "WARNING - no direct support for GB18030 (chinese) - falling back to cp936/gbk" puts stderr "WARNING - no direct support for GB18030 (chinese) - Falling back to cp936/gbk"
set bomenc cp936 set bomenc cp936
} else { } else {
set bomenc [dict get [punk::char::page_names_dict gb18030]] ;#review - this may never exist in Tcl or may be named differently - create a handler? set bomenc [dict get [punk::char::page_names_dict gb18030]] ;#review - this may never exist in Tcl or may be named differently - create a handler?

2
src/modules/punk/fileline-buildversion.txt

@ -1,3 +1,3 @@
0.1.0 0.1.1
#First line must be a semantic version number #First line must be a semantic version number
#all other lines are ignored. #all other lines are ignored.

617
src/modules/punk/lib-999999.0a1.0.tm

@ -69,6 +69,16 @@ package require punk::args
tcl::namespace::eval punk::lib::ensemble { tcl::namespace::eval punk::lib::ensemble {
#wiki.tcl-lang.org/page/ensemble+extend #wiki.tcl-lang.org/page/ensemble+extend
# extend an ensemble-like routine with the routines in some namespace # extend an ensemble-like routine with the routines in some namespace
#NOTE - the extension ns becomes the '-namespace <extension_ns>' for the original routine name,
#with -unknown handling the original subcommands.
#This makes the original ensemble harder to introspect!
#e.g (the original -map or -namespace not visible)
#In this specific case (which, being published on the wiki might be common in the wild)
#we could call {*}[namespace ensemble configure $routine -unknown] $routine <bogussubcommand>
#and then detect that the first resulting word is an ensemble
#For arbitrary '-unknown scripts' - sensible introspection is likely not possible
proc extend {routine extension} { proc extend {routine extension} {
if {![string match ::* $routine]} { if {![string match ::* $routine]} {
set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] set resolved [uplevel 1 [list ::tcl::namespace::which $routine]]
@ -119,6 +129,17 @@ tcl::namespace::eval punk::lib::ensemble {
# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated # some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated
tcl::namespace::eval punk::lib::check { tcl::namespace::eval punk::lib::check {
#These are just a selection of bugs relevant to punk behaviour (or of specific interest to the author)
#Not any sort of comprehensive check of known tcl bugs.
#These are reported in warning output of 'help tcl' - or used for workarounds in some cases.
proc has_tclbug_regexp_emptystring {} {
#The regexp {} [...] trick - code in brackets only runs when non byte-compiled ie in traces
#This was usable as a hack to create low-impact calls that only ran in an execution trace context - handy for debugger logic,
#but as an apparent violation of Tcl's normal parsing rules - was evidently seen as a bug and fixed in:
#https://core.tcl-lang.org/tcl/info/cb03e57a (tcl 9.0.3+ ?)
set bug [expr {![catch {regexp {} [error should_error]}]}]
return [dict create bug $bug bugref cb03e57a description {regexp emptystring first argument over-optimised - difference in compiled vs traced behaviour.} level minor]
}
proc has_tclbug_script_var {} { proc has_tclbug_script_var {} {
set script {set j [list spud] ; list} set script {set j [list spud] ; list}
@ -134,30 +155,38 @@ tcl::namespace::eval punk::lib::check {
#we assume it should have no string rep in either case #we assume it should have no string rep in either case
#Review: check Tcl versions for behaviour/consistency #Review: check Tcl versions for behaviour/consistency
if {!$nostring2} { if {!$nostring2} {
return true set bug true
} else { } else {
return false set bug false
} }
set description "string rep for list variable in script generated when script changed\n(not an acknowledged/reported bug)"
return [dict create bug $bug bugref "" description $description level minor]
} }
proc has_tclbug_lsearch_strideallinline {} { proc has_tclbug_lsearch_strideallinline {} {
#bug only occurs with single -index value combined with -stride -all -inline -subindices #bug only occurs with single -index value combined with -stride -all -inline -subindices
#https://core.tcl-lang.org/tcl/tktview/5a1aaa201d #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d
if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} {
#we aren't looking for an error result - error most likely indicates tcl too old to support -stride #we aren't looking for an error result - error most likely indicates tcl too old to support -stride
return 0 set bug 0
} else {
set bug [expr {$result ne "a2"}]
} }
return [expr {$result ne "a2"}] set description "lsearch -stride with -subindices -inline -all and single index - incorrect results."
return [dict create bug $bug bugref 5a1aaa201d description $description level major]
} }
proc has_tclbug_list_quoting_emptyjoin {} { proc has_tclbug_list_quoting_emptyjoin {} {
#https://core.tcl-lang.org/tcl/tktview/e38dce74e2 #https://core.tcl-lang.org/tcl/tktview/e38dce74e2
set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases
set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}"
return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. set bug [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug.
set description "lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)"
return [dict create bug $bug bugref e38dc74e2 description $description level medium]
} }
proc has_tclbug_safeinterp_compile {{show 0}} { proc has_tclbug_safeinterp_compile {{show 0}} {
#ensemble calls within safe interp not compiled #ensemble calls within safe interp not compiled
#https://core.tcl-lang.org/tcl/tktview/1095bf7f756f9aed6bde
namespace eval [namespace current]::testcompile { namespace eval [namespace current]::testcompile {
proc ensembletest {} {string index a 0} proc ensembletest {} {string index a 0}
} }
@ -199,7 +228,8 @@ tcl::namespace::eval punk::lib::check {
if {[string last "invokeStk" $bytecode_outer] >= 1} { if {[string last "invokeStk" $bytecode_outer] >= 1} {
incr has_bug incr has_bug
} }
return $has_bug set description "ensemble commands not compiled in safe interps - heavy performance impact in safe interps"
return [dict create bug $has_bug bugref 1095bf7f756f9aed6bde description $description level major]
} }
} }
@ -301,7 +331,7 @@ tcl::namespace::eval punk::lib::compat {
if {"::lpop" ne [info commands ::lpop]} { if {"::lpop" ne [info commands ::lpop]} {
#puts stderr "Warning - no built-in lpop" #puts stderr "Warning - no built-in lpop"
interp alias {} lpop {} ::punk::lib::compat::lpop interp alias {} lpop {} ::punk::lib::compat::lpop
punk::args::set_alias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore punk::args::set_idalias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore
} }
proc lpop {lvar args} { proc lpop {lvar args} {
#*** !doctools #*** !doctools
@ -342,19 +372,19 @@ tcl::namespace::eval punk::lib::compat {
} }
if {"::ledit" ni [info commands ::ledit]} { if {"::ledit" ni [info commands ::ledit]} {
interp alias {} ledit {} ::punk::lib::compat::ledit interp alias {} ledit {} ::punk::lib::compat::ledit
punk::args::set_alias ::punk::lib::compat::ledit ::ledit punk::args::set_idalias ::punk::lib::compat::ledit ::ledit
} }
proc ledit {lvar first last args} { proc ledit {lvar first last args} {
upvar $lvar l upvar $lvar l
#use lindex_resolve to support for example: ledit lst end+1 end+1 h i #use lindex_resolve to support for example: ledit lst end+1 end+1 h i
set fidx [punk::lib::lindex_resolve [llength $l] $first] set fidx [punk::lib::lindex_resolve [llength $l] $first]
switch -exact -- $fidx { switch -exact -- $fidx {
-3 { -Inf {
#index below lower bound #index below lower bound
set pre [list] set pre [list]
set fidx -1 set fidx -1
} }
-2 { Inf {
#first index position is greater than index of last element in the list #first index position is greater than index of last element in the list
set pre [lrange $l 0 end] set pre [lrange $l 0 end]
set fidx [llength $l] set fidx [llength $l]
@ -366,11 +396,11 @@ tcl::namespace::eval punk::lib::compat {
} }
set lidx [punk::lib::lindex_resolve [llength $l] $last] set lidx [punk::lib::lindex_resolve [llength $l] $last]
switch -exact -- $lidx { switch -exact -- $lidx {
-3 { -Inf {
#index below lower bound #index below lower bound
set post [lrange $l 0 end] set post [lrange $l 0 end]
} }
-2 { Inf {
#index above upper bound #index above upper bound
set post [list] set post [list]
} }
@ -396,8 +426,8 @@ tcl::namespace::eval punk::lib::compat {
foreach v $varnames { foreach v $varnames {
lappend values "\$$v" lappend values "\$$v"
} }
set linkvars [uplevel 1 [list info vars]] set linkvars [uplevel 1 [list ::tcl::info::vars]]
set nscaller [uplevel 1 [list namespace current]] set nscaller [uplevel 1 [list ::tcl::namespace::current]]
set apply_script "" set apply_script ""
foreach vname $linkvars { foreach vname $linkvars {
@ -499,6 +529,15 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
namespace eval argdoc {
#non-colour SGR codes
set I "\x1b\[3m" ;# [a+ italic]
set NI "\x1b\[23m" ;# [a+ noitalic]
set B "\x1b\[1m" ;# [a+ bold]
set N "\x1b\[22m" ;# [a+ normal]
set T "\x1b\[1\;4m" ;# [a+ bold underline]
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline]
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
@ -673,31 +712,31 @@ namespace eval punk::lib {
upvar $lvar l upvar $lvar l
set len [llength $l] set len [llength $l]
if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} { if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} {
#lindex_resolve_basic returns only -1 if out of range #lindex_resolve_basic returns only -Inf if out of range at either bound
#if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list) #(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
#use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) #use full 'lindex_resolve' which can report which side via -Inf and Inf special results being lower and upper bound breaches respectively
set a_index [lindex_resolve $len $a] set a_index [lindex_resolve $len $a]
set a_msg "" set a_msg ""
switch -- $a_index { switch -- $a_index {
-2 { -Inf {
set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])"
}
-3 {
set a_msg "1st supplied index $a is below the lower bound for the list (0)" set a_msg "1st supplied index $a is below the lower bound for the list (0)"
} }
Inf {
set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])"
}
} }
set z_index [lindex_resolve $len $z] set z_index [lindex_resolve $len $z]
set z_msg "" set z_msg ""
switch -- $z_index { switch -- $z_index {
-2 { -Inf {
set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])"
}
-3 {
set z_msg "2nd supplied index $z is below the lower bound for the list (0)" set z_msg "2nd supplied index $z is below the lower bound for the list (0)"
} }
Inf {
set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])"
}
} }
set errmsg "lswap cannot swap indices $a and $z" set errmsg "lswap cannot swap indices $a and $z"
if {$a_msg ne ""} { if {$a_msg ne ""} {
@ -981,7 +1020,7 @@ namespace eval punk::lib {
return $zip_l return $zip_l
} }
#keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible
if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} {
#-stride either not available - or has bug preventing use of main algorithm below #-stride either not available - or has bug preventing use of main algorithm below
proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] proc lzipn {args} [info body ::punk::lib::lzipn_tcl8]
} else { } else {
@ -991,6 +1030,240 @@ namespace eval punk::lib {
namespace import ::punk::args::lib::tstr namespace import ::punk::args::lib::tstr
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::tclscript_to_scriptlist
@cmd -name punk::lib::tclscript_to_scriptlist\
-summary\
"Parse tcl script to toplevel list of lists."\
-help\
"Get topmost list of tcl language elements in script.
produces a list of lists where each sublist is a commandlist or
a comment string."
@values -min 1 -max 1
script -type string
}]
}
proc tclscript_to_scriptlist {script} {
set scriptlist [list]
set cmdlist [list]
set scrlen [string length $script]
set token ""
set in_token 0
set in_cmdlist 0
set in_comment 0
set charmap [list \t TB \n LF \r CR \\ BSL] ;#for switch 'jump' preservation - review - may be slower than escapes in switch statement?
for {set i 0} {$i < $scrlen} {incr i} {
set ch [string index $script $i]
set chswitch [string map $charmap $ch]
if {!$in_token} {
switch -- $chswitch {
{ } - TB {
#ignore - continue being a non token
}
CR {
if {[string index $script $i+1] eq "\n"} {
if {$in_cmdlist} {
#no active token - newline ends cmdlist
set in_cmdlist 0
lappend scriptlist $cmdlist
set cmdlist [list]
}
incr i
}
}
LF - ";" {
#no active token - newline or semicolon ends cmdlist
if {$in_cmdlist} {
set in_cmdlist 0
lappend scriptlist $cmdlist
set cmdlist [list]
}
}
BSL {
if {[string index $script $i+1] eq "\n"} {
#continuation of whitespace while no token - boring
incr i
} elseif {[string range $script $i+1 $i+2] eq "\r\n"} {
#continuation of whitespace while no token - boring
incr i 2
} else {
#an uncommon possibility, a command wth surrounding spaces called in an strange way
# e.g \ cmdname\ arg
set in_token 1
set token "\\[string index $script $i+1]"
incr i
if {!$in_cmdlist} {
set in_cmdlist 1
}
}
}
# {
if {$in_cmdlist} {
#ordinary data
set in_token 1
set token #
} else {
if {!$in_comment} {
set in_token 1
set in_comment 1
set token #
} else {
#wnen in comment - all will be a single token until comment ends
append token #
}
}
}
default {
#for completeness.. we should exclude other possible whitespace chars
if {![string is space $ch]} {
set in_token 1
set token $ch
if {!$in_cmdlist} {
set in_cmdlist 1
}
}
}
}
} else {
#if we're in a token, we must be in a cmdlist or a comment (single token)
#review - not preserving whitespace in list of commands is ok, but for comments it should ideally be preserved
#note that unbalanced curly in *toplevel* comment will still 'info complete' to true
switch -- $chswitch {
LF {
if {!$in_comment} {
if {[tcl::info::complete $token]} {
#ends token and cmdlist
lappend cmdlist $token
lappend scriptlist $cmdlist
set cmdlist ""
set in_cmdlist 0
set token ""
set in_token 0
} else {
append token \n
}
} else {
#ends a comment
lappend scriptlist $token ;#single token for comment
set token ""
set in_token 0
set in_comment 0
set in_cmdlist 0 ;#shouldn't be necessary, but included for clarity
}
}
";" {
if {!$in_comment} {
if {[tcl::info::complete $token]} {
#ends token and cmdlist
lappend cmdlist $token
lappend scriptlist $cmdlist
set cmdlist ""
set in_cmdlist 0
set token ""
set in_token 0
} else {
append token \n
}
} else {
#ordinary char for comment
append token ";"
}
}
CR {
if {[string index $script $i+1] eq "\n"} {
if {[tcl::info::complete $token]} {
#ends token and commandlist
lappend cmdlist $token
lappend scriptlist $cmdlist
set cmdlist ""
set in_cmdlist 0
set token ""
set in_token 0
} else {
append token \r\n
incr i
}
} else {
append token \r
}
}
BSL {
if {[string index $script $i+1] eq "\n"} {
#continuation - lf effectively becomes a space
if {!$in_comment} {
#token may end - but cmdlist goes on
if {[tcl::info::complete $token]} {
lappend cmdlist $token
set token ""
set in_token 0
} else {
append token " "
}
} else {
append token " "
}
incr i ;#skip LF
} elseif {[string range $script $i+1 $i+2] eq "\r\n"} {
#continuation - cr-lf effectively becomes a space
if {!$in_comment} {
#token may end - but cmdlist goes on
if {[tcl::info::complete $token]} {
lappend cmdlist $token
set token ""
set in_token 0
} else {
append token " "
}
} else {
append token " "
}
incr i 2 ;#skip CRLF
} else {
append token "\\[string index $script $i+1]"
incr i
}
}
default {
if {![string is space $ch]} {
append token $ch
} else {
if {!$in_comment} {
if {[tcl::info::complete $token]} {
lappend cmdlist $token
set token ""
set in_token 0
} else {
append token $ch
}
} else {
append token $ch
}
}
}
}
}
}
#eof
if {!$in_comment} {
if {$in_token} {
if {[tcl::info::complete $token]} {
lappend cmdlist $token
lappend scriptlist $cmdlist
} else {
error "Eof reached whilst script incomplete. Unbalanced braces?\ntoken: '$token'"
}
} else {
if {$in_cmdlist} {
lappend scriptlist $cmdlist
}
}
} else {
lappend scriptlist $token
}
return $scriptlist
}
proc invoke command { proc invoke command {
@ -1064,6 +1337,7 @@ namespace eval punk::lib {
Segments are classified into list,dict and string operations. Segments are classified into list,dict and string operations.
Leading % indicates a string operation - e.g %# gives string length Leading % indicates a string operation - e.g %# gives string length
A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3
(todo - change to indexset syntax @1..3 @1..end-1 etc)
A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1'
The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one.
e.g1 pdict env */%# e.g1 pdict env */%#
@ -1087,9 +1361,9 @@ namespace eval punk::lib {
set opts [dict get $argd opts] set opts [dict get $argd opts]
set dvar [dict get $argd values dictvar] set dvar [dict get $argd values dictvar]
set patterns [dict get $argd values patterns] set patterns [dict get $argd values patterns]
set isarray [uplevel 1 [list array exists $dvar]] set isarray [uplevel 1 [list ::tcl::array::exists $dvar]]
if {$isarray} { if {$isarray} {
set dvalue [uplevel 1 [list array get $dvar]] set dvalue [uplevel 1 [list ::tcl::array::get $dvar]]
if {![dict exists $opts -keytemplates]} { if {![dict exists $opts -keytemplates]} {
set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}]
dict set opts -keytemplates [list $arrdisplay] dict set opts -keytemplates [list $arrdisplay]
@ -1231,6 +1505,9 @@ namespace eval punk::lib {
if {$opt_roottype in {dict list string}} { if {$opt_roottype in {dict list string}} {
#puts "getting keys for roottype:$opt_roottype" #puts "getting keys for roottype:$opt_roottype"
if {[llength $dval]} { if {[llength $dval]} {
#TODO - change to indexset notation 0..1,3..end-1 etc
set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$}
set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$}
foreach pattern_nest $patterns { foreach pattern_nest $patterns {
@ -1445,30 +1722,33 @@ namespace eval punk::lib {
if {![regexp $re_idxdashidx $p _match a b]} { if {![regexp $re_idxdashidx $p _match a b]} {
error "unrecognised pattern $p" error "unrecognised pattern $p"
} }
set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high #TODO - fix terminology. 'lower_resolve' is confusing here as range can be in descending order
#change to start/end terminology?
set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-Inf for too low, Inf for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -2} { if {${lower_resolve} == Inf} {
##x ##x
#lower bound is above upper list range #lower bound is above upper list range
#match with decreasing indices is still possible #match with decreasing indices is still possible
set lower [expr {[llength $dval]-1}] ;#set to max set lower [expr {[llength $dval]-1}] ;#set to max
} elseif {$lower_resolve == -3} { } elseif {$lower_resolve == -Inf} {
##x ##x
set lower 0 set lower 0
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve [llength $dval] $b] set upper [punk::lib::lindex_resolve [llength $dval] $b]
if {$upper == -3} { if {$upper == -Inf} {
##x ##x
#upper bound is below list range - #upper bound is below list range -
if {$lower_resolve >=-2} { if {$lower_resolve > -Inf} {
##x ##x
set upper 0 set upper 0
} else { } else {
continue continue
} }
} elseif {$upper == -2} { } elseif {$upper == Inf} {
#use max #use max
set upper [expr {[llength $dval]-1}] set upper [expr {[llength $dval]-1}]
#assert - upper >=0 because we have ruled out empty lists #assert - upper >=0 because we have ruled out empty lists
@ -2181,17 +2461,22 @@ namespace eval punk::lib {
"Validate that a string is an 'indexset' "Validate that a string is an 'indexset'
An indexset consists of a comma delimited list of indexes or index-ranges. An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based. No particular base is assumed for the purposes of validating an indexset here.
While in Tcl, lists are zero-based - an indexset can be applied to lists of any base.
e.g -10..-1 is an indexset that just won't resolve any results for a list with a base >= 0.
To validate if an indexset is strictly within range, both the length of the data and the base would
need to be considered.
The normal 'range' specifier is .. The normal 'range' specifier is ..
The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire
range of valid values. range of valid values.
e.g the following are all valid ranges e.g the following are all valid ranges
1.. 1..
(index 1 to max) (index 1 to 'max')
..10 ..10
(index 0 to 10) (index 'base' to 10)
2..11 2..11
(index 2o to 11) (index 2 to 11)
.. ..
(all indices) (all indices)
Common whitespace elements space,tab,newlines are ignored. Common whitespace elements space,tab,newlines are ignored.
@ -2199,7 +2484,7 @@ namespace eval punk::lib {
e.g end-2 or 2+2. e.g end-2 or 2+2.
see indexset_resolve" see indexset_resolve"
@values -min 2 -max 2 @values -min 1 -max 1
indexset -type string indexset -type string
} }
proc is_indexset {indexset} { proc is_indexset {indexset} {
@ -2252,29 +2537,69 @@ namespace eval punk::lib {
e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9
An indexset consists of a comma delimited list of indexes or index-ranges. An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based. Ranges must be specified with .. as the separator, with an empty value at either side of the
Ranges must be specified with .. as the separator. separator representing beginning and end of the index range respectively.
The indexes are 0-based by default, but the base can be specified.
indexset_resolve 7 ..
-> 0 1 2 3 4 5 6
indexset_resolve 7 .. -3
-> -3 -2 -1 0 1 2 3
Whitespace is ignored. Whitespace is ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2. e.g end-2 or 2+2.
end means the last item. end means the last item.
end-1 means the second last item. end-1 means the second last item.
0.. is the same as 0..end. 0.. is the same as 0..end
indexset examples: indexset examples:
These assume the default 0-based indices (base == 0)
1,3.. 1,3..
output the index 1 (2nd item) followed by all from index 3 to the end. output the index 1 (2nd item) followed by all from index 3 to the end.
'indexset_resolve 4 1,3..' -> 1 3 indexset_resolve 4 1,3..
'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9 -> 1 3
0-2,end indexset_resolve 10 1,3..
-> 1 3 4 5 6 7 8 9
0..2,end
output the first 3 indices, and the last index. output the first 3 indices, and the last index.
end-1..0 end-1..0
output the indexes in reverse order from 2nd last item to first item." output the indexes in reverse order from 2nd last item to first item."
@values -min 2 -max 2 @values -min 2 -max 3
numitems -type integer numitems -type integer
indexset -type indexset -help "comma delimited specification for indices to return" indexset -type indexset -help "comma delimited specification for indices to return"
base -type integer -default 0 -help\
"This is the starting index. It can be positive, negative or zero.
This affects the start and end calculations, limiting what indices will be
returned.
e.g with base 1 'end' will give a different value from base 0
for 10 items 'end' is 10 when 1-based
for 10 items 'end' is 9 when 0-based
For base 1, index 0 is considered to be below the range.
ie
indexset_resolve 10 0..3 1
-> 1 2 3
indexset_resolve 10 0..3 0
-> 0 1 2 3
It does not *convert* integers within the range.
indexset_resolve 10 5 1
-> 5
indexset_resolve 10 5 0
-> 5
ie if you ask for a 1 based indexset the integers that are within the
range will come out the same, so the result needs to be treated as a
1-based set of indices when performing further operations.
"
} }
proc indexset_resolve {numitems indexset} { proc indexset_resolve {numitems indexset {base 0}} {
if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { if {![string is integer -strict $numitems] || ![is_indexset $indexset]} {
#use parser on unhappy path only #use parser on unhappy path only
set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve]
@ -2283,7 +2608,8 @@ namespace eval punk::lib {
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace
set index_list [list] ;#list of actual indexes within the range set index_list [list] ;#list of actual indexes within the range
set iparts [split $indexset ,] set iparts [split $indexset ,]
set index_list [list] set based_max [expr {$numitems -1 + $base}]
foreach ipart $iparts { foreach ipart $iparts {
set ipart [string trim $ipart] set ipart [string trim $ipart]
set rposn [string first .. $ipart] set rposn [string first .. $ipart]
@ -2292,76 +2618,83 @@ namespace eval punk::lib {
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
set rawa [string trim $rawa] set rawa [string trim $rawa]
set rawb [string trim $rawb] set rawb [string trim $rawb]
if {$rawa eq ""} {set rawa 0} if {$rawa eq ""} {set rawa $base}
set a [punk::lib::lindex_resolve $numitems $rawa] set a [punk::lib::lindex_resolve $numitems $rawa $base]
if {$a == -3} { if {$a == -Inf} {
#(was -3)
#undershot - leave negative #undershot - leave negative
} elseif {$a == -2 && $rawa ne "-2"} { } elseif {$a == Inf} {
#overshot #overshot
set a [expr {$numitems}] ;#put it outside the range on the upper side set a [expr {$based_max + 1}] ;#put it outside the range on the upper side
} }
#review - a may be -Inf
if {$rawb eq ""} { if {$rawb eq ""} {
if {$a > $numitems-1} { if {$a > $based_max} {
set rawb $a ;#make sure <overshot>.. doesn't return last item - should return nothing set rawb $a ;#make sure <overshot>.. doesn't return last item - should return nothing
} else { } else {
set rawb end set rawb end
} }
} }
set b [punk::lib::lindex_resolve $numitems $rawb] set b [punk::lib::lindex_resolve $numitems $rawb $base]
if {$b == -3} { if {$b == -Inf} {
#undershot - leave negative #undershot - leave negative
} elseif {$b == -2 && $rawb ne "-2"} { } elseif {$b == Inf} {
set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side
set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side
} }
#JJJ
#e.g make sure <overshot>.. doesn't return last item - should return nothing as both are above the range. #e.g make sure <overshot>.. doesn't return last item - should return nothing as both are above the range.
if {$a >= 0 && $a <= $numitems-1 && $b >=0 && $b <= $numitems-1} { if {$a >= $base && $a <= $based_max && $b >=$base && $b <= $based_max} {
lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally.
} else { } else {
if {$a >= 0 && $a <= $numitems-1} { if {$a >= $base && $a <= $based_max} {
#only a is in the range #only a is in the range
if {$b < 0} { if {$b < $base} {
set b 0 set b $base
} else { } else {
set b [expr {$numitems-1}] set b $based_max
} }
lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally.
} elseif {$b >=0 && $b <= $numitems-1} { } elseif {$b >=$base && $b <= $based_max} {
#only b is in the range #only b is in the range
if {$a < 0} { if {$a < $base} {
set a 0 set a $base
} else { } else {
set a [expr {$numitems-1}] set a $based_max
} }
lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally.
} else { } else {
#both outside the range #both outside the range
if {$a < 0 && $b > 0} { if {$a < $base && $b > $base} {
#spans the range in forward order #spans the range in forward order
set a 0 set a $base
set b [expr {$numitems-1}] set b $based_max
lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally.
} elseif {$a > 0 && $b < 0} { } elseif {$a > $base && $b < $base} {
#spans the range in reverse order #spans the range in reverse order
set a [expr {$numitems-1}] set a $based_max
set b 0 set b $base
lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally.
} }
#both outside of range on same side #both outside of range on same side
} }
} }
} else { } else {
set idx [punk::lib::lindex_resolve_basic $numitems $ipart] set idx [punk::lib::lindex_resolve_basic $numitems $ipart $base]
if {$idx >= 0} { #returns only -Inf for out of range at either end
if {$idx >= $base} {
#index within the range
lappend index_list $idx lappend index_list $idx
} }
} }
} }
return $index_list return $index_list
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side # showdict uses lindex_resolve results -Inf & Inf to determine whether index is out of bounds on lower vs upper side
#REVIEW: This shouldn't really need the list itself - just the length would suffice #This doesn't need the list itself - just the length suffices.
punk::args::define { punk::args::define {
@id -id ::punk::lib::lindex_resolve @id -id ::punk::lib::lindex_resolve
@cmd -name punk::lib::lindex_resolve\ @cmd -name punk::lib::lindex_resolve\
@ -2379,9 +2712,9 @@ namespace eval punk::lib {
We want to resolve the index used, without passing arbitrary expressions into the 'expr' function We want to resolve the index used, without passing arbitrary expressions into the 'expr' function
- which could have security risks. - which could have security risks.
lindex_resolve will parse the index expression and return: lindex_resolve will parse the index expression and return:
a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) a) -Inf if the supplied index expression is below the lower bound for the supplied list. (< 0)
b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) b) Inf if the supplied index expression is above the upper bound for the supplied list. (> end)
lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote The similar function lindex_resolve_basic uses -Inf to denote
out of range at either end of the list/string. out of range at either end of the list/string.
Otherwise it will return an integer corresponding to the position in the data. Otherwise it will return an integer corresponding to the position in the data.
This is in stark contrast to Tcl list/string function indices which will return empty strings for out of This is in stark contrast to Tcl list/string function indices which will return empty strings for out of
@ -2397,7 +2730,7 @@ namespace eval punk::lib {
datalength -type integer datalength -type integer
index -type indexexpression index -type indexexpression
} }
proc lindex_resolve {len index} { proc lindex_resolve {len index {base 0}} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg len] [arg index]] #[call [fun lindex_resolve] [arg len] [arg index]]
#[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list/string length #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list/string length
@ -2406,8 +2739,8 @@ namespace eval punk::lib {
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -Inf if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) Inf if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list/string #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list/string
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway.
@ -2427,16 +2760,17 @@ namespace eval punk::lib {
} }
if {![string is integer -strict $len] || $len < 0} { if {![string is integer -strict $len] || $len < 0} {
error "lindex_resolve len must be a positive integer" error "lindex_resolve len must be a positive integer."
} }
set based_max [expr {$len -1 + $base}]
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#review - base?
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < $base} {
return -3 return -Inf
} elseif {$index >= $len} { } elseif {$index > $based_max} {
return -2 return Inf
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -2453,19 +2787,22 @@ namespace eval punk::lib {
if {$offset == 0} { if {$offset == 0} {
#(offset +0, -0 or 0 or 000 0_0 etc) #(offset +0, -0 or 0 or 000 0_0 etc)
#op either + or - is irrelevant #op either + or - is irrelevant
set index [expr {$len-1}] #set index [expr {$len-1}] ;#+ base ?
if {$index < 0} { set index $based_max
return -2 ;#special case - equivalent to 'end', with empty list - treat like a positive number out of bounds if {$index < $base} {
#return -2 ;#special case - equivalent to 'end', with empty list - treat like a positive number out of bounds
return Inf
} else { } else {
return $index return $index
} }
} }
set index [if {$op eq "+"} {expr {($len-1) + $offset}} else {expr {($len-1) - $offset}}] #set index [if {$op eq "+"} {expr {($len-1) + $offset}} else {expr {($len-1) - $offset}}]
if {$index < 0} { set index [if {$op eq "+"} {expr {$based_max + $offset}} else {expr {$based_max - $offset}}]
return -3 if {$index < $base} {
} elseif {$index > $len-1} { return -Inf
return -2 } elseif {$index > $based_max} {
return Inf
} else { } else {
return $index return $index
} }
@ -2473,9 +2810,10 @@ namespace eval punk::lib {
#index is 'end' #index is 'end'
if {$len == 0} { if {$len == 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -2 return Inf
} }
return [expr {$len - 1}] #return [expr {$len - 1 + $base}]
return $based_max
} }
} else { } else {
#plain +-<int> already handled above. #plain +-<int> already handled above.
@ -2494,37 +2832,45 @@ namespace eval punk::lib {
} else { } else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < $base} {
return -3 return -Inf
} elseif {$index >= $len} { } elseif {$index > $based_max} {
return -2 return Inf
} }
return $index return $index
} }
} }
} }
proc lindex_resolve_basic {len index} { proc lindex_resolve_basic {len index {base 0}} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve_basic] [arg len] [arg index]] #[call [fun lindex_resolve_basic] [arg len] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index #[para] returns -Inf for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command #[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent #[para] For pure integer indices the performance should be equivalent
if {![string is integer -strict $len]} { if {![string is integer -strict $len] || $len < 0} {
error "lindex_resolve_basic len must be an integer" error "lindex_resolve_basic len must be an integer greater than or equal to zero"
} }
if {![string is integer -strict $base]} {
#base can be negative
error "lindex_resolve_basic base must be an integer"
}
set based_max [expr {$len -1 + $base}]
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
#avoid even the lseq overhead when the index is simple #avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= $len)} { if {$index < $base || ($index > $based_max)} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. #even though in this case we could return -Inf or Inf like lindex_resolve;
return -1 #for consistency we don't return Inf for upper-boudn violation,
#as which bound is violated is not always directly determinable for compound index expressions (such as end-x) using the lseq+lindex mechanism.
return -Inf
} else { } else {
#!NOTE! index within range is unchanged - no matter the base
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
} }
@ -2532,7 +2878,7 @@ namespace eval punk::lib {
if {$len > 0} { if {$len > 0} {
#For large len - this is a wasteful allocation if no true lseq available in Tcl version. #For large len - this is a wasteful allocation if no true lseq available in Tcl version.
#lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW) #lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW)
set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback. set testlist [punk::lib::range $base $based_max] ;# uses lseq if available, has fallback of creating a potentially large list of numbers.
} else { } else {
set testlist [list] set testlist [list]
#we want to call 'lindex' even in this case - to get the appropriate error message #we want to call 'lindex' even in this case - to get the appropriate error message
@ -2540,7 +2886,7 @@ namespace eval punk::lib {
set idx [lindex $testlist $index] set idx [lindex $testlist $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end #we have no way to determine if out of bounds is at lower vs upper end
return -1 return -Inf
} else { } else {
return $idx return $idx
} }
@ -2560,12 +2906,12 @@ namespace eval punk::lib {
if {![string is integer -strict $index]} { if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index] set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index { switch -- $index {
-2 { -Inf {
return [list $str ""]
}
-3 {
return [list "" $str] return [list "" $str]
} }
Inf {
return [list $str ""]
}
} }
} }
return [list [string range $str 0 $index-1] [string range $str $index end]] return [list [string range $str 0 $index-1] [string range $str $index end]]
@ -2580,20 +2926,20 @@ namespace eval punk::lib {
if {![string is integer -strict $index]} { if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index] set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index { switch -- $index {
-2 { -Inf {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
-3 {
if {[lindex $sizes 0] != 0} { if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0] ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0] ledit sizes 0 0 0 [lindex $sizes 0]
} }
continue continue
} }
Inf {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
} }
} }
if {$index <= 0} { if {$index <= 0} {
@ -4038,14 +4384,15 @@ namespace eval punk::lib {
set result "" set result ""
set in_jt 0 set in_jt 0
foreach ln [split $data \n] { foreach ln [split $data \n] {
set tln [string trim $ln] set tln [::tcl::string::trim $ln]
if {!$in_jt} { if {!$in_jt} {
if {[string match *jumpTable* $ln]} { if {[::tcl::string::match *jumpTable* $ln]} {
punk::ns::call_frame
append result $ln \n append result $ln \n
set in_jt 1 set in_jt 1
} }
} else { } else {
if {[string match Command* $tln] || [string match "(*) *" $tln]} { if {[::tcl::string::match Command* $tln] || [::tcl::string::match "(*) *" $tln]} {
set in_jt 0 set in_jt 0
} else { } else {
append result $ln \n append result $ln \n
@ -4055,6 +4402,13 @@ namespace eval punk::lib {
return $result return $result
} }
#a test
# punk::ns::cmdtracereturn punk::lib::disassemble ::punk::ns::test_switch4
# Note the different disassemble result when trace is running.
proc disassemble {procname} {
tcl::unsupported::disassemble proc $procname
}
proc temperature_f_to_c {deg_fahrenheit} { proc temperature_f_to_c {deg_fahrenheit} {
return [expr {($deg_fahrenheit -32) * (5/9.0)}] return [expr {($deg_fahrenheit -32) * (5/9.0)}]
} }
@ -4201,6 +4555,17 @@ namespace eval punk::lib {
} }
} }
#review - there are various type of uuid - we should use something consistent across platforms
#twapi is used on windows because it's about 5 times faster - but is this more important than consistency?
#twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway
#(counterpoint: in the case of punk - we currently need twapi anyway on windows)
#does tcllib's uuid use the same mechanisms on different platforms anyway?
if {$has_twapi} {
interp alias "" ::punk::lib::uuid "" twapi::new_uuid
} else {
catch {package require uuid}
interp alias "" ::punk::lib::uuid "" uuid::uuid generate
}
#*** !doctools #*** !doctools

2
src/modules/punk/lib-buildversion.txt

@ -1,3 +1,3 @@
0.1.3 0.1.4
#First line must be a semantic version number #First line must be a semantic version number
#all other lines are ignored. #all other lines are ignored.

24
src/modules/punk/libunknown-0.1.tm

@ -1585,12 +1585,12 @@ namespace eval punk::libunknown {
#use lindex_resolve to support for example: ledit lst end+1 end+1 h i #use lindex_resolve to support for example: ledit lst end+1 end+1 h i
set fidx [lindex_resolve [llength $l] $first] set fidx [lindex_resolve [llength $l] $first]
switch -exact -- $fidx { switch -exact -- $fidx {
-3 { -Inf {
#index below lower bound #index below lower bound
set pre [list] set pre [list]
set fidx -1 set fidx -1
} }
-2 { Inf {
#first index position is greater than index of last element in the list #first index position is greater than index of last element in the list
set pre [lrange $l 0 end] set pre [lrange $l 0 end]
set fidx [llength $l] set fidx [llength $l]
@ -1601,11 +1601,11 @@ namespace eval punk::libunknown {
} }
set lidx [lindex_resolve [llength $l] $last] set lidx [lindex_resolve [llength $l] $last]
switch -exact -- $lidx { switch -exact -- $lidx {
-3 { -Inf {
#index below lower bound #index below lower bound
set post [lrange $l 0 end] set post [lrange $l 0 end]
} }
-2 { Inf {
#index above upper bound #index above upper bound
set post [list] set post [list]
} }
@ -1632,9 +1632,9 @@ namespace eval punk::libunknown {
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -3 return -Inf
} elseif {$index >= $len} { } elseif {$index >= $len} {
return -2 return Inf
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -1646,14 +1646,14 @@ namespace eval punk::libunknown {
set offset [string range $index 4 end] set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} { if {$op eq "+" && $offset != 0} {
return -2 return Inf
} }
} else { } else {
#index is 'end' #index is 'end'
set index [expr {$len-1}] set index [expr {$len-1}]
if {$index < 0} { if {$index < 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -2 return Inf
} else { } else {
return $index return $index
} }
@ -1661,7 +1661,7 @@ namespace eval punk::libunknown {
if {$offset == 0} { if {$offset == 0} {
set index [expr {$len-1}] set index [expr {$len-1}]
if {$index < 0} { if {$index < 0} {
return -2 ;#special case as above return Inf ;#special case as above
} else { } else {
return $index return $index
} }
@ -1670,7 +1670,7 @@ namespace eval punk::libunknown {
set index [expr {($len-1) - $offset}] set index [expr {($len-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -3 return -Inf
} else { } else {
return $index return $index
} }
@ -1691,9 +1691,9 @@ namespace eval punk::libunknown {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < 0} {
return -3 return -Inf
} elseif {$index >= $len} { } elseif {$index >= $len} {
return -2 return Inf
} }
return $index return $index
} }

2
src/modules/punk/mix/util-999999.0a1.0.tm

@ -150,7 +150,7 @@ namespace eval punk::mix::util {
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found"
} }
if {![string match ::* $ns]} { if {![string match ::* $ns]} {
set nscaller [uplevel 1 {namespace current}] set nscaller [uplevel 1 {::tcl::namespace::current}]
set ns [punk::nsjoin $nscaller $ns] set ns [punk::nsjoin $nscaller $ns]
} }
set a_export_patterns [namespace eval $source_ns {namespace export}] set a_export_patterns [namespace eval $source_ns {namespace export}]

94
src/modules/punk/netbox-999999.0a1.0.tm

@ -711,6 +711,7 @@ tcl::namespace::eval punk::netbox {
return [file join $punk_netbox_data_dir netbox_api_contexts.toml] return [file join $punk_netbox_data_dir netbox_api_contexts.toml]
} }
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::punk::netbox::api_context_save @id -id ::punk::netbox::api_context_save
@cmd -name punk::netbox::api_context_save -help\ @cmd -name punk::netbox::api_context_save -help\
@ -1173,6 +1174,8 @@ tcl::namespace::eval punk::netbox::dcim {
tcl::namespace::eval punk::netbox::ipam { tcl::namespace::eval punk::netbox::ipam {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace eval argdoc {
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1186,7 +1189,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
@ -1219,8 +1222,10 @@ tcl::namespace::eval punk::netbox::ipam {
{ {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::vrfs_list api/ipam/vrfs/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::vrfs_list api/ipam/vrfs/ -verb get -body none
namespace eval argdoc {
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1234,7 +1239,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1243,9 +1248,10 @@ tcl::namespace::eval punk::netbox::ipam {
id -type integer -help\ id -type integer -help\
"A unique integer value identifying this VRF" "A unique integer value identifying this VRF"
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::vrfs_read api/ipam/vrfs/{id}/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::vrfs_read api/ipam/vrfs/{id}/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1259,7 +1265,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
@ -1308,8 +1314,10 @@ tcl::namespace::eval punk::netbox::ipam {
{ {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_list api/ipam/prefixes/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_list api/ipam/prefixes/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1323,7 +1331,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1332,8 +1340,10 @@ tcl::namespace::eval punk::netbox::ipam {
body -type string -help\ body -type string -help\
"JSON string" "JSON string"
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_create api/ipam/prefixes/{id}/ -verb post -body required ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_create api/ipam/prefixes/{id}/ -verb post -body required
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1347,7 +1357,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1356,9 +1366,10 @@ tcl::namespace::eval punk::netbox::ipam {
id -type integer -help\ id -type integer -help\
"A unique integer value identifying this prefix" "A unique integer value identifying this prefix"
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_read api/ipam/prefixes/{id}/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_read api/ipam/prefixes/{id}/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1372,7 +1383,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_page_options]\ [set ::punk::netbox::argdoc::_page_options]\
@ -1384,8 +1395,10 @@ tcl::namespace::eval punk::netbox::ipam {
"A unique integer value identifying this prefix" "A unique integer value identifying this prefix"
}\ }\
] ]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_list api/ipam/prefixes/{id}/available-ips/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_list api/ipam/prefixes/{id}/available-ips/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1399,7 +1412,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\
@ -1432,8 +1445,10 @@ tcl::namespace::eval punk::netbox::ipam {
} }
}\ }\
] ]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1447,7 +1462,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_page_options]\ [set ::punk::netbox::argdoc::_page_options]\
@ -1459,8 +1474,10 @@ tcl::namespace::eval punk::netbox::ipam {
"A unique integer value identifying this prefix" "A unique integer value identifying this prefix"
}\ }\
] ]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1474,7 +1491,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\
@ -1491,8 +1508,10 @@ tcl::namespace::eval punk::netbox::ipam {
} }
}\ }\
] ]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1506,7 +1525,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
@ -1555,8 +1574,10 @@ tcl::namespace::eval punk::netbox::ipam {
{ {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_list api/ipam/ip-addresses/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_list api/ipam/ip-addresses/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1570,7 +1591,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1578,8 +1599,10 @@ tcl::namespace::eval punk::netbox::ipam {
@values -min 1 -max 1 @values -min 1 -max 1
id -type integer id -type integer
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_read api/ipam/ip-addresses/{id}/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_read api/ipam/ip-addresses/{id}/ -verb get -body none
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1593,7 +1616,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1625,8 +1648,10 @@ tcl::namespace::eval punk::netbox::ipam {
Required: address (IPv4 or IPV6 address with mask) Required: address (IPv4 or IPV6 address with mask)
} }
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_create api/ipam/ip-addresses/ -verb post -body required ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_create api/ipam/ip-addresses/ -verb post -body required
namespace eval argdoc {
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic
@ -1640,7 +1665,7 @@ tcl::namespace::eval punk::netbox::ipam {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1672,11 +1697,18 @@ tcl::namespace::eval punk::netbox::ipam {
required: address required: address
} }
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_bulk_partial_update api/ipam/ip-addresses/ -verb patch -body required ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_bulk_partial_update api/ipam/ip-addresses/ -verb patch -body required
} }
tcl::namespace::eval punk::netbox::tenancy { tcl::namespace::eval punk::netbox::tenancy {
namespace export {[a-z]*} namespace export {[a-z]*}
variable PUNKARGS
namespace eval argdoc {
variable PUNKARGS
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1690,7 +1722,7 @@ tcl::namespace::eval punk::netbox::tenancy {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
@ -1721,11 +1753,18 @@ tcl::namespace::eval punk::netbox::tenancy {
{ {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::tenancy::tenants_list api/tenancy/tenants/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::tenancy::tenants_list api/tenancy/tenants/ -verb get -body none
} }
tcl::namespace::eval punk::netbox::virtualization { tcl::namespace::eval punk::netbox::virtualization {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace eval argdoc {
variable PUNKARGS
variable DYN_CONTEXTNAMES
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1739,7 +1778,7 @@ tcl::namespace::eval punk::netbox::virtualization {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
@ -1796,8 +1835,11 @@ tcl::namespace::eval punk::netbox::virtualization {
{ {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_list api/virtualization/virtual-machines/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_list api/virtualization/virtual-machines/ -verb get -body none
namespace eval argdoc {
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1811,7 +1853,7 @@ tcl::namespace::eval punk::netbox::virtualization {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1822,8 +1864,10 @@ tcl::namespace::eval punk::netbox::virtualization {
body -type string -help\ body -type string -help\
"JSON string" "JSON string"
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_create api/virtualization/virtual-machines/ -verb post -body required ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_create api/virtualization/virtual-machines/ -verb post -body required
namespace eval argdoc {
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1839,7 +1883,7 @@ tcl::namespace::eval punk::netbox::virtualization {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
-FORCE -default 0 -type boolean -help\ -FORCE -default 0 -type boolean -help\
"Set to true to BULK delete all items at this endpoint" "Set to true to BULK delete all items at this endpoint"
@ -1847,9 +1891,10 @@ tcl::namespace::eval punk::netbox::virtualization {
{ {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_delete api/virtualization/virtual-machines/ -verb delete -body none ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_delete api/virtualization/virtual-machines/ -verb delete -body none
namespace eval argdoc {
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1863,7 +1908,7 @@ tcl::namespace::eval punk::netbox::virtualization {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1872,8 +1917,10 @@ tcl::namespace::eval punk::netbox::virtualization {
id -type integer -help\ id -type integer -help\
"A unique integer value identifying this virtual machine" "A unique integer value identifying this virtual machine"
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_read api/virtualization/virtual-machines/{id}/ -verb get -body none ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_read api/virtualization/virtual-machines/{id}/ -verb get -body none
namespace eval argdoc {
lappend PUNKARGS [list\ lappend PUNKARGS [list\
{ {
@dynamic @dynamic
@ -1887,7 +1934,7 @@ tcl::namespace::eval punk::netbox::virtualization {
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${$DYN_CONTEXTNAMES}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1898,6 +1945,7 @@ tcl::namespace::eval punk::netbox::virtualization {
body -type string -help\ body -type string -help\
"JSON string" "JSON string"
}] }]
}
::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_update api/virtualization/virtual-machines/{id}/ -verb put -body required ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_update api/virtualization/virtual-machines/{id}/ -verb put -body required
} }

111
src/modules/punk/netbox/man-999999.0a1.0.tm

@ -178,13 +178,25 @@ tcl::namespace::eval punk::netbox::man::prefixes {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid} namespace ensemble create -parameters {apicontextid}
namespace eval argdoc {
variable PUNKARGS variable PUNKARGS
#mark as @dynamic and ensure double-substitution present for dynamic parts
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
[punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes::list"}} ::punk::netbox::ipam::prefixes_list]\ {@dynamic}\
[punk::args::resolved_def\
-antiglobs {@leaders @values -RETURN}\
-override {
@id {-id ::punk::netbox::man::prefixes::list }
apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
}\
::punk::netbox::ipam::prefixes_list\
]\
{-RETURN -default table -choices {table tableobject list}}\ {-RETURN -default table -choices {table tableobject list}}\
{-MAXRESULTS -type integer -default -1}\ {-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\ {@values -min 0 -max 0}\
] ]
}
#caution: must use ::list to avoid loop #caution: must use ::list to avoid loop
proc list {args} { proc list {args} {
@ -290,18 +302,24 @@ tcl::namespace::eval punk::netbox::man::prefixes {
namespace ensemble create -parameters {apicontextid} namespace ensemble create -parameters {apicontextid}
variable PUNKARGS variable PUNKARGS
namespace eval argdoc {
variable PUNKARGS
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
{@dynamic}\
[punk::args::resolved_def\ [punk::args::resolved_def\
-antiglobs {@leaders -offset}\ -antiglobs {@leaders -offset}\
-override {\ -override {
@id {-id "::punk::netbox::man::prefixes::available-ips::create"}\ @id {-id "::punk::netbox::man::prefixes::available-ips::create" }
-RETURN {-default table -choices {list linelist showlistofdicts}}\ apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
@values {-min 2 -max 2}\ -RETURN {-default table -choices {list linelist showlistofdicts} }
body {-optional 0}\ @values {-min 2 -max 2 }
body {-optional 0 }
}\ }\
::punk::netbox::ipam::prefixes_available-ips_create\ ::punk::netbox::ipam::prefixes_available-ips_create\
]\ ]\
] ]
}
proc create {args} { proc create {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::create"] set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::create"]
set resultlist [::list] set resultlist [::list]
@ -356,18 +374,22 @@ tcl::namespace::eval punk::netbox::man::prefixes {
# [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\
# {-RETURN -default table -choices {table tableobject list}} # {-RETURN -default table -choices {table tableobject list}}
# ] # ]
namespace eval argdoc {
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
{@dynamic}\
[punk::args::resolved_def\ [punk::args::resolved_def\
-antiglobs {@leaders -offset}\ -antiglobs {@leaders -offset}\
-override {\ -override {
@id {-id "::punk::netbox::man::prefixes::available-ips::list"}\ @id {-id "::punk::netbox::man::prefixes::available-ips::list"}
-limit {-default 254 -help "Maximum number of entries to return"}\ apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
-RETURN {-default table -choices {table tableobject list linelist}}\ -limit {-default 254 -help "Maximum number of entries to return"}
@values {-min 1 -max 1}\ -RETURN {-default table -choices {table tableobject list linelist}}
@values {-min 1 -max 1}
}\ }\
::punk::netbox::ipam::prefixes_available-ips_list\ ::punk::netbox::ipam::prefixes_available-ips_list\
]\ ]\
] ]
}
proc list {args} { proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::list"] set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::list"]
@ -453,20 +475,25 @@ tcl::namespace::eval punk::netbox::man::prefixes {
tcl::namespace::eval available-prefixes { tcl::namespace::eval available-prefixes {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid} namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
namespace eval argdoc {
variable PUNKARGS
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
{@dynamic}\
[punk::args::resolved_def\ [punk::args::resolved_def\
-antiglobs {@leaders -offset}\ -antiglobs {@leaders -offset}\
-override {\ -override {
@id {-id "::punk::netbox::man::prefixes::available-prefixes::create"}\ @id {-id "::punk::netbox::man::prefixes::available-prefixes::create"}
-RETURN {-default table -choices {list linelist showlistofdicts}}\ apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
@values {-min 2 -max 2}\ -RETURN {-default table -choices {list linelist showlistofdicts}}
body {-optional 0}\ @values {-min 2 -max 2}
body {-optional 0}
}\ }\
::punk::netbox::ipam::prefixes_available-prefixes_create\ ::punk::netbox::ipam::prefixes_available-prefixes_create\
]\ ]\
] ]
}
proc create {args} { proc create {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::create"] set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::create"]
set resultlist [::list] set resultlist [::list]
@ -521,18 +548,22 @@ tcl::namespace::eval punk::netbox::man::prefixes {
# [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\
# {-RETURN -default table -choices {table tableobject list}} # {-RETURN -default table -choices {table tableobject list}}
# ] # ]
namespace eval argdoc {
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
{@dynamic}\
[punk::args::resolved_def\ [punk::args::resolved_def\
-antiglobs {@leaders -offset}\ -antiglobs {@leaders -offset}\
-override {\ -override {
@id {-id "::punk::netbox::man::prefixes::available-prefixes::list"}\ @id {-id "::punk::netbox::man::prefixes::available-prefixes::list"}
-limit {-default 254 -help "Maximum number of entries to return"}\ apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
-RETURN {-default table -choices {table tableobject list linelist}}\ -limit {-default 254 -help "Maximum number of entries to return"}
@values {-min 1 -max 1}\ -RETURN {-default table -choices {table tableobject list linelist}}
@values {-min 1 -max 1}
}\ }\
::punk::netbox::ipam::prefixes_available-prefixes_list\ ::punk::netbox::ipam::prefixes_available-prefixes_list\
]\ ]\
] ]
}
proc list {args} { proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::list"] set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::list"]
@ -631,17 +662,23 @@ tcl::namespace::eval punk::netbox::man::tenancy {
#we're overriding a resolved_def which was dynamic #we're overriding a resolved_def which was dynamic
# - we need to ensure the new definition is also dynamic # - we need to ensure the new definition is also dynamic
# - todo - override rawdef instead? (convenience functions for override of rawdef is missing in punk::args) # - todo - override rawdef instead? (convenience functions for override of rawdef is missing in punk::args)
namespace eval argdoc {
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
@dynamic\ @dynamic\
[punk::args::resolved_def\ [punk::args::resolved_def\
-antiglobs {@leaders @values -RETURN}\ -antiglobs {@leaders @values -RETURN}\
-override {@id {-id "::punk::netbox::man::tenancy::tenants::list"} apicontextid {-choices {${[punk::netbox::api_context_names]}}}}\ -override {
@id {-id "::punk::netbox::man::tenancy::tenants::list" }
apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
}\
::punk::netbox::tenancy::tenants_list\ ::punk::netbox::tenancy::tenants_list\
]\ ]\
{-RETURN -default table -choices {table tableobject list linelist}}\ {-RETURN -default table -choices {table tableobject list linelist}}\
{-MAXRESULTS -type integer -default -1}\ {-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\ {@values -min 0 -max 0}\
] ]
}
proc list {args} { proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::tenancy::tenants::list"] set argd [punk::args::parse $args withid "::punk::netbox::man::tenancy::tenants::list"]
@ -757,13 +794,25 @@ tcl::namespace::eval punk::netbox::man::virtualization {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid} namespace ensemble create -parameters {apicontextid}
variable PUNKARGS variable PUNKARGS
namespace eval argdoc {
variable PUNKARGS
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
[punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::virtualization::virtual-machines::list"}} ::punk::netbox::virtualization::virtual-machines_list]\ {@dynamic}\
[punk::args::resolved_def\
-antiglobs {@leaders @values -RETURN}\
-override {
@id {-id "::punk::netbox::man::virtualization::virtual-machines::list" }
apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
}\
::punk::netbox::virtualization::virtual-machines_list\
]\
{-RETURN -default table -choices {table tableobject list linelist}}\ {-RETURN -default table -choices {table tableobject list linelist}}\
{-MAXRESULTS -type integer -default -1}\ {-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\ {@values -min 0 -max 0}\
] ]
}
proc list {args} { proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::virtualization::virtual-machines::list"] set argd [punk::args::parse $args withid "::punk::netbox::man::virtualization::virtual-machines::list"]
@ -881,14 +930,24 @@ tcl::namespace::eval punk::netbox::man::virtualization {
tcl::namespace::eval punk::netbox::man::ip-addresses { tcl::namespace::eval punk::netbox::man::ip-addresses {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid} namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
namespace eval argdoc {
set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}}
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
[punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses::list"}} ::punk::netbox::ipam::ip-addresses_list]\ {@dynamic}\
[punk::args::resolved_def\
-antiglobs {@leaders @values -RETURN}\
-override {
@id {-id ::punk::netbox::man::ip-addresses::list }
apicontextid {-choices {${$DYN_CONTEXTNAMES}} }
}\
::punk::netbox::ipam::ip-addresses_list\
]\
{-RETURN -default table -choices {table tableobject list linelist}}\ {-RETURN -default table -choices {table tableobject list linelist}}\
{-MAXRESULTS -type integer -default -1}\ {-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\ {@values -min 0 -max 0}\
] ]
}
#caution: must use ::list to avoid loop #caution: must use ::list to avoid loop
proc list {args} { proc list {args} {

1968
src/modules/punk/ns-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

29
src/modules/punk/repl-999999.0a1.0.tm

@ -452,7 +452,7 @@ proc repl::start {inchan args} {
#punk::repl::codethread::running is required whether safe or not. #punk::repl::codethread::running is required whether safe or not.
interp eval code { interp eval code {
namespace eval ::punk::repl::codethread {} namespace eval ::punk::repl::codethread {}
set ::punk::repl::codethread::running 1 set ::punk::repl::codethread::is_running 1
namespace eval ::punk::ns::ns_current {} namespace eval ::punk::ns::ns_current {}
set ::punk::ns::ns_current %ns1% set ::punk::ns::ns_current %ns1%
} }
@ -1616,7 +1616,11 @@ proc repl::repl_handler {inputchan prompt_config} {
#repl_handler_checkchannel $inputchan #repl_handler_checkchannel $inputchan
chan event $inputchan readable {} chan event $inputchan readable {}
set reading 0 set reading 0
thread::send -async $::repl::codethread {set ::punk::repl::codethread::running 0} #target is the 'main' interp in codethread.
#(note bug where thread::send <owntid> goes to code interp, but thread::send -async <owntid> goes to main interp)
# https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4
thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread
if {$::tcl_interactive} { if {$::tcl_interactive} {
rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]"
#rputs stderr "\n|repl> ctrl-c EOF on $inputchan." #rputs stderr "\n|repl> ctrl-c EOF on $inputchan."
@ -2940,7 +2944,8 @@ namespace eval repl {
thread::send %replthread% [list punk::repl::editbuf {*}$args] thread::send %replthread% [list punk::repl::editbuf {*}$args]
} }
proc escapeeval {script} { proc escapeeval {script} {
eval $script #eval $script
uplevel #0 $script
} }
proc do_after {args} { proc do_after {args} {
if {[llength $args] == 1} { if {[llength $args] == 1} {
@ -3050,7 +3055,7 @@ namespace eval repl {
namespace ensemble create namespace ensemble create
namespace ensemble configure [namespace current] -unknown ::repl::interphelpers::repl_ensemble_unknown namespace ensemble configure [namespace current] -unknown ::repl::interphelpers::repl_ensemble_unknown
variable replinfo variable replinfo
set replinfo [dict create thread %replthread% interp %replthread_interp%] set replinfo [dict create thread %replthread% interp %replthread_interp% codethread [thread::id]]
proc thread {} { proc thread {} {
return %replthread% return %replthread%
} }
@ -3267,6 +3272,7 @@ namespace eval repl {
textutil\ textutil\
punk::encmime\ punk::encmime\
punk::char\ punk::char\
punk::trie\
punk::ansi\ punk::ansi\
punk::lib\ punk::lib\
overtype\ overtype\
@ -3353,7 +3359,7 @@ namespace eval repl {
code alias ::shellfilter::stack ::shellfilter::stack code alias ::shellfilter::stack ::shellfilter::stack
#code alias ::punk::lib::set_valcopy ::punk::lib::set_valcopy #code alias ::punk::lib::set_valcopy ::punk::lib::set_valcopy
#code alias ::aliases ::punk::ns::aliases #code alias ::aliases ::punk::ns::aliases
code alias ::punk::ns::aliases ::punk::ns::aliases #code alias ::punk::ns::aliases ::punk::ns::aliases
namespace eval ::codeinterp {} namespace eval ::codeinterp {}
code alias ::md5::md5 ::repl::interphelpers::md5 code alias ::md5::md5 ::repl::interphelpers::md5
@ -3445,6 +3451,13 @@ namespace eval repl {
interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)]
interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)]
set codehidden [code hidden]
#interp alias is available in safe - so it seems unreasonable to disallow 'info cmdtype'
if {"tcl:info:cmdtype" in $codehidden} {
code eval {rename ::tcl::info::cmdtype ""}
code expose tcl:info:cmdtype
code eval {rename tcl:info:cmdtype ::tcl::info::cmdtype}
}
code alias ::fconfigure ::repl::interphelpers::fconfigure ;#needed for shellfilter code alias ::fconfigure ::repl::interphelpers::fconfigure ;#needed for shellfilter
@ -3578,7 +3591,7 @@ namespace eval repl {
} }
} }
if {$libunknown ne ""} { if {$libunknown ne ""} {
uplevel 1 [list source $libunknown] uplevel 1 [list ::source $libunknown]
if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} {
puts "error initialising punk::libunknown\n$errM" puts "error initialising punk::libunknown\n$errM"
} }
@ -3689,6 +3702,10 @@ namespace eval repl {
code alias exit ::repl::interphelpers::quit code alias exit ::repl::interphelpers::quit
code alias ::thread::id ::thread::id
#REVIEW
#code alias ::thread::send ::thread::send
#experiment #experiment
#code alias ::shellfilter::stack ::shellfilter::stack #code alias ::shellfilter::stack ::shellfilter::stack

104
src/modules/punk/repl/codethread-999999.0a1.0.tm

@ -62,44 +62,6 @@ package require punk::config
#*** !doctools #*** !doctools
#[section API] #[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::repl::codethread::class {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::class}]
#[para] class definitions
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -109,7 +71,7 @@ tcl::namespace::eval punk::repl::codethread {
tcl::namespace::export * tcl::namespace::export *
variable replthread variable replthread
variable replthread_cond variable replthread_cond
variable running 0 variable is_running 0
variable output_stdout "" variable output_stdout ""
variable output_stderr "" variable output_stderr ""
@ -126,19 +88,6 @@ tcl::namespace::eval punk::repl::codethread {
#[list_begin definitions] #[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
variable run_command_cache variable run_command_cache
#Use interp exists instead.. #Use interp exists instead..
@ -149,9 +98,10 @@ tcl::namespace::eval punk::repl::codethread {
#} #}
proc is_running {} { proc is_running {} {
variable running variable is_running
return $running return $is_running
} }
proc runscript {script} { proc runscript {script} {
#puts stderr "->runscript" #puts stderr "->runscript"
@ -170,12 +120,14 @@ tcl::namespace::eval punk::repl::codethread {
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread"
return return
} }
interp eval code [list set ::punk::repl::codethread::output_stdout ""]
interp eval code [list set ::punk::repl::codethread::output_stderr ""]
set outstack [list] set outstack [list]
set errstack [list] set errstack [list]
set config_running [::punk::config::configure running] set config_running [::punk::config::configure running]
interp eval code {
set ::punk::repl::codethread::output_stdout ""
set ::punk::repl::codethread::output_stderr ""
}
if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} { if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} {
lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]]
} }
@ -269,45 +221,7 @@ tcl::namespace::eval punk::repl::codethread {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread::lib {
tcl::namespace::export *
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::repl::codethread::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
tcl::namespace::eval punk::repl::codethread::system {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread {
variable pkg punk::repl::codethread variable pkg punk::repl::codethread

16
src/modules/punk/safe-999999.0a1.0.tm

@ -334,7 +334,8 @@ tcl::namespace::eval punk::safe {
#REVIEW #REVIEW
set autoPath {} set autoPath {}
} }
set argd [punk::args::get_by_id ::punk::safe::interpCreate $args] #set argd [punk::args::get_by_id ::punk::safe::interpCreate $args]
set argd [punk::args::parse $args withid ::punk::safe::interpCreate]
set child [dict get $argd leaders child] set child [dict get $argd leaders child]
set autoPath [dict get $argd opts -autoPath] set autoPath [dict get $argd opts -autoPath]
punk::safe::lib::RejectExcessColons $child punk::safe::lib::RejectExcessColons $child
@ -355,7 +356,8 @@ tcl::namespace::eval punk::safe {
if {$AutoPathSync} { if {$AutoPathSync} {
set autoPath {} set autoPath {}
} }
set argd [punk::args::get_by_id ::punk::safe::interpIC $args] #set argd [punk::args::get_by_id ::punk::safe::interpIC $args]
set argd [punk::args::parse $args withid ::punk::safe::interpIC]
set child [dict get $argd leaders child] set child [dict get $argd leaders child]
set autoPath [dict get $argd opts -autoPath] set autoPath [dict get $argd opts -autoPath]
if {![::interp exists $child]} { if {![::interp exists $child]} {
@ -405,7 +407,8 @@ tcl::namespace::eval punk::safe {
# we know that "child" is our given argument because it also # we know that "child" is our given argument because it also
# checks for the "-help" option. # checks for the "-help" option.
#TODO! #TODO!
set argd [punk::args::get_by_id ::punk::safe::interpIC $args] #set argd [punk::args::get_by_id ::punk::safe::interpIC $args]
set argd [punk::args::parse $args withid ::punk::safe::interpIC]
set child [dict get $argd leaders child] set child [dict get $argd leaders child]
CheckInterp $child CheckInterp $child
@ -469,7 +472,8 @@ tcl::namespace::eval punk::safe {
} }
default { default {
#return -code error "unknown flag $name. Known options: $opt_names" #return -code error "unknown flag $name. Known options: $opt_names"
punk::args::get_by_id ::punk::safe::interpIC [list $child $arg] #punk::args::get_by_id ::punk::safe::interpIC [list $child $arg]
punk::args::parse [list $child $arg] withid ::punk::safe::interpIC
} }
} }
} }
@ -477,7 +481,9 @@ tcl::namespace::eval punk::safe {
# Otherwise we want to parse the arguments like init and create did # Otherwise we want to parse the arguments like init and create did
#set Args [::tcl::OptKeyParse ::safe::interpIC $args] #set Args [::tcl::OptKeyParse ::safe::interpIC $args]
set argd [punk::args::get_by_id ::punk::safe::interpIC $args] #set argd [punk::args::get_by_id ::punk::safe::interpIC $args]
set argd [punk::args::parse $args withid ::punk::safe::interpIC
set child [dict get $argd leaders child] set child [dict get $argd leaders child]
CheckInterp $child CheckInterp $child
namespace upvar ::punk::safe::system [VarName $child] state namespace upvar ::punk::safe::system [VarName $child] state

37
src/modules/punk/trie-999999.0a1.0.tm

@ -103,16 +103,27 @@ tcl::namespace::eval punk::trie {
proc Dolog {lvl txt} { proc Dolog {lvl txt} {
#return "$lvl -- $txt" #return "$lvl -- $txt"
#logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted #logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted
set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie $lvl '[uplevel [list subst $txt]]'"
puts stderr $msg puts stderr $msg
} }
if {![catch {
package require logger package require logger
}]} {
logger::initNamespace ::punk::trie logger::initNamespace ::punk::trie
foreach lvl [logger::levels] { foreach lvl [logger::levels] {
interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl
log::logproc $lvl ::punk::trie::Log_$lvl log::logproc $lvl ::punk::trie::Log_$lvl
} }
#namespace path ::punk::trie::log #namespace path ::punk::trie::log
} else {
#e.g tcllib not available, safe interp?
#fake out the logger calls
namespace eval log {
foreach lvl {debug info notice warn error critical alert emergency} {
proc $lvl {args} {}
}
}
}
#*** !doctools #*** !doctools
#[subsection {Namespace punk::trie}] #[subsection {Namespace punk::trie}]
@ -553,30 +564,6 @@ tcl::namespace::eval punk::trie {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::trie::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::trie::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::trie::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++

17
src/modules/punkcheck-0.1.0.tm

@ -46,21 +46,16 @@ namespace eval punkcheck {
#antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators #antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators
variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"] variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"]
variable default_antiglob_file_core "" variable default_antiglob_file_core ""
proc uuid {} {
set has_twapi 0 set has_twapi 0
if {"windows" eq $::tcl_platform(platform)} { if {"windows" eq $::tcl_platform(platform)} {
if {![catch {package require twapi}]} { set has_twapi [expr {![catch {package require twapi}]}]
set has_twapi 1
}
} }
if {!$has_twapi} { if {$has_twapi} {
if {[catch {package require uuid} errM]} { interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid
error "punkcheck: Unable to load a package for uuid on this platform. Try tcllib's uuid (any platform) - twapi for windows"
}
return [uuid::uuid generate]
} else { } else {
return [twapi::new_uuid] catch {package require uuid}
} interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate
} }
proc default_antiglob_dir_core {} { proc default_antiglob_dir_core {} {

68
src/modules/test/punk/#modpod-lib-999999.0a1.0/files/testscript_parsing.tcl

@ -0,0 +1,68 @@
#file should load as list of lists with punk::lib::tclscript_to_scriptlist
\
\
puts test1
# extended comment with trailing whitespace \
etc\
puts test2
list\
test3\
# hmm
set x [list\
#blah \
etc
]
puts "x = $x"
set y [list A B
]
puts "y = $y"
set z [list not in z because next line is a new command which becomes result of the script delimited by square brackets
set j 1
]
#z will be just 1
puts "z = $z"
set hmm {
#seemingly unbalanced comment,but is just part of hmm data - still requires balancing close curly within the data {
#syntax highlighters usually get this wrong.
}
# also not really a comment, but closing curly is not part of data }
puts $hmm
;# }
# unbalanced curly in *toplevel* comment is unwise, but not really a problem. info complete for this line will be true. {
set data "
# {
"
set j 123;set k 345
;list\
a b c
set etc {
\{ a test
;}
list \ #etc
list \ \" ;#etc
proc { x } {a} {
return $a
}
\ x\ blah
#the end

22
src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/index_functions.test

@ -32,26 +32,26 @@ namespace eval ::testspace {
#e.g indices {0 1 2 3 4} n = 5 #e.g indices {0 1 2 3 4} n = 5
lappend result [punk::lib::lindex_resolve 5 end+1] ;# -> -2 out of bounds on upper side lappend result [punk::lib::lindex_resolve 5 end+1] ;# -> Inf out of bounds on upper side
lappend result [punk::lib::lindex_resolve 5 end--1] ;# equiv to +1 -> -2 lappend result [punk::lib::lindex_resolve 5 end--1] ;# equiv to +1 -> Inf
lappend result [punk::lib::lindex_resolve 5 4--5] ;# -> -2 out of bounds on upper side lappend result [punk::lib::lindex_resolve 5 4--5] ;# -> Inf out of bounds on upper side
lappend result [punk::lib::lindex_resolve 5 end--5] ;# -> -2 out of bounds on upper side lappend result [punk::lib::lindex_resolve 5 end--5] ;# -> Inf out of bounds on upper side
lappend result [punk::lib::lindex_resolve 5 4-5] ;# -> -3 out of bounds on lower side lappend result [punk::lib::lindex_resolve 5 4-5] ;# -> -Inf out of bounds on lower side
lappend result [punk::lib::lindex_resolve 5 end-5] ;# -> -3 out of bounds on lower side lappend result [punk::lib::lindex_resolve 5 end-5] ;# -> -Inf out of bounds on lower side
lappend result [punk::lib::lindex_resolve 5 4+-5] ;# -> -3 out of bounds on lower side lappend result [punk::lib::lindex_resolve 5 4+-5] ;# -> -Inf out of bounds on lower side
lappend result [punk::lib::lindex_resolve 5 end+-5] ;# -> -3 out of bounds on lower side lappend result [punk::lib::lindex_resolve 5 end+-5] ;# -> -Inf out of bounds on lower side
lappend result [punk::lib::lindex_resolve 5 4-+5] ;# -> -3 out of bounds on lower side lappend result [punk::lib::lindex_resolve 5 4-+5] ;# -> -Inf out of bounds on lower side
lappend result [punk::lib::lindex_resolve 5 end-+5] ;# -> -3 out of bounds on lower side lappend result [punk::lib::lindex_resolve 5 end-+5] ;# -> -Inf out of bounds on lower side
}\ }\
-cleanup { -cleanup {
}\ }\
-result [list\ -result [list\
-2 -2 -2 -2 -3 -3 -3 -3 -3 -3 Inf Inf Inf Inf -Inf -Inf -Inf -Inf -Inf -Inf
] ]
test lindex_resolve_endoffset_errors {test some end-like offsets that should error}\ test lindex_resolve_endoffset_errors {test some end-like offsets that should error}\

43
src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/parse.test

@ -0,0 +1,43 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
test parse_tcl_script_switchargs {test basic parse of switch args (switch form 1) tclscript_to_scriptlist}\
-setup $common -body {
#
set scr {-exact -- [lindex $args 0] {a - b {expr 33} c {expr 44}} }
set lol [punk::lib::tclscript_to_scriptlist $scr]
lappend result [llength $lol] ;#single toplevel script
lappend result [llength [lindex $lol 0]]
#final arg to switch -form 1 is a scriptblock consisting of pattern/script pairs
set patternblock_script [lindex $lol 0 end]
set patternblock_contents [lindex $patternblock_script 0] ;#it's braced
#we should be able to treat the data within the braces as a dict.
lappend result [dict keys $patternblock_contents]
}\
-cleanup {
}\
-result [list\
1 4 {a b c}
]
test parse_tcl_script_oneline {test basic parse of single-line script to list of lists with tclscript_to_scriptlist}\
-setup $common -body {
set scr {puts [info name]; dict get {a A b "B B"} a}
set lol [punk::lib::tclscript_to_scriptlist $scr]
lappend result [llength $lol] ;#2 toplevel scripts
lappend result [llength [lindex $lol 0]]
lappend result [llength [lindex $lol 1]]
}\
-cleanup {
}\
-result [list\
2 2 4
]
}

0
src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/tests/parse.test#..+lib+parse.test.fauxlink

15
src/modules/textblock-999999.0a1.0.tm

@ -5724,7 +5724,7 @@ tcl::namespace::eval textblock {
#join without regard to each line length in a block (no padding added to make each block uniform) #join without regard to each line length in a block (no padding added to make each block uniform)
proc ::textblock::join_basic {args} { proc ::textblock::join_basic {args} {
set argd [punk::args::parse $args -cache 1 withid ::textblock::join_basic] set argd [punk::args::parse $args -cache 0 withid ::textblock::join_basic]
set ansiresets [tcl::dict::get $argd opts -ansiresets] set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks] set blocks [tcl::dict::get $argd values blocks]
@ -7798,13 +7798,13 @@ tcl::namespace::eval textblock {
variable frame_cache variable frame_cache
set frame_cache [tcl::dict::create] set frame_cache [tcl::dict::create]
namespace eval argdoc {
punk::args::define { punk::args::define {
@id -id ::textblock::frame_cache @id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\ @cmd -name textblock::frame_cache -help\
"Display or clear the frame cache." "Display or clear the frame cache."
-pretty -default 1 -help\ -pretty -default 1 -help\
"Uses 'pdict textblock::frame_cache */*' for prettier output "Uses '${$B}pdict${$N} textblock::frame_cache */*' for prettier output
Either way this is set, output requires long lines and may Either way this is set, output requires long lines and may
still wrap in an ugly manner. Try 'textblock::use_cache md5' still wrap in an ugly manner. Try 'textblock::use_cache md5'
to shorten the argument display and reduce wrapping. to shorten the argument display and reduce wrapping.
@ -7814,6 +7814,7 @@ tcl::namespace::eval textblock {
clear "Clear the textblock::frame_cache dictionary." clear "Clear the textblock::frame_cache dictionary."
} -help "Perform an action on the frame cache." } -help "Perform an action on the frame cache."
} }
}
proc frame_cache {args} { proc frame_cache {args} {
set argd [punk::args::parse $args withid ::textblock::frame_cache] set argd [punk::args::parse $args withid ::textblock::frame_cache]
set action [dict get $argd values action] set action [dict get $argd values action]
@ -7847,7 +7848,6 @@ tcl::namespace::eval textblock {
} }
} }
punk::args::define { punk::args::define {
@dynamic
@id -id ::textblock::frame_cache_display @id -id ::textblock::frame_cache_display
@opts @opts
${[::punk::args::resolved_def -types opts ::textblock::frame_cache -pretty]} ${[::punk::args::resolved_def -types opts ::textblock::frame_cache -pretty]}
@ -7966,6 +7966,8 @@ tcl::namespace::eval textblock {
#todo punk::args alias for centre center etc? #todo punk::args alias for centre center etc?
namespace eval argdoc { namespace eval argdoc {
set DYN_FRAMETYPES {${[textblock::frametypes]}}
set DYN_FRAMESAMPLES {${[textblock::frame_samples]}}
punk::args::define { punk::args::define {
@dynamic @dynamic
@id -id ::textblock::frame @id -id ::textblock::frame
@ -7997,10 +7999,11 @@ tcl::namespace::eval textblock {
-type -default light\ -type -default light\
-type dict\ -type dict\
-typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\
-choices {${[textblock::frametypes]}}\ -choices {${$DYN_FRAMETYPES}}\
-choicerestricted 0 -choicecolumns 8\ -choicerestricted 0 -choicecolumns 8\
-unindentedfields {-choicelabels}\
-choicelabels { -choicelabels {
${[textblock::frame_samples]} ${$DYN_FRAMESAMPLES}
}\ }\
-help "Type of border for frame." -help "Type of border for frame."
-boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements.

4892
src/vendormodules/overtype-1.7.2.tm

File diff suppressed because it is too large Load Diff
Loading…
Cancel
Save