Tcl Source Code

Artifact 1dd3c6a9b47bfab566a45b92c008e72a46f8df27:

Attachment "test.tcl" to ticket [967565ffff] added by mistachkin 2004-06-06 19:17:27.

---

namespace eval ::test {
  proc procA { interp } {
    if {$interp} then {
      global i
      interp alias $i ::test::A::procB {} ::test::procB
      interp eval $i [list namespace eval ::test::A procC]
    } else {
      interp alias {} ::test::A::procB {} ::test::procB
      namespace eval ::test::A procC
    }
  }

  proc procB {} {
    set current [lindex [info level [info level]] 0]

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

    if {$current == "::test::procB"} then {
      puts stdout "SUCCESS, current proc match."
    } else {
      puts stdout "FAILURE, current proc mismatch."
    }

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

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

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


foreach this_interp [list 0 1] {
  puts stdout "Running test with use_new_interp set to $this_interp."

  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
}