Thread: [tcljava-dev] Testcase for bug 2072924

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

I've been looking into the bug I filed a while back, and developed
a stand alone test case that illustrates the behavior.

Itcl class Foo resembles my actual environment.  It wraps up
a Java object, and the destructor does an explicit 'rename' to
get rid of the object command.  

Bar class is the same, except it does not explicitly rename
the Java object upon destruction.

Proc 'testVar' is similar to the Foo class, but obviously without
Itcl class or namespace issues - it too explicitly renames the
Java object to {} when going out of scope.  

The behavior in the bug I reported is evident when running:
    jaclsh testcase.tcl Foo
The first time the 'testFoo' proc runs, all is good, but
subsequent executions of 'testFoo' reports errors, the
Java object command is returned, but it is no longer
a valid Tcl command.

Testing class Bar, without an explicit rename of the Java object:
    jaclsh testcase.tcl Bar
This case runs to completion, but leaks the Java
object command into the top level namespace.  Furthermore,
it appears that the ReflectObject.useCount is incremented
for the ReflectObject, each time through 'testBar' (as witnessed with the
Eclipse debugger).

See below for output.

Unfortunately the patch I submitted seems to also increment
the useCount, therefore it too leaks objects in Java, not
necessarily in Tcl command space.

Mo, do you see anything wrong with my Foo class or its
usage?  

testcase.tcl:
---cut here---------------------------------------------------------------
package require java
package require Itcl

# itcl class - destructor explicitly destroys the java object _obj_
itcl::class Foo {
   private variable _obj_
   constructor {sbObj} {
     set _obj_ $sbObj
   }
   destructor {
     puts "destruct $this"
     catch {rename $_obj_ {}}
   }
   public method _getObj_ {} {
     return $_obj_
   }
   public method getValue {} {
     return [$_obj_ toString]
   }
}

# itcl class - destructor does not destroy the java object _obj_
itcl::class Bar {
   private variable _obj_
   constructor {sbObj} {
     set _obj_ $sbObj
   }
   destructor {
     puts "destruct $this"
   }
   public method _getObj_ {} {
     return $_obj_
   }
   public method getValue {} {
     return [$_obj_ toString]
   }
}

# create a HashMap, put in one StringBuffer object
set hm [java::new java.util.HashMap]
set sb [java::new String sb]
$hm put $sb [java::new java.lang.StringBuffer foobar]
puts "info commands java0x*: [lsort [info commands java0x*]]"

# proc to test retrieving the StringBuffer object into a simple Tcl variable
# explicitly destroy the StringBuffer object command via "rename"
proc testVar {} {
  global hm sb
  set o [$hm get $sb]
  puts "testVar: [$o toString]"
  rename $o {}
  return ""
}

# proc to test retrieving the StringBuffer object into an Itcl object Foo
proc testFoo {} {
  global hm sb
  set o [$hm get $sb]
  set f [Foo #auto $o]
  puts "testFoo: [$f getValue]"
  itcl::delete object $f
  return ""
}

# proc to test retrieving the StringBuffer object into an Itcl object Bar
proc testBar {} {
  global hm sb
  set o [$hm get $sb]
  set b [Bar #auto $o]
  puts "testBar: [$b getValue]"
  itcl::delete object $b
  return ""
}

if {[lindex $argv 0] eq "Foo"} {

  puts ==testVar===========================================
  for {set i 1} {$i < 5} {incr i} {
    if {[catch {testVar} result]} {
        puts "testVar: iteration $i catch error: $result"
    }
    puts "testVar: iteration $i \[info commands java0x*\]: [lsort [info commands java0x*]]"
  }

  puts ==testFoo===========================================
  for {set i 1} {$i < 5} {incr i} {
    if {[catch {testFoo} result]} {
      puts "testFoo: iteration $i catch error: $result"
    }
    puts "testFoo: iteration $i \[info commands java0x*\]: [lsort [info commands java0x*]]"
  }

} elseif {[lindex $argv 0] eq "Bar"} {

  puts ==testVar===========================================
  for {set i 1} {$i < 5} {incr i} {
    if {[catch {testVar} result]} {
      puts "testVar: iteration $i catch error: $result"
    }
    puts "testVar: iteration $i \[info commands java0x*\]: [lsort [info commands java0x*]]"
  }

  puts ==testBar===========================================
  for {set i 1} {$i < 5} {incr i} {
    if {[catch {testBar} result]} {
      puts "testVar: iteration $i catch error: $result"
    }
    puts "testbar: iteration $i \[info commands java0x*\]: [lsort [info commands java0x*]]"
  }

} else {
  error "arg should be \"Foo\" or \"Bar\""
}

---cut here---------------------------------------------------------------

Test results:
$ jaclsh testcase.tcl Foo
info commands java0x*: java0x1 java0x2
==testVar===========================================
testVar: foobar
testVar: iteration 1 [info commands java0x*]: java0x1 java0x2
testVar: foobar
testVar: iteration 2 [info commands java0x*]: java0x1 java0x2
testVar: foobar
testVar: iteration 3 [info commands java0x*]: java0x1 java0x2
testVar: foobar
testVar: iteration 4 [info commands java0x*]: java0x1 java0x2
==testFoo===========================================
testFoo: foobar
destruct ::foo0
testFoo: iteration 1 [info commands java0x*]: java0x1 java0x2
testFoo: iteration 2 catch error: invalid command name "java0x8"
testFoo: iteration 2 [info commands java0x*]: java0x1 java0x2
testFoo: iteration 3 catch error: invalid command name "java0x8"
testFoo: iteration 3 [info commands java0x*]: java0x1 java0x2
testFoo: iteration 4 catch error: invalid command name "java0x8"
testFoo: iteration 4 [info commands java0x*]: java0x1 java0x2

$ jaclsh testcase.tcl Bar
info commands java0x*: java0x1 java0x2
==testVar===========================================
testVar: foobar
testVar: iteration 1 [info commands java0x*]: java0x1 java0x2
testVar: foobar
testVar: iteration 2 [info commands java0x*]: java0x1 java0x2
testVar: foobar
testVar: iteration 3 [info commands java0x*]: java0x1 java0x2
testVar: foobar
testVar: iteration 4 [info commands java0x*]: java0x1 java0x2
==testBar===========================================
testBar: foobar
destruct ::bar0
testbar: iteration 1 [info commands java0x*]: java0x1 java0x2 java0x8
testBar: foobar
destruct ::bar1
testbar: iteration 2 [info commands java0x*]: java0x1 java0x2 java0x8
testBar: foobar
destruct ::bar2
testbar: iteration 3 [info commands java0x*]: java0x1 java0x2 java0x8
testBar: foobar
destruct ::bar3
testbar: iteration 4 [info commands java0x*]: java0x1 java0x2 java0x8

-- 
Tom Poindexter
tpo...@ny...