Tcl Library Source Code

    branchset {
      ::oo::meta::rebuild $class
      foreach {field value} [lindex $args end] {
        ::dict set ::oo::meta::local_property($class) {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    leaf_add {
      if {[::info exists ::oo::meta::local_property($class)]} {
        set result [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]]
      }
      ladd result {*}[lrange $args 1 end]
      dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result
    }
    leaf_remove {
      if {![::info exists ::oo::meta::local_property($class)]} return
      set result {}
      forearch element [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]] {
        if { $element in [lrange $args 1 end]} continue
        lappend result $element
      }
      dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result
    }

    foreach dclass $dirty_classes {
      foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
        if {$dclass in $cancestors} {
          unset -nocomplain ::oo::meta::cached_property($cclass)
          unset -nocomplain ::oo::meta::cached_hierarchy($cclass)
        }
      }
      if {![::info exists ::oo::meta::local_property($dclass)]} continue
      if {[dict getnull $::oo::meta::local_property($dclass) classinfo type:] eq "core"} {
        if {$dclass ni $::oo::meta::core_classes} {
          lappend ::oo::meta::core_classes $dclass
        }
      }
    }
    set dirty_classes {}

    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}

proc ::tool::ensemble_build_map args {





  set emap {}
  foreach thisclass $args {
    foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
      foreach {submethod subinfo} $einfo {

        dict set emap $ensemble $submethod $subinfo
      }
    }
  }
  return $emap
}


proc ::tool::ensemble_methods emap {


  set result {}
  foreach {ensemble einfo} $emap {
    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]

      set body [lindex [dict get $einfo _preamble:] 1]
    } else {
      set body {}
    }
    append body \n [list set methodlist $methodlist]
    append body \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append body \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $body]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tool::dynamic_object_ensembles {thisobject thisclass} {
  variable trace
  set ensembledict {}
  foreach dclass $::tool::dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::tool::obj_ensemble_cache($cclass)
      }
    }
  }
  set ::tool::dirty_classes {}
  ###
  # Only go through the motions for classes that have a locally defined
  # ensemble method implementation
  ###
  if {[info exists ::tool::obj_ensemble_cache($thisclass)]} return
  set emap [::tool::ensemble_build_map $thisclass]
  set body [::tool::ensemble_methods $emap]
  oo::define $thisclass $body
  # Define a property for this ensemble for introspection
  foreach {ensemble einfo} $emap {
    ::oo::meta::info $thisclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
  }
  set ::tool::obj_ensemble_cache($thisclass) 1

}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tool::define::method {rawmethod args} {

  return $result
}

###
# topic: a92cd258900010f656f4c6e7dbffae57
###
proc ::tool::dynamic_methods class {
  ::oo::meta::rebuild $class
  set metadata [::oo::meta::metadata $class]
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class $metadata
  }
}

###

# This class is inherited by all classes that have options.
#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  
  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    

        }
      }
    }
    set dat [dict getnull $public option_info]
    if {$integrate} {
      my meta rmerge [list option $dat]
    }

    my variable option_canonical
    array set option_canonical [dict getnull $public option_canonical]
    set dictargs {}
    foreach {var getcmd} [dict getnull $public option_default_command] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var [{*}[string map [list %field% $var %self% [namespace which my]] $getcmd]]
    }
    foreach {var value} [dict getnull $public option_default_value] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var $value
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {

  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      my ClassPublicApply $class
    }
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      my Morph_leave
      my variable mixins
      oo::objdefine [self] class ::${newclass}
      my graft class ::${newclass}
      # Reapply mixins
      my mixin {*}$mixins
      my InitializePublic
      my Morph_enter
    }
  }

  ###
  # Commands to perform as this object transitions out of the present class

      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }
}

test tool-option_class-002 {Test option class} {
  ObjectOptionTest5 organ master
} GNDN

test tool-option_class-003 {Test option class} {
  ObjectOptionTest5 <master> puts FOO
} {puts FOO}

###
# Second round of testing
# Make sure the various and sundry ways to generate
# dynamic methods follow through morphs, mixins,
# and class method definitions
###

tool::class create WidgetClass {
  class_method unknown args {
    set tkpath [lindex $args 0]
    if {[string index $tkpath 0] eq "."} {
      set obj [my new $tkpath {*}[lrange $args 1 end]]
      $obj tkalias $tkpath
      return $tkpath
    }
    next {*}$args
  }
  
  constructor {TkPath args} {
    my variable hull
    set hull $TkPath
    my graft hull $TkPath
  }
    
  method tkalias tkname {
    set oldname $tkname
    my variable tkalias
    set tkalias $tkname
    set self [self]
    set hullwidget [::info object namespace $self]::tkwidget
    my graft tkwidget $hullwidget
    #rename ::$tkalias $hullwidget
    my graft hullwidget $hullwidget
    ::tool::object_rename [self] ::$tkalias
    #my Hull_Bind $tkname
    return $hullwidget
  }
}

test tool-class-method-001 {Test Tk style creator} {
  WidgetClass .foo
  .foo organ hull
} {.foo}

tool::class create WidgetNewClass {
  superclass WidgetClass
}

test tool-class-method-002 {Test Tk style creator inherited by morph} {
  WidgetNewClass .bar
  .bar organ hull
} {.bar}

tool::class create DummyClass {
  method i_am_here {} {
    return DummyClass
  }
}


tool::class create OrganClass {
  option db {class organ default ::noop}
  constructor args {
    my config set $args
  }
}
DummyClass create ::DbObj
OrganClass create OrganObject db ::DbObj
test tool-constructor-args-001 {Test that organs passed as options map correctly} {
  OrganObject organ db
} {::DbObj} 
test tool-constructor-args-002 {Test that organs passed as options map correctly} {
  OrganObject cget db
} {::DbObj}

tool::object create MorphOrganObject#1
tool::object create MorphOrganObject#2
MorphOrganObject#2 graft db ::DbObj

MorphOrganObject#1 morph OrganClass
test tool-constructor-args-003 {Test that a default for an organ option is applied after a morph} {
  MorphOrganObject#1  organ db
} {::noop}

MorphOrganObject#2 morph OrganClass
test tool-constructor-args-004 {Test that a default for an organ option is NOT applied if the graft exists following a morph} {
  MorphOrganObject#2  organ db
} {::DbObj}

tool::object create MorphOrganObject#3
tool::object create MorphOrganObject#4
MorphOrganObject#4 graft db ::DbObj
MorphOrganObject#3 mixin OrganClass
test tool-constructor-args-005 {Test that a default for an organ option is applied during a mixin} {
  MorphOrganObject#3  organ db
} {::noop}

MorphOrganObject#4 mixin OrganClass
test tool-constructor-args-006 {Test that a default for an organ option is NOT applied if the graft exists during a mixin} {
  MorphOrganObject#4  organ db
} {::DbObj}



# -------------------------------------------------------------------------


testsuiteCleanup

# Local variables:
# mode: tcl