You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
812 lines
33 KiB
812 lines
33 KiB
# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2025 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::pipe 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license MIT |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::pipe 0 999999.0a1.0] |
|
#[copyright "2025"] |
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
#[require punk::pipe] |
|
#[keywords module] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::pipe |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::pipe |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
|
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
|
|
|
|
tcl::namespace::eval punk::pipe { |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection {Namespace punk::pipe}] |
|
#[para] Core API functions for punk::pipe |
|
#[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" |
|
#} |
|
|
|
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
|
# |
|
#we can't provide a float comparison suitable for every situation, |
|
#but we should pick something reasonable, keep it stable, and document it. |
|
proc float_almost_equal {a b} { |
|
package require math::constants |
|
set diff [expr {abs($a - $b)}] |
|
if {$diff <= $::math::constants::eps} { |
|
return 1 |
|
} |
|
set A [expr {abs($a)}] |
|
set B [expr {abs($b)}] |
|
set largest [expr {($B > $A) ? $B : $A}] |
|
return [expr {$diff <= $largest * $::math::constants::eps}] |
|
} |
|
|
|
#debatable whether boolean_almost_equal is more surprising than helpful. |
|
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
|
#perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. |
|
#alternatively - use an even more complex classifier? (^&~) ? |
|
proc boolean_almost_equal {a b} { |
|
if {[string is double -strict $a]} { |
|
if {[float_almost_equal $a 0]} { |
|
set a 0 |
|
} |
|
} |
|
if {[string is double -strict $b]} { |
|
if {[float_almost_equal $b 0]} { |
|
set b 0 |
|
} |
|
} |
|
#must handle true,no etc. |
|
expr {($a && 1) == ($b && 1)} |
|
} |
|
|
|
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
|
proc boolean_equal {a b} { |
|
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
|
expr {($a && 1) == ($b && 1)} |
|
} |
|
|
|
|
|
proc val [list [list v [lreplace x 0 0]]] {return $v} |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::pipe ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::pipe::lib { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
tcl::namespace::path [tcl::namespace::parent] |
|
#*** !doctools |
|
#[subsection {Namespace punk::pipe::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 |
|
#} |
|
|
|
#map rhs to names suitable to use in pipemcd proc name (whitespace mapping) |
|
# (for .= and = pipecmds) |
|
proc pipecmd_namemapping {rhs} { |
|
#used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. |
|
#glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence |
|
#we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test |
|
#set rhs [string trim $rhs];#ignore all leading & trailing whitespace |
|
set rhs [string trimleft $rhs] |
|
#--- |
|
#REVIEW! |
|
#set rhs [regsub -all {\s{1,}} $rhs {<sp>}] ;#collapse all internal whitespace to a single <sp> token |
|
#This stops us matching {/@**@x x} vs {/@**@x x} |
|
#--- |
|
|
|
set rhs [tcl::string::map {: <c> ? <q> * <star> [ <lb> ] <rb> \\ <bsl> {"} <dq> " " <sp>} $rhs] |
|
#review - we don't expect other command-incompatible chars such as colon? |
|
return $rhs |
|
} |
|
|
|
# relatively slow on even small sized scripts |
|
#proc arg_is_script_shaped2 {arg} { |
|
# set re {^(\s|;|\n)$} |
|
# set chars [split $arg ""] |
|
# if {[lsearch -regex $chars $re] >=0} { |
|
# return 1 |
|
# } else { |
|
# return 0 |
|
# } |
|
#} |
|
|
|
#exclude quoted whitespace |
|
proc arg_is_script_shaped {arg} { |
|
if {[tcl::string::first \n $arg] >= 0} { |
|
return 1 |
|
} elseif {[tcl::string::first ";" $arg] >= 0} { |
|
return 1 |
|
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { |
|
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found |
|
return [expr {$part2 ne ""}] |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
#split top level of patterns only. |
|
proc _split_patterns_memoized {varspecs} { |
|
set name_mapped [pipecmd_namemapping $varspecs] |
|
set cmdname ::punk::pipecmds::split_patterns::_$name_mapped |
|
if {[info commands $cmdname] ne ""} { |
|
return [$cmdname] |
|
} |
|
set result [_split_patterns $varspecs] |
|
proc $cmdname {} [list return $result] |
|
#debug.punk.pipe.compile {proc $cmdname} 4 |
|
return $result |
|
} |
|
|
|
|
|
#note - empty data after trailing , is ignored. (comma as very last character) |
|
# - fix by documentation only. double up trailing comma e.g <pattern>,, if desired to return pattern match plus all at end! |
|
#todo - move to punk::pipe |
|
proc _split_patterns {varspecs} { |
|
|
|
set varlist [list] |
|
# @ @@ - list and dict functions |
|
# / level separator |
|
# # list count, ## dict size |
|
# % string functions |
|
# ! not |
|
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) |
|
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname |
|
|
|
#except when prefixed directly by pin classifier ^ |
|
set protect_terminals [list "^"] ;# e.g sequence ^# |
|
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
|
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
|
set in_brackets 0 ;#count depth |
|
set in_atom 0 |
|
set token "" |
|
set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section |
|
set token_index 0 ;#index of terminal char within each token |
|
set indq 0 |
|
set inbraces 0 |
|
set inesc 0 ;#whether last char was backslash (see also punk::escv) |
|
set prevc "" |
|
set char_index 0 |
|
#if {[string index $varspecs end] eq ","} { |
|
# set varspecs [string range $varspecs 0 end-1] |
|
#} |
|
set charcount 0 |
|
foreach c [split $varspecs ""] { |
|
incr charcount |
|
if {$indq} { |
|
if {$inesc} { |
|
#puts stderr "inesc adding '$c'" |
|
append token \\$c |
|
} else { |
|
if {$c eq {"}} { |
|
set indq 0 |
|
} else { |
|
append token $c |
|
} |
|
} |
|
} elseif {$inbraces} { |
|
if {$inesc} { |
|
append token \\$c |
|
} else { |
|
if {$c eq "\}"} { |
|
incr inbraces -1 |
|
if {$inbraces} { |
|
append token $c |
|
} |
|
} elseif {$c eq "\{"} { |
|
incr inbraces |
|
if {$inbraces} { |
|
append token $c |
|
} |
|
} else { |
|
append token $c |
|
} |
|
} |
|
} elseif {$in_atom} { |
|
#ignore dquotes/brackets in atoms - pass through |
|
append token $c |
|
#set nextc [lindex $chars $char_index+1] |
|
if {$c eq "'"} { |
|
set in_atom 0 |
|
} |
|
} elseif {$in_brackets > 0} { |
|
append token $c |
|
if {$c eq ")"} { |
|
incr in_brackets -1 |
|
} |
|
} else { |
|
if {$c eq {"}} { |
|
if {!$inesc} { |
|
set indq 1 |
|
} else { |
|
append token $c |
|
} |
|
} elseif {$c eq "\{"} { |
|
if {!$inesc} { |
|
set inbraces 1 |
|
} else { |
|
append token $c |
|
} |
|
} elseif {$c eq ","} { |
|
#set var $token |
|
#set spec "" |
|
#if {$end_var_posn > 0} { |
|
# #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
|
# #lassign [scan $token %${end_var_posn}s%s] var spec |
|
# set var [string range $token 0 $end_var_posn-1] |
|
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
|
#} else { |
|
# if {$end_var_posn == 0} { |
|
# set var "" |
|
# set spec $token |
|
# } |
|
#} |
|
#lappend varlist [list [string trim $var] [string trim $spec]] |
|
#set token "" |
|
#set token_index -1 ;#reduce by 1 because , not included in next token |
|
#set end_var_posn -1 |
|
} else { |
|
append token $c |
|
switch -exact -- $c { |
|
' { |
|
set in_atom 1 |
|
} |
|
( { |
|
incr in_brackets |
|
} |
|
default { |
|
if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
|
set end_var_posn $token_index |
|
} |
|
} |
|
} |
|
} |
|
if {$c eq ","} { |
|
set var $token |
|
set spec "" |
|
if {$end_var_posn > 0} { |
|
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
|
#lassign [scan $token %${end_var_posn}s%s] var spec |
|
#lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec |
|
set var [string range $token 0 $end_var_posn-1] |
|
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
|
} else { |
|
if {$end_var_posn == 0} { |
|
set var "" |
|
set spec $token |
|
} |
|
} |
|
lappend varlist [list [string trim $var] $spec] |
|
set token "" |
|
set token_index -1 |
|
set end_var_posn -1 |
|
|
|
} |
|
} |
|
|
|
if {$charcount == [string length $varspecs]} { |
|
if {!($indq || $inbraces || $in_atom || $in_brackets)} { |
|
if {$c ne ","} { |
|
set var $token |
|
set spec "" |
|
if {$end_var_posn > 0} { |
|
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
|
#lassign [scan $token %${end_var_posn}s%s] var spec |
|
set var [string range $token 0 $end_var_posn-1] |
|
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
|
} else { |
|
if {$end_var_posn == 0} { |
|
set var "" |
|
set spec $token |
|
} |
|
} |
|
lappend varlist [list [string trim $var] $spec] |
|
set token "" |
|
set token_index -1 |
|
set end_var_posn -1 |
|
} |
|
} |
|
} |
|
|
|
set prevc $c |
|
if {$c eq "\\"} { |
|
#review |
|
if {$inesc} { |
|
set inesc 0 |
|
} else { |
|
set token [string range $token 0 end-1] |
|
set inesc 1 |
|
} |
|
} else { |
|
set inesc 0 |
|
} |
|
incr token_index |
|
incr char_index |
|
} |
|
|
|
#if {[string length $token]} { |
|
# #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn] |
|
# set var $token |
|
# set spec "" |
|
# if {$end_var_posn > 0} { |
|
# #lassign [scan $token %${end_var_posn}s%s] var spec |
|
# set var [string range $token 0 $end_var_posn-1] |
|
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
|
# } else { |
|
# if {$end_var_posn == 0} { |
|
# set var "" |
|
# set spec $token |
|
# } |
|
# } |
|
# #lappend varlist [list [string trim $var] [string trim $spec]] |
|
# #spec needs to be able to match whitespace too |
|
# lappend varlist [list [string trim $var] $spec] |
|
#} |
|
|
|
return $varlist |
|
} |
|
|
|
#todo - consider whether we can use < for insertion/iteration combinations |
|
# =a<,b< iterate once through |
|
# =a><,b>< cartesian product |
|
# =a<>,b<> ??? zip ? |
|
# |
|
# ie = {a b c} |> .=< inspect |
|
# would call inspect 3 times, once for each argument |
|
# .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list |
|
# would produce list of cartesian pairs? |
|
# |
|
proc _split_equalsrhs {insertionpattern} { |
|
#map the insertionpattern so we can use faster globless info command search |
|
set name_mapped [pipecmd_namemapping $insertionpattern] |
|
set cmdname ::punk::pipecmds::split_rhs::_$name_mapped |
|
if {[info commands $cmdname] ne ""} { |
|
return [$cmdname] |
|
} |
|
|
|
set lst_var_indexposition [_split_patterns_memoized $insertionpattern] |
|
set i 0 |
|
set return_triples [list] |
|
foreach v_pos $lst_var_indexposition { |
|
lassign $v_pos v index_and_position |
|
#e.g varname@@data/ok>0 varname/1/0>end |
|
#ensure only one ">" is detected |
|
if {![string length $index_and_position]} { |
|
set indexspec "" |
|
set positionspec "" |
|
} else { |
|
set chars [split $index_and_position ""] |
|
set posns [lsearch -all $chars ">"] |
|
if {[llength $posns] > 1} { |
|
error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
|
} |
|
if {![llength $posns]} { |
|
set indexspec $index_and_position |
|
set positionspec "" |
|
} else { |
|
set splitposn [lindex $posns 0] |
|
set indexspec [string range $index_and_position 0 $splitposn-1] |
|
set positionspec [string range $index_and_position $splitposn+1 end] |
|
} |
|
} |
|
|
|
#review - |
|
if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { |
|
set star "" |
|
if {$v eq "*"} { |
|
set v "" |
|
set star "*" |
|
} |
|
if {[string index $positionspec end] eq "*"} { |
|
set star "*" |
|
} |
|
#it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent |
|
#as are /end and @end |
|
#lset lst_var_indexposition $i [list $v "/end$star"] |
|
set triple [list $v $indexspec "/end$star"] |
|
} else { |
|
if {$positionspec eq ""} { |
|
#e.g just =varname |
|
#lset lst_var_indexposition $i [list $v "/end"] |
|
set triple [list $v $indexspec "/end"] |
|
#error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" |
|
} else { |
|
if {[string index $indexspec 0] ni [list "" "/" "@"]} { |
|
error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
|
} |
|
set triple [list $v $indexspec $positionspec] |
|
} |
|
} |
|
lappend return_triples $triple |
|
incr i |
|
} |
|
proc $cmdname {} [list return $return_triples] |
|
return $return_triples |
|
} |
|
|
|
proc _rhs_tail_split {fullrhs} { |
|
set inq 0; set indq 0 |
|
set equalsrhs "" |
|
set i 0 |
|
foreach ch [split $fullrhs ""] { |
|
if {$inq} { |
|
append equalsrhs $ch |
|
if {$ch eq {'}} { |
|
set inq 0 |
|
} |
|
} elseif {$indq} { |
|
append equalsrhs $ch |
|
if {$ch eq {"}} { |
|
set indq 0 |
|
} |
|
} else { |
|
switch -- $ch { |
|
{'} { |
|
set inq 1 |
|
} |
|
{"} { |
|
set indq 1 |
|
} |
|
" " { |
|
#whitespace outside of quoting |
|
break |
|
} |
|
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z {} |
|
default { |
|
#\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to <t> (and without a literal binary tab in source file)? |
|
#we can't (reliably?) put \t as one of our switch keys |
|
# |
|
if {$ch eq "\t"} { |
|
break |
|
} |
|
} |
|
} |
|
append equalsrhs $ch |
|
} |
|
incr i |
|
} |
|
set tail [tcl::string::range $fullrhs $i end] |
|
return [list $equalsrhs $tail] |
|
} |
|
|
|
#todo - recurse into bracketed sub parts |
|
#JMN3 |
|
#e.g @*/(x@0,y@2) |
|
proc _var_classify {multivar} { |
|
set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] |
|
if {[info commands $cmdname] ne ""} { |
|
return [$cmdname] |
|
} |
|
|
|
|
|
#comma seems a natural choice to split varspecs, |
|
#but also for list and dict subelement access |
|
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
|
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
|
#set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] |
|
set valsource_key_list [_split_patterns_memoized $multivar] |
|
|
|
|
|
|
|
#mutually exclusive - atom/pin |
|
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
|
#set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
|
#0 - novar |
|
#1 - atom ' |
|
#2 - pin ^ |
|
#3 - boolean & |
|
#4 - integer |
|
#5 - double |
|
#6 - var |
|
#7 - glob (no classifier and contains * or ?) |
|
#8 - numeric |
|
#9 - > (+) |
|
#10 - < (-) |
|
|
|
set var_names [list] |
|
set var_class [list] |
|
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob |
|
|
|
|
|
set leading_classifiers [list "'" "&" "^" ] |
|
set trailing_classifiers [list + -] |
|
set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] |
|
|
|
foreach v_key $valsource_key_list { |
|
lassign $v_key v key |
|
set vname $v ;#default |
|
set classes [list] |
|
if {$v eq ""} { |
|
lappend var_class [list $v_key 0] |
|
lappend varspecs_trimmed $v_key |
|
} else { |
|
set lastchar [string index $v end] |
|
switch -- $lastchar { |
|
+ { |
|
lappend classes 9 |
|
set vname [string range $v 0 end-1] |
|
} |
|
- { |
|
lappend classes 10 |
|
set vname [string range $v 0 end-1] |
|
} |
|
} |
|
set firstchar [string index $v 0] |
|
switch -- $firstchar { |
|
' { |
|
lappend var_class [list $v_key 1] |
|
#set vname [string range $v 1 end] |
|
lappend varspecs_trimmed [list $vname $key] |
|
} |
|
^ { |
|
lappend classes [list 2] |
|
#use vname - may already have trailing +/- stripped |
|
set vname [string range $vname 1 end] |
|
set secondclassifier [string index $v 1] |
|
switch -- $secondclassifier { |
|
"&" { |
|
#pinned boolean |
|
lappend classes 3 |
|
set vname [string range $v 2 end] |
|
} |
|
"#" { |
|
#pinned numeric comparison instead of string comparison |
|
#e.g set x 2 |
|
# this should match: ^#x.= list 2.0 |
|
lappend classes 8 |
|
set vname [string range $vname 1 end] |
|
} |
|
"*" { |
|
#pinned glob |
|
lappend classes 7 |
|
set vname [string range $v 2 end] |
|
} |
|
} |
|
#todo - check for second tag - & for pinned boolean? |
|
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
|
#while we're at it.. pinned glob would be nice. ^* |
|
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
|
#These all limit the range of varnames permissible - which is no big deal. |
|
lappend var_class [list $v_key $classes] |
|
lappend varspecs_trimmed [list $vname $key] |
|
} |
|
& { |
|
#we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. |
|
#ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans |
|
#allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. |
|
lappend var_class [list $v_key 3] |
|
set vname [string range $v 1 end] |
|
lappend varspecs_trimmed [list $vname $key] |
|
} |
|
default { |
|
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
|
lappend var_class [list $v_key 7] ;#glob |
|
#leave vname as the full glob |
|
lappend varspecs_trimmed [list "" $key] |
|
} else { |
|
#scan vname not v - will either be same as v - or possibly stripped of trailing +/- |
|
set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 |
|
#leading . still need to test directly for double |
|
if {[string is double -strict $vname] || [string is double -strict $numtestv]} { |
|
if {[string is integer -strict $numtestv]} { |
|
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
|
#integer test before double.. |
|
#note there is also string is wide (string is wideinteger) for larger ints.. |
|
lappend classes 4 |
|
lappend var_class [list $v_key $classes] |
|
lappend varspecs_trimmed $v_key |
|
} else { |
|
#double |
|
#sci notation 1e123 etc |
|
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
|
lappend classes 5 |
|
lappend var_class [list $v_key $classes] |
|
lappend varspecs_trimmed $v_key |
|
} |
|
} else { |
|
lappend var_class [list $v_key 6] ;#var |
|
lappend varspecs_trimmed $v_key |
|
} |
|
} |
|
} |
|
} |
|
} |
|
lappend var_names $vname |
|
} |
|
|
|
set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] |
|
|
|
proc $cmdname {} [list return $result] |
|
#JMN |
|
#debug.punk.pipe.compile {proc $cmdname} |
|
return $result |
|
} |
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# == === === === === === === === === === === === === === === |
|
# Sample 'about' function with punk::args documentation |
|
# == === === === === === === === === === === === === === === |
|
tcl::namespace::eval punk::pipe { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
variable PUNKARGS |
|
variable PUNKARGS_aliases |
|
|
|
lappend PUNKARGS [list { |
|
@id -id "(package)punk::pipe" |
|
@package -name "punk::pipe" -help\ |
|
"Package |
|
Description" |
|
}] |
|
|
|
namespace eval argdoc { |
|
#namespace for custom argument documentation |
|
proc package_name {} { |
|
return punk::pipe |
|
} |
|
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] |
|
} |
|
return $about_topics |
|
} |
|
proc default_topics {} {return [list Description outline *]} |
|
|
|
# ------------------------------------------------------------- |
|
# get_topic_ functions add more to auto-include in about topics |
|
# ------------------------------------------------------------- |
|
proc get_topic_Description {} { |
|
punk::args::lib::tstr [string trim { |
|
punk pipeline features |
|
} \n] |
|
} |
|
proc get_topic_License {} { |
|
return "MIT" |
|
} |
|
proc get_topic_Version {} { |
|
return $::punk::pipe::version |
|
} |
|
proc get_topic_Contributors {} { |
|
set authors {{Julian Noble <julian@precisium.com.au>}} |
|
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_outline {} { |
|
punk::args::lib::tstr -return string { |
|
todo.. |
|
} |
|
} |
|
# ------------------------------------------------------------- |
|
} |
|
|
|
# we re-use the argument definition from punk::args::standard_about and override some items |
|
set overrides [dict create] |
|
dict set overrides @id -id "::punk::pipe::about" |
|
dict set overrides @cmd -name "punk::pipe::about" |
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
|
About punk::pipe |
|
}] \n] |
|
dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] |
|
dict set overrides topic -choicerestricted 1 |
|
dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
|
lappend PUNKARGS [list $newdef] |
|
proc about {args} { |
|
package require punk::args |
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
|
set argd [punk::args::parse $args withid ::punk::pipe::about] |
|
lassign [dict values $argd] _leaders opts values _received |
|
punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] |
|
} |
|
} |
|
# end of sample 'about' function |
|
# == === === === === === === === === === === === === === === |
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::pipe |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::pipe [tcl::namespace::eval punk::pipe { |
|
variable pkg punk::pipe |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|