source object.tcl

namespace import Object::*

set ObjectDebug 1

#------------------------------------------------------
#declares new class with name ClassA and without parents

class ClassA {
    #declare constructor

    constructor {
        puts "ClassA::constructor: $this $args"
    }

    #declares destructor

    destructor {
        puts "ClassA::destructor $this"
    }

    #declares invariant

    invariant {
        puts "ClassA::invariant $this"
    }

    #declares attribute Attr1 with default Value

    attribute Attr1 defValue1

    #declares methodA without arguments

    method methodA {} {
        puts "classA::methodA $this"
        return 1
    } -precondition {
        puts "classA::methodA - precondition $this"
    } -postcondition {
        puts "classA::methodA - postcondition $this"
    }

    #declares methodB with 1 argument

    method methodB {a} {
        puts "classA::methodB $this $a"
        return $a
    } -precondition {
        if {[scan $a "%d" value] != 1} {
            error "argument should be a number"
        }
    }

}

#------------------------------------------------------
#declares new class with name NewClass and with parent classA

class ClassB "ClassA" {
    constructor {
        puts "ClassB::constructor $this $args"
    }

    destructor {
        puts "ClassB::destructor $this"
    }

    invariant {
        puts "ClassB::invariant $this"
    }

    method methodA {} {
        puts "classB::methodA $this"
    } -postcondition {
        puts "classB::methodA - postcondition $this"
    }
}

#------------------------------------------------------
#declares some procedures, used in bindings

proc onDelete {args} {
    puts "On Delete Object $args"
}

proc onChangeAttr {args} {
    puts "On Change Attribute $args"
}

puts "++++ set objA \[new ClassA\] ++++"
set objA [new ClassA]

Object::bind $objA OnDelete ::onDelete

puts "++++ \$objA methodA ++++"
$objA methodA
puts "++++ \$objA methodB argB ++++"
$objA methodB 1

puts "++++ set objB \[new ClassB\] ++++"
set objB [new ClassB]

Object::bind $objB OnDelete onDelete
Object::bind $objB OnChangeAttr1 onChangeAttr

puts "++++ \$objB methodA ++++"
$objB methodA
puts "++++ \$objB methodB argB ++++"
$objB methodB 2

puts "++++ \$objB getAttr1 ++++"
puts [$objB getAttr1]

puts "++++ \$objB setAttr1 \"new Value\" ++++"
$objB setAttr1 "new Value"

puts "++++ \$objB getAttr1 ++++"
puts [$objB getAttr1]

Object::unbind $objB OnDelete onDelete

puts "++++ delete \$objA ++++"
delete $objA
puts "++++ delete \$objB ++++"
delete $objB