set source ~/scripts
set auto_path [concat . $auto_path]

source $source/itcl.tcl

set ::tests 0
proc ? {cmd expected {msg ""}} {
   incr ::tests                               
   set r [uplevel $cmd]
   if {$msg eq ""} {set msg $cmd}
   if {$r ne $expected} {
     error "... $msg returned '$r' ne '$expected'"
   } else {
     puts "... $msg -> $expected -  passed"
   }
 }

######################################################################
#
# 3. Sample itcl program
#
######################################################################
namespace import itcl::*

# example from OO bench
set n 4

itcl::class Toggle {
   variable state
   constructor {start_state} {
     set state $start_state
     #puts "constructor: i am [::itcl::self], state?[info exists state]"
   }
   method value {} {
     return $state
   }
   method activate {} {
     #puts "acivate: i am [::itcl::self], state?[info exists state]"
     set state [expr {!$state}]
     return $this
   }
 }

set toggle1 [Toggle \#auto 1]
? {set toggle1} toggle0
? {$toggle1 activate; $toggle1 value} 0
? {$toggle1 activate; $toggle1 value} 1
? {$toggle1 activate; $toggle1 value} 0
? {$toggle1 activate; $toggle1 value} 1
? {$toggle1 activate; $toggle1 value} 0

  itcl::delete object $toggle1
   for {set i 0} {$i<$n} {incr i} {
     set toggle [Toggle toggle$i 1]
     itcl::delete object $toggle
   }

# define a subclass of Toggle

 itcl::class NthToggle {
   inherit Toggle
   variable count_max
   variable counter
   constructor {start_state max_counter} {
     Toggle::constructor $start_state
   } {
     set count_max $max_counter
     set counter 0
   }
   method activate {} {
     if {[incr counter] >= $count_max} {
       Toggle::activate
       set counter 0
     }
     return $this
   }
 }

set ntoggle1 [NthToggle \#auto 1 3]
? {$ntoggle1 activate; $ntoggle1 value} 1
? {$ntoggle1 activate; $ntoggle1 value} 1
? {$ntoggle1 activate; $ntoggle1 value} 0
? {$ntoggle1 activate; $ntoggle1 value} 0
? {$ntoggle1 activate; $ntoggle1 value} 0
? {$ntoggle1 activate; $ntoggle1 value} 1
? {$ntoggle1 activate; $ntoggle1 value} 1
? {$ntoggle1 activate; $ntoggle1 value} 1
itcl::delete object $ntoggle1

for {set i 0} {$i<$n} {incr i} {
  set ntoggle [NthToggle nthtoggle$i 1 3]
  itcl::delete object $ntoggle
}
? {NthToggle __info instances} ""


#############################
# Counter class
#############################

# todo protected+private methods+vars
# todo some parts ?reflectors? in C

    itcl::class Counter {
      constructor {args} {
        incr num
        eval configure $args
      }
      destructor {
        incr num -1
      }
      method ++ {} {
        return [incr val $by]
      }
      proc num {} {
        return $num
      }

      public variable by 1
      protected variable val 0
      private common num 0
    }


Counter c
? {Counter __info instances} ::c
? {list [c ++] [c ++] [c ++]} {1 2 3}
? {Counter::num} 1 "query class variable"
set c [Counter #auto]
? {Counter::num} 2 "query incremented class variable"
::itcl::delete object $c
? {Counter::num} 1 "query decremented class variable"

? {c configure} {{-by 1 1}}
? {c configure -by} {-by 1 1}
? {list [c configure -by 2] [c cget -by]} {{} 2}
? {list [c ++] [c ++]} {5 7}
? {Counter::num} 1

? {Counter __info instances} ::c

    itcl::class C2 {
      inherit Counter
      method ns {} {
        namespace current
      }
      method foo {} {
        ++
      }
    }

? {C2 c2} c2
? {c2 ++} 1    "calling inherited method"
? {c2 ns} ::C2 "namespace in method == class namespace"
? {c2 foo} 2   "calling inherited method without object name"



itcl::class test_globals {
  common g1 "global1"
  proc getval {name} {
    variable $name
    return [set [namespace tail $name]]
  }
  proc setval {name val} {
    variable $name
    return [set [namespace tail $name] $val]
  }
  method do {args} {
    return [eval $args]
  }
}
namespace eval test_globals {
  variable g2 "global2"
}


? {test_globals #auto} test_globals0
? {lsort [info vars ::test_globals::*]} {::test_globals::g1 ::test_globals::g2}
? {list [catch {test_globals0 do set g1} msg] $msg} {0 global1}
? {list [catch {test_globals0 do set g2} msg] $msg} {1 {can't read "g2": no such variable}}
? {list [catch {test_globals::getval g1} msg] $msg} {0 global1}
? {list [catch {test_globals::getval g2} msg] $msg} {0 global2}
? {set ::test_global_0 "g0"
    list [catch {test_globals::getval test_global_0} msg] $msg \
         [catch {test_globals::getval ::test_global_0} msg] $msg \
} {1 {can't read "test_global_0": no such variable} 0 g0}
? {test_globals::setval ::test_global_1 g1
    namespace eval :: {lsort [info globals test_global_*]}
} {test_global_0 test_global_1}
? {test_globals::setval ::test:global:2 g2
    namespace eval :: {info globals test:global:2}
} {test:global:2}

    proc test_arrays_get {name} {
        upvar $name x
        set rlist {}
        foreach index [lsort [array names x]] {
            lappend rlist [list $index $x($index)]
        }
        return $rlist
    }
    itcl::class test_arrays {
        variable nums
        common undefined

        common colors
        set colors(red)   #ff0000
        set colors(green) #00ff00
        set colors(blue)  #0000ff

        constructor {} {
            set nums(one) 1
            set nums(two) 2
            set nums(three) 3

            set undefined(a) A
            set undefined(b) B
        }
        method do {args} {
            return [eval $args]
        }
    }

? {test_arrays #auto} test_arrays0

? {lsort [test_arrays0 do array get nums]} {1 2 3 one three two} \
  {test array access for instance variables}

? {lsort [test_arrays0 do array get colors]} [list #0000ff #00ff00 #ff0000 blue green red] \
    {test array access for commons} 

? {test_arrays0 do test_arrays_get nums} {{one 1} {three 3} {two 2}} \
    {test array access for instance variables via "upvar"}

? {test_arrays0 do test_arrays_get colors} {{blue #0000ff} {green #00ff00} {red #ff0000}} \
    {test array access for commons via "upvar"}

? {lsort [test_arrays0 do array get undefined]} {A B a b} \
    {test array access for commons defined in constructor}

? {test_arrays0 do test_arrays_get undefined} {{a A} {b B}} \
    {test array access for commons defined in constructor}

? {list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)]} {A B} \
    {test array access for commons defined in constructor} 

? {test_arrays0 do unset undefined;test_arrays0 do array names undefined} {} \
    {common variables can be unset} 

? {test_arrays0 do set undefined "scalar"} {scalar} \
    {common variables can be redefined}

# redefine the class
    itcl::class Counter {
        method ++ {} {
            return [incr val $by]
        }
        public variable by 1
        protected variable val 0
    }

? {list [catch "Counter::num" msg] $msg} {1 {invalid command name "Counter::num"}} \
    {the redefined class is actually different}

? {list [Counter #auto] [Counter #auto]} {counter0 counter1} \
    {objects can be created from the new class}

? {namespace eval someNS1 {}
  namespace eval someNS2 {}
  list [Counter someNS1::#auto] [Counter someNS2::#auto]} [list someNS1::counter2 someNS2::counter3] \
    {namespaces for #auto are prepended to the command name}

? {list [lsort [itcl::find objects counter*]] \
       [itcl::delete class Counter] \
       [lsort [itcl::find objects counter*]]} {{counter0 counter1} {} {}} \
    {when a class is destroyed, its objects are deleted}


class Person {
  public variable name ""
  public variable phone ""
  public variable email ""
  
  constructor {args} {
    eval configure $args
  }
}

Person bob \
    -name "Cyber Bob" \
    -phone "555-4bob" \
    -email "cbob@foo.com"

? {bob configure} "{-email {} cbob@foo.com} {-name {} {Cyber Bob}} {-phone {} 555-4bob}"
? {bob configure -phone} "-phone {} 555-4bob"
? {bob configure -phone 1-800-num-4bob} ""
? {bob configure -phone} "-phone {} 1-800-num-4bob"
? {bob cget -phone} "1-800-num-4bob"


itcl::class test_pr {
  public variable pubv "public var"
  public common pubc "public com"
  public method pubm {} {return "public method"}
  public method ovpubm {} {return "overloaded public method"}
  public proc pubp {} {return "public proc"}

  protected variable prov "protected var"
  protected common proc "protected com"
  protected method prom {} {return "protected method"}
  protected method ovprom {} {return "overloaded protected method"}
  protected proc prop {} {return "protected proc"}

  private variable priv "private var"
  private  common pric "private com"
  private  method prim {} {return "private method"}
  private  method ovprim {} {return "overloaded private method"}
  private  proc prip {} {return "private proc"}

  method do {args} {
    #puts "method namespace = [namespace current] cmds [lsort [info commands ::test_pr::*]]"
    #foreach v {pubv pubc prov proc priv pric} {puts "exists $v ?[info exists $v]"}
    eval $args}
  method do_base {args} {
    #foreach v {pubv pubc prov proc priv pric} {puts "exists $v ?[info exists $v]"}
    #puts "derived method namespace = [namespace current] cmds [lsort [info commands ::test_pr::*]]"
    eval $args}
}
? {test_pr #auto} {test_pr0}

? {list [catch {test_pr0 pubm} msg] $msg} {0 {public method}} \
    "public methods can be accessed from outside"

? {list [catch {test_pr0 do pubm} msg] $msg} {0 {public method}} \
    {public methods can be accessed from inside}

? {list [catch {test_pr0 prom} msg] $msg} {1 {bad option "prom": should be one of...
  test_pr0 cget -option
  test_pr0 configure ?-option? ?value -option value...?
  test_pr0 do ?arg arg ...?
  test_pr0 do_base ?arg arg ...?
  test_pr0 isa className
  test_pr0 ovpubm
  test_pr0 pubm}} \
    {protected methods are blocked from outside}      

? {list [catch {test_pr0 do prom} msg] $msg} {0 {protected method}} \
    {protected methods can be accessed from inside}

? {list [catch {test_pr0 prim} msg] $msg} {1 {bad option "prim": should be one of...
  test_pr0 cget -option
  test_pr0 configure ?-option? ?value -option value...?
  test_pr0 do ?arg arg ...?
  test_pr0 do_base ?arg arg ...?
  test_pr0 isa className
  test_pr0 ovpubm
  test_pr0 pubm}} \
    {private methods are blocked from outside}      

? {list [catch {test_pr0 do prim} msg] $msg} {0 {private method}} \
    {private methods can be accessed from inside}

? {list [catch {test_pr::pubp} msg] $msg} {0 {public proc}} \
    {public procs can be accessed from outside} 

? {list [catch {test_pr0 do pubp} msg] $msg} {0 {public proc}} \
    {public procs can be accessed from inside}

? {list [catch {test_pr::prop} msg] $msg} {1 {can't access "::test_pr::prop": protected function}} \
    {protected procs are blocked from outside}

? {list [catch {test_pr0 do prop} msg] $msg} {0 {protected proc}} \
    {protected procs can be accessed from inside}

? {list [catch {test_pr::prip} msg] $msg} {1 {can't access "::test_pr::prip": private function}} \
    {private procs are blocked from outside}

? {list [catch {test_pr0 do prip} msg] $msg} {0 {private proc}} \
    {private procs can be accessed from inside} 

? {list [catch {set test_pr::pubc} msg] $msg} {0 {public com}} \
    {public commons can be accessed from outside}

? {list [catch {test_pr0 do set pubc} msg] $msg} {0 {public com}} \
    {public commons can be accessed from inside}

? {list [catch {test_pr0 do set proc} msg] $msg} {0 {protected com}} \
    {protected commons can be accessed from inside}

? {list [catch {test_pr0 do set pric} msg] $msg} {0 {private com}} \
    {private commons can be accessed from inside}

? {list [catch {set test_pr::pubv} msg] $msg} {1 {can't read "test_pr::pubv": no such variable}} \
    {object-specific variables require an access command}

? {list [catch {test_pr0 do set pubv} msg] $msg} {0 {public var}} \
    {public variables can be accessed from inside} 

? {list [catch {set test_pr::prov} msg] $msg} {1 {can't read "test_pr::prov": no such variable}} \
    {object-specific variables require an access command}

? {list [catch {test_pr0 do set prov} msg] $msg} {0 {protected var}} \
    {public variables can be accessed from inside}

? {list [catch {set test_pr::prov} msg] $msg} {1 {can't read "test_pr::prov": no such variable}} \
    {object-specific variables require an access command} 

? {list [catch {test_pr0 do set prov} msg] $msg} {0 {protected var}} \
    {protected variables can be accessed from inside}

? {list [catch {set test_pr::priv} msg] $msg} {1 {can't read "test_pr::priv": no such variable}} \
    {object-specific variables require an access command}

? {list [catch {test_pr0 do set priv} msg] $msg} {0 {private var}} \
    {private variables can be accessed from inside}

? {
  itcl::class test_pr_derived {
    inherit test_pr
    method do {args} {
      #puts "subclass method namespace = [namespace current] cmds [lsort [info commands ::test_pr_derived::*]]"
      eval $args}
    
    public method ovpubm {} {return "specific public method"}
    protected method ovprom {} {return "specific protected method"}
    private method ovprim {} {return "specific private method"}
    
    public method dpubm {} {return "pub (only in derived)"}
    protected method dprom {} {return "pro (only in derived)"}
    private method dprim {} {return "pri (only in derived)"}
  }
} "" {define a derived class}

? {test_pr_derived #auto} {test_pr_derived0} {create an object to execute tests}

? {list [catch {test_pr_derived0 do pubm} msg] $msg} {0 {public method}} \
    {public methods can be accessed from inside}

? {list [catch {test_pr_derived0 do prom} msg] $msg} {0 {protected method}} \
    {protected methods can be accessed from inside}

? {list [catch {test_pr_derived0 do prim} msg] $msg} {1 {invalid command name "prim"}} \
    {private methods are blocked}

? {list [catch {test_pr_derived0 do pubp} msg] $msg} {0 {public proc}} \
    {public procs can be accessed from inside}

? {list [catch {test_pr_derived0 do prop} msg] $msg} {0 {protected proc}} \
    {protected procs can be accessed from inside}

? {list [catch {test_pr_derived0 do prip} msg] $msg} {1 {invalid command name "prip"}} \
    {private procs are blocked}

? {list [catch {test_pr_derived0 do set pubc} msg] $msg} {0 {public com}} \
    {public commons can be accessed from inside}

? {list [catch {test_pr_derived0 do set proc} msg] $msg} {0 {protected com}} \
    {protected commons can be accessed from inside}

? {list [catch {test_pr_derived0 do set pric} msg] $msg} {1 {can't read "pric": no such variable}} \
    {private commons are blocked}

? {list [catch {test_pr_derived0 do set pubv} msg] $msg} {0 {public var}} \
    {public variables can be accessed from inside}

? {list [catch {test_pr_derived0 do set prov} msg] $msg} {0 {protected var}} \
    {protected variables can be accessed from inside}

? {list [catch {test_pr_derived0 do set priv} msg] $msg} {1 {can't read "priv": no such variable}} \
    {private variables are blocked}

? {set cmd {namespace eval test_pr_derived {test_pr_derived0 ovpubm}}
  list [catch $cmd msg] $msg} {0 {specific public method}} \
    {can access overloaded public method}

? {list [catch {test_pr_derived0 do test_pr_derived0 ovprom} msg] $msg} \
    {0 {specific protected method}} \
    {can access overloaded protected method}

#? {set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprom}}
#  list [catch $cmd msg] $msg} {0 {specific protected method}} \
#    {can access overloaded protected method}

? {list [catch {test_pr_derived0 do test_pr_derived0 ovprim} msg] $msg} \
    {0 {specific private method}} \
    {can access overloaded private method}

#? {set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprim}}
#  list [catch $cmd msg] $msg} {0 {specific private method}} \
#    {can access overloaded private method}

? {list [catch {test_pr_derived0 do_base test_pr_derived0 ovpubm} msg] $msg} \
    {0 {specific public method}} \
    {can access overloaded public method from base class}

? {set cmd {namespace eval test_pr {test_pr_derived0 ovpubm}}
  list [catch $cmd msg] $msg} {0 {specific public method}} \
    {can access overloaded public method from base class}

? {list [catch {test_pr_derived0 do_base test_pr_derived0 ovprom} msg] $msg} \
    {0 {specific protected method}} \
    {can access overloaded protected method from base class}

#? {set cmd {namespace eval test_pr {test_pr_derived0 ovprom}}
#  list [catch $cmd msg] $msg} {0 {specific protected method}} \
#    {can access overloaded protected method from base class}

? {list [catch {test_pr_derived0 do_base test_pr_derived0 ovprim} msg] $msg} \
    {1 {bad option "ovprim": should be one of...
  test_pr_derived0 cget -option
  test_pr_derived0 configure ?-option? ?value -option value...?
  test_pr_derived0 do ?arg arg ...?
  test_pr_derived0 do_base ?arg arg ...?
  test_pr_derived0 dpubm
  test_pr_derived0 isa className
  test_pr_derived0 ovprom
  test_pr_derived0 ovpubm
  test_pr_derived0 prim
  test_pr_derived0 prom
  test_pr_derived0 pubm}} \
    {*cannot* access overloaded private method from base class}

#? {set cmd {namespace eval test_pr {test_pr_derived0 ovprom}}
#  list [catch $cmd msg] $msg} {0 {specific protected method}} \
#    {can access overloaded protected method from base class}

? {set cmd {namespace eval test_pr {test_pr_derived0 dpubm}}
  list [catch $cmd msg] $msg} {0 {pub (only in derived)}} \
    {can access non-overloaded public method from base class} 

? {set cmd {namespace eval test_pr {test_pr_derived0 dprom}}
  list [catch $cmd msg] $msg} {1 {bad option "dprom": should be one of...
  test_pr_derived0 cget -option
  test_pr_derived0 configure ?-option? ?value -option value...?
  test_pr_derived0 do ?arg arg ...?
  test_pr_derived0 do_base ?arg arg ...?
  test_pr_derived0 dpubm
  test_pr_derived0 isa className
  test_pr_derived0 ovprom
  test_pr_derived0 ovpubm
  test_pr_derived0 prim
  test_pr_derived0 prom
  test_pr_derived0 pubm}} \
    {*cannot* access non-overloaded protected method from base class} 

? {list [catch {test_pr_derived0 do_base test_pr_derived0 dprom} msg] $msg} \
    {1 {bad option "dprom": should be one of...
  test_pr_derived0 cget -option
  test_pr_derived0 configure ?-option? ?value -option value...?
  test_pr_derived0 do ?arg arg ...?
  test_pr_derived0 do_base ?arg arg ...?
  test_pr_derived0 dpubm
  test_pr_derived0 isa className
  test_pr_derived0 ovprom
  test_pr_derived0 ovpubm
  test_pr_derived0 prim
  test_pr_derived0 prom
  test_pr_derived0 pubm}} \
    {*cannot* access non-overloaded protected method from base class} 

? {set cmd {namespace eval test_pr {test_pr_derived0 dprim}}
  list [catch $cmd msg] $msg} {1 {bad option "dprim": should be one of...
  test_pr_derived0 cget -option
  test_pr_derived0 configure ?-option? ?value -option value...?
  test_pr_derived0 do ?arg arg ...?
  test_pr_derived0 do_base ?arg arg ...?
  test_pr_derived0 dpubm
  test_pr_derived0 isa className
  test_pr_derived0 ovprom
  test_pr_derived0 ovpubm
  test_pr_derived0 prim
  test_pr_derived0 prom
  test_pr_derived0 pubm}} \
    {*cannot* access non-overloaded private method from base class} 

? {list [catch {test_pr_derived0 do_base test_pr_derived0 dprim} msg] $msg} \
    {1 {bad option "dprim": should be one of...
  test_pr_derived0 cget -option
  test_pr_derived0 configure ?-option? ?value -option value...?
  test_pr_derived0 do ?arg arg ...?
  test_pr_derived0 do_base ?arg arg ...?
  test_pr_derived0 dpubm
  test_pr_derived0 isa className
  test_pr_derived0 ovprom
  test_pr_derived0 ovpubm
  test_pr_derived0 prim
  test_pr_derived0 prom
  test_pr_derived0 pubm}} \
    {*cannot* access non-overloaded private method from base class} 

puts "$::tests Tests passed"