See Also  edit

Selfish

the pure Tcl extension which inspired this extension

Description  edit

https://github.com/mpcjanssen/self

• clone new - creates a cloned object with name $new and sets the clone receiver as parent
• copy new - creates a copy of the receiver with name $new
• name: value - create a value slot name that will return $value
• name: args body - will create a method slot name
• parents* - a value or method slot that returns a list with all the parents of the object. This information is used for method dispatch. Object initially has no parents.
• _state - Show the internal object state (use for debugging only). Because it doesn't use the dispatcher this can't be overridden or redefined.

• parents* {receiver of the clone message}

• self slotname args: will call slot $slotname on the receiver of the initial message. Without arguments it will return the name of the receiver.
• next: will call the same slot with the same args as currently executing, but the dispatcher will start looking for the slot only in the parents of the implementer of the currently executing slot, which is not the same as self for inherited slots.
• next slotname args: will call a different slot $slotname on the parents of the implementor of the currently executing slot.

• Variable slots are not real variables, so it is not possible to add traces to them.
• Currently method dispatch in a very deep parent child chain is slow. Doing dispatch on a slot that is defined 999 objects higher in the inheritance tree takes approximately 1000 microseconds on my machine, where as in the TIP 257 [1] implementation it takes only 12. This can be resolved using slot/call chain caching.
• It would be nice to be able to delegate methods based on their signature (an unknown on steroids), which is very useful for building megawidgets. For instance:

 a slot delegate* {}
 a delegate* {{cget .t} {* {self unknown}}}
 # the unknown slot is now a normal slot.
 # delegates will be called with the slotname and args

package require self

# create a Point object.
Object clone Point

# add a to_s slot to display information of the object
Object to_s: {} {
    return "[self]"
}

# add x and y slots for the point, notice that these slots cannot be called for now.
Point x: {args} {error "abstract slot, override in clone"}
Point y: {args} {error "abstract slot, override in clone"} 

# extend default behavior from parent (Object)
Point to_s: {} {
    return "id: [next] ([self x],[self y])"
    # Here next will search for a slot named to_s in the parents of the implementor of the current method (Point)
    # finding the Object slot to_s and the execute it in the context of the receiver (which will be a clone of Point) 
}

# define a point factory
Point create: {name x y} {
    self clone $name
    $name x: $x
    $name y: $y
}

# clone a Point
Point clone p1

# to_s will fail because the x and y slots in Point are called
catch {p1 to_s} err
puts $err

# use the Point factory which will define x and y slots
Point create p1 0 0

# to_s will now work
puts [p1 to_s]

Object clone A
A test: args {return}

A clone a
a test

A clone debug
debug test: {args} {puts "called test with $args"; next}

a parents*: {debug}
a test 1 2 3

 # example demostrating how to override a widget
 package require self
 package require Tk

 proc debugtext name {
        text $name
        rename $name _$name
        Object clone $name
        $name unknown: args {
           puts "[self] $args"
           _[self] {*}$args
        }
        $name destroy: {} {
                destroy _[self]
                rename _[self] {}
                next
        }
        return $name
 }

 debugtext .t 

 pack .t -expand 1 -fill both
 
 button .b -text "Make readonly" -command make_ro
 pack .b
 
 proc make_ro {} {
  # allows on the fly redefining of behaviour
  .t insert: args {puts stderr "readonly"}
  .t delete: args {puts stderr "readonly"}
 }

 % Object clone a
 % a clone: {args} {error "cannot clone"}
 % a clone b
 cannot clone

 MyObj pos: [Point create $x $y]
 puts "pos = [[MyObj pos] to_s]"

 puts "pos = [MyObj pos to_s]"

 Object addChild: {object} {
   self $object: {slot args} "return \[$object \$slot \{*\}\$args \]"   
 }

 Object clone a   
 Object clone pos

 pos to_s: {} {return "I am [self]"}
 a addChild pos
 puts [a pos to_s]

 # even nested 
 Object clone b
 b to_s: {} {return "I am [self]"}
 pos addChild b

 puts [a pos b to_s]

Or more elaborate:

 package require self

 Object children*: {}

 Object addChild: {name object} {
   self $name: {slot args} "return \[$object \$slot \{*\}\$args \]"
   self children* [lappend [self children*] $object]
 }


 Object delete: {} {
    foreach child [self children*] {
        $child delete
    }
    self destroy
 }

 Object clone Point

  Object to_s: {} {
  return "[self]"
 }

 namespace eval self {
  namespace eval objs {
   variable counter
  }
 }

 Point x: {args} {error "abstract slot, override in clone"}
 Point y: {args} {error "abstract slot, override in clone"}

 Point to_s: {} {
  return "id: [next] ([self x],[self y])"
 }

 Point create: {x y} {
  set obj [self clone ::self::objs::obj[incr ::self::objs::counter]]
  $obj x: $x
  $obj y: $y
  return $obj
 }

 Object clone MousePointer
 MousePointer addChild pos [Point create 130 140]
 
 MousePointer pos x
 MousePointer pos to_s
 
 MousePointer delete
 # child is gone
 info commands ::self::objs::*

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References