Tcl Source Code

Artifact b6021ee36db65656b91edd3f0c11b904db17c254:

Attachment "call-stack.tcl" to ticket [967565ffff] added by mistachkin 2004-06-07 05:37:16.

---

# call stack:
#
# global
# parent interp :: procA
# child interp :: procC <-- this is skipped over in second test.
# parent interp :: procB

namespace eval ::test {
  proc procA { interp copy } {
    if {$interp} then {
      global i

      if {$copy} then {
        set procB_body [info body procB]
        interp eval $i [list namespace eval ::test [list proc procB {} $procB_body]]
        interp alias $i ::test::A::procB $i ::test::procB
      } else {
        interp alias $i ::test::A::procB {} ::test::procB
      }

      puts stdout "MASTER => test::cmds == \{ [info commands ::test::proc*] \}"
      puts stdout "SLAVE => test::A::cmds == \{ [interp eval $i [list info commands ::test::A::proc*]] \}"

      interp eval $i [list namespace eval ::test::A procC]
    } else {
      interp alias {} ::test::A::procB {} ::test::procB

      puts stdout "MASTER => test::cmds == \{ [info commands ::test::proc*] \}"
      puts stdout "MASTER => test::A::cmds == \{ [info commands ::test::A::proc*] \}"

      namespace eval ::test::A procC
    }
  }

  proc procB {} {
    puts stdout "\nCALL STACK:"

    for {set index 1} {$index <= [info level]} {incr index} {
      puts stdout "level $index == [info level $index]"
    }

    puts stdout ""

    set current_ns [namespace current]

    # should print "::test"
    puts stdout "current namespace == $current_ns"

    if {$current_ns == "::test"} then {
      puts stdout "SUCCESS, current namespace MATCH.\n"
    } else {
      puts stdout "FAILURE, current namespace MISMATCH.\n"
    }

    set current [lindex [info level [info level]] 0]

    # should print "::test::procB"
    puts stdout "current proc ([info level]) == $current"

    if {[string match "*procB" $current]} then {
      puts stdout "SUCCESS, current proc MATCH.\n"
    } else {
      puts stdout "FAILURE, current proc MISMATCH.\n"
    }

    set parent_ns [uplevel 1 [list namespace current]]

    # should print "::test::A"
    puts stdout "parent namespace == $parent_ns"

    if {$parent_ns == "::test::A"} then {
      puts stdout "SUCCESS, parent namespace MATCH.\n"
    } else {
      puts stdout "FAILURE, parent namespace MISMATCH.\n"
    }

    set parent [lindex [info level [expr {[info level] - 1}]] 0]

    # should print "::test::A::procC" or "procC"
    puts stdout "parent proc ([info level] - 1) == $parent"

    if {[string match "*procC" $parent]} then {
      puts stdout "SUCCESS, parent proc MATCH.\n"
    } else {
      puts stdout "FAILURE, parent proc MISMATCH.\n"
    }
  }
}

catch {wm withdraw .}
catch {console show}

#
# NOTE: Run the tests...
#
foreach this_interp [list 0 1] {
  foreach this_copy [list 0 1] {
    puts stdout "--------------------------------------------------------------------"
    puts stdout "Running test with \"use_new_interp\" set to \"$this_interp\" \nand \"copy_body\" set to \"$this_copy\".\n"
  
    if {$this_interp} then {
      set i [interp create]
      
      interp eval $i {
        namespace eval ::test::A {
          proc procC {} {
            procB
          }    
        }
      }
    } else {
      namespace eval ::test::A {
        proc procC {} {
          procB
        }    
      }
    }
    
    ::test::procA $this_interp $this_copy
  }
}