diff options
| -rw-r--r-- | jim.c | 41 | ||||
| -rw-r--r-- | regtest.tcl | 3 | ||||
| -rw-r--r-- | stdlib.tcl | 28 | ||||
| -rw-r--r-- | tcltest.tcl | 47 | ||||
| -rw-r--r-- | tests/infoframe.test | 31 |
5 files changed, 93 insertions, 57 deletions
@@ -12017,23 +12017,44 @@ static int JimInfoFrame(Jim_Interp *interp, Jim_Obj *levelObjPtr, Jim_Obj **objP } #ifndef JIM_NO_INTROSPECTION { - Jim_Obj *cmdObj; - /* Omit the command and proc */ - cmdObj = Jim_NewListObj(interp, targetEvalFrame->argv, targetEvalFrame->argc); + Jim_Obj *cmdObj = Jim_NewListObj(interp, targetEvalFrame->argv, targetEvalFrame->argc); Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "cmd", -1)); Jim_ListAppendElement(interp, listObj, cmdObj); - /* Look in parent frames for a proc name */ - Jim_EvalFrame *p; - for (p = targetEvalFrame->parent; p ; p = p->parent) { - if (p->cmd && p->cmd->isproc) { - Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "proc", -1)); - Jim_ListAppendElement(interp, listObj, p->cmd->cmdNameObj); + } +#endif + /* Now determine if this eval frame has a proc caller */ + { + /* If the target eval frame has proc call frame level >= the previous one + * we don't set 'proc' (it will be set on the previous one) + * So first determine if this needs 'proc' + */ + Jim_EvalFrame *e, *p = NULL; + for (e = interp->evalFrame; e; e = e->parent) { + if (e == targetEvalFrame) { break; } + if (!p || e->callFrameLevel != p->callFrameLevel) { + p = e; + } + else { + p = NULL; + } + } + if (!p || e->callFrameLevel < p->callFrameLevel) { + /* Find the first proc above this level */ + for (e = targetEvalFrame->parent; e; e = e->parent) { + if (e->cmd && e->cmd->isproc) { + /* apply and namespace eval won't provide cmdNameObj */ + if (e->cmd->cmdNameObj) { + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "proc", -1)); + Jim_ListAppendElement(interp, listObj, e->cmd->cmdNameObj); + } + break; + } + } } } -#endif Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "level", -1)); Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, interp->framePtr->level - targetEvalFrame->callFrameLevel)); diff --git a/regtest.tcl b/regtest.tcl index b0cb70b..a9ee5eb 100644 --- a/regtest.tcl +++ b/regtest.tcl @@ -384,6 +384,9 @@ foreach i $chars1 { alarm 0 puts "TEST 54 PASSED" +# info frame should work even if in an anonymous proc +apply {{} {info frame 0}} +puts "TEST 55 PASSED" # TAKE THE FOLLOWING puts AS LAST LINE @@ -37,32 +37,14 @@ proc function {value} { # with 3 entries for each stack frame (proc), # (deepest level first) proc stacktrace {{skip 0}} { - set trace {} - # Need to skip info frame 0 and this (stacktrace) level - incr skip 2 - loop level $skip [info level]+1 { + set frames {} + loop level 2 [info frame]+1 { set frame [info frame -$level] - lappend trace [lindex [dict getdef $frame cmd {}] 0] [dict get $frame file] [dict get $frame line] - } - return $trace -} -proc stacktrace {{skip 0}} { - set trace {} - # skip the internal frames - incr skip 1 - set last 0 - loop level $skip [info frame]+1 { - set frame [info frame -$level] - set file [dict get $frame file] - set line [dict get $frame line] - set lev [dict get $frame level] - if {$lev != $last && $lev > $skip} { - set proc [lindex [dict get $frame cmd] 0] - lappend trace $proc $file $line + if {$frame(level) > $skip && [dict exists $frame proc]} { + lappend frames $frame(proc) $frame(file) $frame(line) } - set last $lev } - return $trace + return $frames } # Returns a human-readable version of a stack trace diff --git a/tcltest.tcl b/tcltest.tcl index a95f665..2b8d3d8 100644 --- a/tcltest.tcl +++ b/tcltest.tcl @@ -73,6 +73,20 @@ proc skiptest {{msg {}}} { exit 0 } +# Takes a stacktrace and applies [file tail] to the filenames. +# This allows stacktrace tests to be run from a directory other than the source directory. +# Also convert proc name ::a into a for compatibility between Tcl and Jim +proc basename-stacktrace {stacktrace} { + set result {} + foreach {p f l} $stacktrace { + if {[string match ::* $p]} { + set p [string range $p 2 end] + } + lappend result $p [file tail $f] $l + } + return $result +} + # If tcl, just use tcltest if {[catch {info version}]} { package require Tcl 8.5 @@ -87,6 +101,29 @@ if {[catch {info version}]} { proc testreport {} { ::tcltest::cleanupTests } + proc stacktrace {{skip 0}} { + set trace {} + # Need to skip info frame 0 and this (stacktrace) level + incr skip 1 + set maxlevel [info frame] + for {set level $skip} {$level < $maxlevel} {incr level} { + set frame [info frame -$level] + if {[dict get $frame type] eq "source" && [dict exists $frame proc]} { + set proc [dict get $frame proc] + # make it look like it is running under Jim tcltest + if {$proc eq "::tcltest::RunTest"} { + set proc test + } else { + set proc [string range $proc 2 end] + } + lappend trace $proc [dict get $frame file] [dict get $frame line] + if {$proc eq "test"} { + break + } + } + } + return $trace + } return } @@ -195,16 +232,6 @@ proc bytestring {x} { return $x } -# Takes a stacktrace and applies [file tail] to the filenames. -# This allows stacktrace tests to be run from a directory other than the source directory. -proc basename-stacktrace {stacktrace} { - set result {} - foreach {p f l} $stacktrace { - lappend result $p [file tail $f] $l - } - return $result -} - # Takes a list of {filename line} and returns {basename line} proc basename-source {list} { list [file tail [lindex $list 0]] [lindex $list 1] diff --git a/tests/infoframe.test b/tests/infoframe.test index 9490589..e8544b1 100644 --- a/tests/infoframe.test +++ b/tests/infoframe.test @@ -1,11 +1,14 @@ source [file dirname [info script]]/testing.tcl -needs constraint jim + proc a {n} { if {$n eq "trace"} { - # strip the frame levels for test and uplevel - return [basename-stacktrace [lrange [stacktrace] 0 end-6]] + return [basename-stacktrace [stacktrace]] + } + set frame [info frame $n] + if {![dict exists $frame proc]} { + dict set frame proc {} } - set frame [info frame $n]; list [dict getdef $frame proc {}] [file tail [dict get $frame file]] [dict get $frame line] + basename-stacktrace [list [dict get $frame proc] [file tail [dict get $frame file]] [dict get $frame line]] } proc b {n} { @@ -18,24 +21,24 @@ proc c {n} { # --- Don't change line numbers above -test info-frame-1.1 "Current command" { +test info-frame-1.1 {Current command} -body { c 0 -} {a infoframe.test 8} +} -result {a infoframe.test 7} -test info-frame-1.2 "Current Proc" { +test info-frame-1.2 {Current Proc} -body { c -1 -} {b infoframe.test 12} +} -result {b infoframe.test 15} -test info-frame-1.3 "Caller" { +test info-frame-1.3 Caller -body { c -2 -} {c infoframe.test 16} +} -result {c infoframe.test 19} -test info-frame-1.4 "Caller of Caller" { +test info-frame-1.4 {Caller of Caller} -body { c -3 -} {test infoframe.test 34} +} -result {test infoframe.test 37} -test stacktrace-1.1 "Full stack trace" { +test stacktrace-1.1 {Full stack trace} -body { c trace -} {a infoframe.test 12 b infoframe.test 16 c infoframe.test 38} +} -result {a infoframe.test 5 b infoframe.test 15 c infoframe.test 19 test infoframe.test 41} testreport |