diff --git a/scriptlib/error.tcl b/scriptlib/error.tcl index d890ca9..f26d17f 100644 --- a/scriptlib/error.tcl +++ b/scriptlib/error.tcl @@ -1,5 +1,7 @@ puts stdout "1 (stdout) test of error in scriptlib tcl script" -puts stderr "2 (stderr) error line will be run next - followed by a dashed line on stdout" +puts stderr "2 (stderr) error line will be run next" error "This is the error" + +#should be unreachable puts stdout "-----------------------------" diff --git a/scriptlib/hello.tcl b/scriptlib/hello.tcl index 883fba1..40b7243 100644 --- a/scriptlib/hello.tcl +++ b/scriptlib/hello.tcl @@ -12,6 +12,6 @@ puts -nonewline stderr "5 hello on stderr no line-ending" flush stderr puts -nonewline stdout "6 hello on stdout no line-ending" flush stdout - +set ::tcl_interactive 1 diff --git a/scriptlib/scriptinfo b/scriptlib/scriptinfo new file mode 100644 index 0000000..665e897 --- /dev/null +++ b/scriptlib/scriptinfo @@ -0,0 +1,20 @@ +# tcl - commented line with 'tcl' as indicator this is a tcl script. A standard shebang line would also work. + +puts stderr "info script: [info script]" + +apply {{self} { + set selfdir [file dirname $self] + puts stderr "selfdir: $selfdir" + source $selfdir/scriptinfo2 + + #if {[file exists $selfdir/kettle.tcl]} { + ## Look for a local copy first, for when we install ourselves. + #source $selfdir/kettle.tcl + #} else { + ## use the installed core. + #package require kettle + #} + + +}} [file dirname [file normalize [info script]/__]] + diff --git a/scriptlib/scriptinfo2 b/scriptlib/scriptinfo2 new file mode 100644 index 0000000..9a3bd37 --- /dev/null +++ b/scriptlib/scriptinfo2 @@ -0,0 +1,6 @@ +# tcl - commented line with 'tcl' as indicator this is a tcl script. A standard shebang line would also work. + +puts stderr "scriptinfo2 info script: [info script]" +puts stderr "scriptinfo2 argc: $::argc" +puts stderr "scriptinfo2 argv: $::argv" +puts stderr "scriptinfo2 argv0: $::argv0" diff --git a/scriptlib/stdout_per_second.tcl b/scriptlib/stdout_per_second.tcl index 0c31c3e..68d1990 100644 --- a/scriptlib/stdout_per_second.tcl +++ b/scriptlib/stdout_per_second.tcl @@ -1,78 +1,78 @@ - -if {$::argc >= 1} { - set persec [lindex $::argv 0] -} else { - set persec 1 -} -if {$::argc == 2} { - set what [lindex $::argv 1] -} else { - set what "." -} - -if {$persec > 1000} { - puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed" - flush stderr - after 500 -} -#--- confg --- -set newline_every_x_seconds 5 -#--- -chan configure stdout -blocking 1 -buffering none -set counter 0 -set ms [expr {1000 / $persec}] -set nl_every [expr {$persec * $newline_every_x_seconds}] - -proc schedule {} { - if {$::forever_stdout_per_second} { - after idle [list after 0 ::emit] - tailcall after $::ms ::schedule - } else { - after idle [list ::the_end] - } -} - -set ::forever_stdout_per_second 1 - -proc the_end {} { - puts stderr "-done-" - flush stderr - flush stdout - set ::done_stdout_per_second 1 -} - -proc emit {} { - upvar ::counter c - if {($c > 1) && (($c % $::nl_every) == 0)} { - puts -nonewline stdout " " - flush stdout - puts stderr $c - flush stderr - } else { - puts -nonewline stdout $::what - } - #flush stdout - incr c -} -chan configure stdin -blocking 0 -buffering none -chan event stdin readable [list apply {{chan} { - set chunk [chan read $chan] - if {[string length $chunk]} { - if {[string match "*q*" [string tolower $chunk]]} { - set ::forever_stdout_per_second 0 - chan event $chan readable {} - puts stderr "cancelling" - } - } - if {[chan eof $chan]} { - chan event $chan readable {} - } -}} stdin] - -schedule -vwait ::forever_stdout_per_second - -vwait ::done_stdout_per_second - - - + +if {$::argc >= 1} { + set persec [lindex $::argv 0] +} else { + set persec 1 +} +if {$::argc == 2} { + set what [lindex $::argv 1] +} else { + set what "." +} + +if {$persec > 1000} { + puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed" + flush stderr + after 500 +} +#--- confg --- +set newline_every_x_seconds 5 +#--- +chan configure stdout -blocking 1 -buffering none +set counter 0 +set ms [expr {1000 / $persec}] +set nl_every [expr {$persec * $newline_every_x_seconds}] + +proc schedule {} { + if {$::forever_stdout_per_second} { + after idle [list after 0 ::emit] + tailcall after $::ms ::schedule + } else { + after idle [list ::the_end] + } +} + +set ::forever_stdout_per_second 1 + +proc the_end {} { + puts stderr "-done-" + flush stderr + flush stdout + set ::done_stdout_per_second 1 +} + +proc emit {} { + upvar ::counter c + if {($c > 1) && (($c % $::nl_every) == 0)} { + puts -nonewline stdout " " + flush stdout + puts stderr $c + flush stderr + } else { + puts -nonewline stdout $::what + } + #flush stdout + incr c +} +chan configure stdin -blocking 0 -buffering none +chan event stdin readable [list apply {{chan} { + set chunk [chan read $chan] + if {[string length $chunk]} { + if {[string match "*q*" [string tolower $chunk]]} { + set ::forever_stdout_per_second 0 + chan event $chan readable {} + puts stderr "cancelling" + } + } + if {[chan eof $chan]} { + chan event $chan readable {} + } +}} stdin] + +schedule +vwait ::forever_stdout_per_second + +vwait ::done_stdout_per_second + + + diff --git a/scriptlib/tests/block_padleft.tcl b/scriptlib/tests/block_padleft.tcl index e71c372..c892104 100644 --- a/scriptlib/tests/block_padleft.tcl +++ b/scriptlib/tests/block_padleft.tcl @@ -7,3 +7,11 @@ puts stdout "block_padleft pipeline" puts stdout "[alias block_padleft]" puts stderr "block_padleft \[>punk . logo] 50" puts stdout "[block_padleft [>punk . logo] 50]" + + +package require overtype +set out "" +foreach ln [.= block_padleft [>punk . logo ] 2 |> linelist] bgline [.= block_padleft [>punk . logo] 100 |> linelist] { + append out [overtype::left $bgline [a+ green bold]$ln[a+]]\n +} +puts stdout "$out" \ No newline at end of file diff --git a/scriptlib/tests/codewars_cola.tcl b/scriptlib/tests/codewars_cola.tcl new file mode 100644 index 0000000..3e683b4 --- /dev/null +++ b/scriptlib/tests/codewars_cola.tcl @@ -0,0 +1,95 @@ + +#naive - literal approach to the problem via a form of simulation (as attempted in https://www.youtube.com/watch?v=7fylNa2wZaU) +#the proper solution is of course just a little bit of maths - but the list-manipulation is an interesting exercise. + +proc collapse lst { + #puts stdout "lst:'$lst' len:[llength $lst]" + foreach i $lst { + #puts stderr "'$i len:[llength $i] len-el0:[llength [lindex $i 0]]'" + if {[llength $i] == 2 && [llength [lindex $i 0]] ==2} { + lappend out [list [list [lindex $i 0 0] [expr {[lindex $i 0 1] + [lindex $i 1 1]}] ] ] + } else { + lappend out $i + } + } + return $out +} + +#.=* list |h/0,t/tail> .=t>1*,h>end,h>end list |> punk::group_list_by {[lindex $item 0]} |> inspect |> .= collapse } .=t>1*,h>end,h>end list {| + data2, + nplus@end/1 + >} {expr {$nsofar + $nplus}} {| + nsofar + >} {set data2} {| + + >} punk::group_list_by {[lindex $item 0]} {| + + >} .= collapse {| + + >} .=>2 lmap v {lindex $v 0} {| + >} .=nsofar>1,n>2,data>end* list } .=>. {set in $data; while {$i < $n } { + #puts stdout "$i < $n" + #puts stdout "drinkx $in" + set in [drinkx {*}$in] + lassign $in i n + }; set in} {| + >} inspect -channel null {| + + result/end + >} {set result} peopleInLine) { + r -= peopleInLine; + copiesOfEachPerson *= 2; + peopleInLine *= 2; + } + + return names[Math.floor((r - 1) / copiesOfEachPerson) % peopleInLine]; + } +} + +proc who_is_next {names n} { + set peopleInLine [llength $names] + set copiesOfEachPerson 1 + while {$n > $peopleInLine} { + set n [expr {$n - $peopleInLine}] + set copiesOfEachPerson [expr {$copiesOfEachPerson * 2}] + set peopleInLine [expr {$peopleInLine * 2}] + } + set idx [expr {int(floor(($n -1)/$copiesOfEachPerson)) % $peopleInLine}] + #puts "idx:$idx names: $names" + set result [lindex $names $idx] +} + + + diff --git a/scriptlib/tests/first_assign.tcl b/scriptlib/tests/first_assign.tcl index a6d7d67..9e7b8c1 100644 --- a/scriptlib/tests/first_assign.tcl +++ b/scriptlib/tests/first_assign.tcl @@ -1,4 +1,6 @@ #experiment with the dangers of substitution in the first position after = in pipelines +puts stderr "Relevant for consideration if attempting to build pipelines parametrically" + puts stdout {set i {"a b "}} set i {"a b "} @@ -12,3 +14,7 @@ puts stderr "% x=\$i -> $errm" #%x="a b " +#however.. this is no different from the risk in normal tcl usage +# e.g lindex x$i 0 + + diff --git a/scriptlib/tests/fun.tcl b/scriptlib/tests/fun.tcl index 03eb4ab..3f2ce4b 100644 --- a/scriptlib/tests/fun.tcl +++ b/scriptlib/tests/fun.tcl @@ -253,11 +253,15 @@ proc pipefun::fun {name argspec body} { #set case [list pipecase ,$a= |$a> .= $b <|] - append case { {*}$switchargs} #we can't maintain case as a proper list.. because it isn't. (contains {*}$xxx) append pipecases $case\n } + set casenomatch [string map [list $name] {pipecase .= {error "casenomatch fun: args: $args" "pipefun::fun " {casenomatch unhandled_args}} $switchresult" - if {[ispipematch r@@error/mismatch.= val $switchresult]} { + if {[ispipematch r@@casemismatch.= val $switchresult]} { #all good - simulate an @@error/mismatch - or raise an 'ignore' error so that this implementation is considered to be unmatched and we fall through to others. #puts stdout "=ispipematch true" error [list ignore [list argcheck passed]] diff --git a/scriptlib/tests/functional/divisible_sum_pairs.tcl b/scriptlib/tests/functional/divisible_sum_pairs.tcl new file mode 100644 index 0000000..842f43e --- /dev/null +++ b/scriptlib/tests/functional/divisible_sum_pairs.tcl @@ -0,0 +1,37 @@ + + + +set ints [list 1 2 3 4 5 6] +set k 5 + +cartesianpairs1.= {foreach i $ints {foreach j $ints {lappend out [list $i $j]}}; set out} \ +{inspect -label K= $k} |> \ +.= {foreach i $ints {foreach j $ints {lappend out [list $i $j]}}; set out} |> \ +list_filter_cond { = $item |a/0,b/1> .= {expr $b > $a}} |> \ +{list_filter_cond { .= list $item $k |a/0/0,b/0/1,k/1> \ +.= {expr {($a + $b) % $k == 0} }} $data } . {inspect "$h|$t"} |> {list $h [list lazy $name $t]} |r,fn/1> {upvar $name nm; pipeset nm .= {*}$fn} |> {lindex $r 0} . {list $h [list lazy $name $t]} |r,fn/1> {upvar $name nm; pipeset nm .= {*}$fn} |> {lindex $r 0} 0 |a/0/0,b/0/1,c/0/2> {list $a $b [list init {*}$c]} |> .=* |> inspect |h> {pipealias $name .= eval \$$name} |> {set name} {upvar $name nm; pipeset nm .= {*}$fn} |> {set h} \ + .= val $pipeargs |argd> inspect -channel null |>\ 1.= { dict exists $argd -author } { @@ -139,7 +139,7 @@ pipeset htmldoc .= list "julian@precisium.com.au" "info@precisium.com" |email_ pipecase .= val "Author: unknown" |> div [attrs hidden hidden] - } |> p [attrs] |> footer [attrs] + } |> inspect -channel null -label argd |> p [attrs] |> footer [attrs] #puts "author: $author" @@ -215,5 +215,5 @@ proc make_script {pipeline} { proc run_pipe {pipeline} { funcl::funcl_script_test [make_script $pipeline] } - +puts stdout "created pipeline in variable htmldoc" diff --git a/scriptlib/tests/listbuilder.tcl b/scriptlib/tests/listbuilder.tcl index 56302dd..7fd1a96 100644 --- a/scriptlib/tests/listbuilder.tcl +++ b/scriptlib/tests/listbuilder.tcl @@ -101,7 +101,7 @@ pipeset commentpipe normallist.= rawlist/0.= { } { #more comments - but we need to pass the pipeline data through here - so 'set data' required at end. set data -} |> string trim |> linelist |> .=/2 lmap v {string trim $v} +} |> string trim |> linelist |> .=>2 lmap v {string trim $v} pipeputs $commentpipe {*}$commentpipe @@ -111,14 +111,14 @@ puts stdout "normallist:$normallist" puts stderr $sep -pipeset pipe2 alt.= = $rawlist |> .=/1 lrange 0 end +pipeset pipe2 alt.= = $rawlist |> .=>1 lrange 0 end puts stdout "Alternative interpretation of list data" puts stdout "pipe2:" pipeputs $pipe2 {*}$pipe2 puts stdout "alt: $alt" -pipeset pipe3 alt.= = $rawlist |> .=* list +pipeset pipe3 alt.= = $rawlist |> .=>* list puts stdout "Or.." puts stdout "pipe3:" pipeputs $pipe3 diff --git a/scriptlib/tests/nameservers.tcl b/scriptlib/tests/nameservers.tcl index aee4573..f8349aa 100644 --- a/scriptlib/tests/nameservers.tcl +++ b/scriptlib/tests/nameservers.tcl @@ -7,12 +7,12 @@ proc pipe_webpub {} { pipeset subpipe % .= { pipeswitch { pipecase \ - .= val [lindex $switchargs 0] \ - |> {string trimright $data .} |server> {split $data .} \ - |> 'webpub.net'.= { + .= val [lindex $switchargs 0] {| + >} {string trimright $data .} |server> {split $data .} {| + >} 'webpub.net'.= { join [lrange $data 1 2] . - } \ - |> { + } {| + >} { list type internal server $server } diff --git a/scriptlib/tests/parser.tcl b/scriptlib/tests/parser.tcl new file mode 100644 index 0000000..8c3378e --- /dev/null +++ b/scriptlib/tests/parser.tcl @@ -0,0 +1,64 @@ + + + +proc p_digit str { + if {[string is digit -strict [string index $str 0]]} { + return [list [string index $str 0] [string range $str 1 end]] + } else { + return [list] + } +} + +proc p_char {str ch} { + if {[string index $str 0] eq $ch} { + return [list [string index $str 0] [string range $str 1 end]] + } else { + return [list] + } +} + +proc parser_of_char {ch} { + pipeset outparser @@ok/result.= { + pipeswitch { + pipecase .= list $input $ch |data/0,char/1> \ + ,'${ch}'@0.= {p_char $data $char} + + return [list ok [list result [list]]] + } + } \ + ,'result'@@ok/@0.= { + .= list $pipe $input |p@,i@> {{*}$p $i} + } |result@@ok/result> =result>1/1 + + return nothing-functor + } + } $input" + pipecase = $input |> \ + ,'${ch}'@0.= {list [string index $data 0] [string range $data 1 end] } |> { + set data + } + return nothing + } + } { - .= lrange $data 1 end-1 |>\ - b.= string toupper + .= lrange $data 1 end-1 {| + + >} b.= string toupper puts stdout "==================================" puts stdout "info vars: [info vars]" diff --git a/scriptlib/tests/pipeswitch.tcl b/scriptlib/tests/pipeswitch.tcl index ef35576..3ac0e32 100644 --- a/scriptlib/tests/pipeswitch.tcl +++ b/scriptlib/tests/pipeswitch.tcl @@ -64,7 +64,9 @@ proc match_args {args} { return [list source pipecase3 data [list transformed {*}$data]] } - pipecase .= val $args |> { + pipecase .= val $args {| + + >} { puts "catchall pipe4 $data" return $data } diff --git a/scriptlib/tests/wanted.tcl b/scriptlib/tests/wanted.tcl index 252d69a..d5c3f81 100644 --- a/scriptlib/tests/wanted.tcl +++ b/scriptlib/tests/wanted.tcl @@ -2,17 +2,17 @@ # this should run 'list a b c tail' catch { -% x.=/0* tail |> {puts $data;set data} 0* tail |> inspect {puts $data;set data} string toupper +% x.=>0* |> inspect string toupper #but then what would happen if the args pipeline also took input via another <| ? -#% x.=/0* |> {puts $data;set data} * |> inspect {puts $data; set data} |p1/0> .= { {*}$p1 } |> {puts $data;set data} string toupper] +% out= x= |> inspect |p1/0> .= { {*}$p1 } |> inspect string toupper]