#! /bin/env tclsh
package require {ycl ns}
namespace import [yclprefix]::ns::powerimport
package require {ycl parse tcl}
namespace import [yclprefix]::parse::tcl::wordparts
package require {ycl proc step}
namespace import [yclprefix]::proc::step::pre
namespace import [yclprefix]::proc::step::stepconfig
namespace import [yclprefix]::proc::step::stepexpr
namespace import [yclprefix]::proc::step::stepscript
namespace import [yclprefix]::proc::step::wrap
apply [list {subsume ns} {
${ns}::foreach name $subsume {
set subcmds [lassign $name[set name {}] name]
${ns}::interp alias {} [
${ns}::namespace current]::$name {} ${ns}::$name
}
} [namespace current]] [set [namespace parent]::subsume] [namespace parent]
#todo: override created interps such that [myinterp eval ...] is also wrapped
proc wrap_after {wrapped name args} {
pre
set script [string map [
list @wrapped@ [list $wrapped] @config@ [
list $config] @stepscript@ [list [namespace which stepscript]]] {
::switch -glob [lindex $args 0] {
ca* {
if {[llength $args] > 2} {
lassign [@stepscript@ [join [lrange $args 1 end] { }] \
@config@] infoname newscript
set args [list {*}[lrange $args[set args {}] 0 1] $newscript]
}
}
id* {
lassign [@stepscript@ [join [
lrange $args 1 end] { }] @config@] infoname newargs
set args [list [lindex $args[set args {}] 0] $newargs]
}
inf* {
}
default {
set args [lassign $args[set args {}] subcmd ms]
if {[llength $args]} {
lassign [@stepscript@ [join $args[
set args {}] { }] @config@] infoname newargs
set args [list $subcmd $ms $newargs]
} else {
set args [list $subcmd $ms]
}
}
}
::tailcall @wrapped@ {*}$args
}]
proc $name args $script
}
proc wrap_catch {wrapped name args} {
tailcall wrap $wrapped $name [list indices 0] {*}$args
}
proc wrap_chan_event {wrapped name args} {
pre
tailcall wrap $wrapped $name [list indices 2] {*}$args
}
proc wrap_dict_for {wrapped name args} {
pre
tailcall wrap $wrapped $name [list indices 2] {*}$args
}
proc wrap_dict_map {wrapped name args} {
tailcall wrap $wrapped $name [list indices end] {*}$args
}
proc wrap_dict_update {wrapped name args} {
tailcall wrap $wrapped $name [list indices end] {*}$args
}
proc wrap_dict_with {wrapped name args} {
tailcall wrap $wrapped $name [list indices end] {*}$args
}
proc wrap_expr {wrapped name args} {
pre
set body [string map [list \
@config@ [list $config] \
@tailcall@ [list [namespace which tailcall]] \
@stepexpr@ [list [namespace which stepexpr]] \
@wrapped@ [list $wrapped] \
] {
lassign [@stepexpr@ 0 [join $args { }] @config@ {}] info expr
@tailcall@ @wrapped@ $expr
}]
tailcall proc $name args $body]
}
proc wrap_eval {wrapped name args} {
pre
tailcall wrap $wrapped $name [list indices args] {*}$args
}
proc wrap_for {wrapped name args} {
pre
tailcall wrap $wrapped $name [list indices {0 2 3} eindices 1] {*}$args
}
proc wrap_foreach {wrapped name args} {
tailcall wrap $wrapped $name [list indices end] {*}$args
}
proc wrap_history_add {wrapped name args} {
pre
set script [string map [
list @wrapped@ [list $wrapped] @config@ [
list $config] @stepscript@ [list [namespace which stepscript]]] {
lassign [@stepscript@ [lindex $args 0] @config@] info newscript
set args [lreplace $args 0 0 $newscript]
::tailcall @wrapped@ add {*}$args
}]
proc $name args $script
}
proc wrap_if {wrapped name args} {
pre
set body [string map [list \
@config@ [list $config] \
@expr@ [list [namespace which expr]] \
@for@ [list [namespace which for]] \
@if@ [list [namespace which if]] \
@stepexpr@ [list [namespace which stepexpr]] \
@stepscript@ [list [namespace which stepscript]] \
@switch@ [list [namespace which switch]] \
] {
lassign [@stepscript@ [lindex $args end] @config@] infoname newbody
set args [lreplace $args[set args {}] end end $newbody]
set last [@expr@ {[llength $args]-1}]
set state elseif
@for@ {set i 0} {$i < $last} {incr i} {
set arg [lindex $args $i]
@switch@ $state {
then {
@switch@ $arg {then continue}
lassign [@stepscript@ $arg @config@] infoname newbody
set args [lreplace $args[set args {}] $i $i $newbody]
set state elseif
}
elseif {
@switch@ $arg {else break}
@if@ {$arg eq {elseif}} continue
lassign [@stepexpr@ 0 $arg @config@ {}] infoname newbody
set args [lreplace $args[set args {}] $i $i $newbody]
set state then
}
}
}
::tailcall @wrapped@ {*}$args
}]
tailcall wrap $wrapped $name [list body $body] {*}$args
}
proc wrap_info {wrapped name args} {
pre
}
proc wrap_interp_eval {wrapped name args} {
pre
set script [string map [
list @wrapped@ [list $wrapped] @config@ [
list $config] @stepscript@ [list [namespace which stepscript]]] {
set args [lassign $args[set args {}] arg1]
lassign [@stepscript@ [join $args[set args {}] { }] @config@] \
infoname newscript
set args [list $arg1 $newscript]
::tailcall @wrapped@ eval {*}$args
}]
proc $name args $script
}
proc wrap_lmap {wrapped name args} {
tailcall wrap $wrapped $name [list indices end] {*}$args
}
proc wrap_namespace_eval {wrapped name args} {
pre
set script [string map [
list @wrapped@ [list $wrapped] @config@ [
list $config] @stepscript@ [list [namespace which stepscript]]] {
set first [lindex $args 0]
lassign [@stepscript@ [join [lrange $args[set args {}] 1 end] { }] @config@] \
infoname newscript
set args [list $first $newscript]
::tailcall @wrapped@ {*}$args
}]
proc $name args $script
}
proc wrap_source {wrapped name args} {
pre
set script [string map [list \
@config@ [list $config] \
@stepscript@ [list [namespace which stepscript]] \
@uplevel_orig@ [list [namespace which uplevel]]
] {
if {[lindex $args 0] eq {-encoding}} {
set chan [open [lindex $args 2]]
chan configure $chan -encoding [lindex $args 1]
} else {
set chan [open [lindex $args 0]]
}
lassign [@stepscript@ [read $chan] @config@] infoname script
close $chan
@uplevel_orig@ 1 $script
}]
proc $name args $script
}
proc wrap_subst {wrapped name args} {
pre
set script [string map [list \
@config@ [list $config] \
@wrapped@ [list $wrapped] \
@stepscript@ [list [namespace which stepscript]] \
@wordparts@ [list [namespace which wordparts]]
] {
set whack 1
set vars 1
set commands 1
foreach arg $args {
if {[string first $arg -nobackslashes] == 0} {
set whack 0
} elseif {[string first $arg -nocommands] == 0} {
set commands 0
} elseif {[string first $arg -novariables] == 0} {
set vars 0
} else {
break
}
}
if {[llength $args] != 1} {
#let the real commmand handle the invalid arguments
::tailcall @wrapped@ {*}$args
}
set newstring {}
foreach part [
@wordparts@ $arg commands $commands vars $vars whack $whack] {
if {[string match {$?*} $part] && $vars} {
lassign [@stepscript@ $part @config@] infoname newpart
if {$part ne $newpart} {
append newstring "\[$newpart\]"
} else {
append newstring $part
}
} elseif {[string match {\[*]} $part] && $commands} {
lassign [@stepscript@ [string range $part 1 end-1] @config@] \
infoname newscript
append newstring "\[$newscript\]"
} else {
append newstring $part
}
}
set args [lreplace $args[set args {}] end end $newstring]
::tailcall @wrapped@ {*}$args
}]
proc $name args $script
}
proc wrap_switch {wrapped name args} {
pre
set script [string map [list \
@config@ [list $config] \
@foreach@ [list [namespace which foreach]] \
@if@ [list [namespace which if]] \
@wrapped@ [list $wrapped] \
@stepscript@ [list [namespace which stepscript]] \
] {
set i 0
@foreach@ arg $args {
@if@ {$arg eq {--}} {
incr i
break
} elseif {[string match -* $arg]} {
continue
} else {
break
}
incr i
}
#at this point, $i is the index of the first ''pattern''
set opts [lrange $args 0 $i]
set args [lrange $args $i+1 end]
@if@ {[llength $args] == 1} {
set args [lindex $args[set args {}] 0]
}
@foreach@ {pattern body} $args[set args {}] {
lassign [@stepscript@ $body @config@] infoname newscript
lappend args $pattern $newscript
}
::tailcall @wrapped@ {*}$opts {*}$args
}]
proc $name args $script
}
proc wrap_time {wrapped name args} {
pre
tailcall wrap $wrapped $name [list indices 0] {*}$args
}
proc wrap_try {wrapped name args} {
pre
set script [string map [
list @wrapped@ [list $wrapped] @config@ [
list $config] @stepscript@ [list [namespace which stepscript]]] {
lassign [@stepscript@ [lindex $args 0] @config@] infoname newscript
set args [lreplace $args 0 0 $newscript]
set stat {}
set finally 0
set i 0
foreach arg [lrange $args 1 end] {
incr i
switch $arg {
on - trap {
incr i 3
lassign [@stepscript@ [lindex $args $i] @config@] \
infoname newscript
set args [lreplace $args[set args {}] $i $i $newscript]
}
finally {
incr i
lassign [@stepscript@ [lindex $args $i] @config@] infoname newscript
set args [lreplace $args[set args {}] $i $i $newscript]
}
default break
}
}
::tailcall @wrapped@ {*}$args
}]
proc $name args $script
}
proc wrap_uplevel {wrapped name args} {
pre
set script [string map [list \
@config@ [list $config] \
@wrapped@ [list $wrapped] \
@stepscript@ [list [namespace which stepscript]]] {
if {[string is digit [lindex $args 0]] || (
[regexp {#[[:digit:]]+\s} [lindex $args 0]])} {
lassign [@stepscript@ [join [
lrange $args 1 end] { }] @config@] infoname newscript
set args [list {*}[lindex $args 0] $newscript]
} else {
lassign [@stepscript@ [join $args { }] @config@] \
infoname newscript
set args [list $newscript]
}
::tailcall @wrapped@ {*}$args
}]
proc $name args $script
}
proc wrap_while {wrapped name args} {
pre
tailcall wrap $wrapped $name [list eindices 0 indices 1] {*}$args
}