Tcl Library Source Code

###
# Author: Sean Woods, [email protected]
##
# TclOO routines to implement property tracking by class and object
###
package require dicttool
package provide oo::meta 0.7

namespace eval ::oo::meta {
  variable dirty_classes {}
  variable core_classes {::oo::class ::oo::object}
}

proc ::oo::meta::args_to_dict args {

        set result [linsert $result 0 $item]
      }
    }
  }
  return $result
}

proc oo::meta::info {class submethod args} {
  set class [::oo::meta::normalize $class]
  switch $submethod {
    rebuild {

      ::oo::meta::rebuild $class

    }
    is {
      set info [metadata $class]
      return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
    }
    for -
    map {

      set result {}
      foreach {field value} [dict getnull $info {*}$args] {
        dict set result [string trimright $field :] $value
      }
      return $result
    }
    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 {
      set result [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]]
      ladd result {*}[lrange $args 1 end]

    }
    append -
    incr -
    lappend -
    set -
    unset -
    update {

      ::oo::meta::rebuild $class

      ::dict $submethod ::oo::meta::local_property($class) {*}$args
    }
    merge {

      ::oo::meta::rebuild $class

      set ::oo::meta::local_property($class) [dict rmerge $::oo::meta::local_property($class) {*}$args]
    }
    dump {
      set info [metadata $class]
      return $info
    }
    default {

  if {[::info exists local_property($class)]} {
    lappend metadata $local_property($class)
  }
  set metadata [dict rmerge {*}$metadata]
  set cached_property($class) $metadata
  return $metadata
}

proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
  }
}

proc ::oo::meta::search args {
  variable local_property

  set path [lrange $args 0 end-1]
  set value [lindex $args end]

#checker -scope global exclude warnUndefinedVar
# var in question is 'dir'.
if {![package vsatisfies [package provide Tcl] 8.5]} {
    # PRAGMA: returnok
    return
}
package ifneeded oo::meta 0.7 [list source [file join $dir oometa.tcl]]
package ifneeded oo::option 0.3 [list source [file join $dir oooption.tcl]]

::namespace eval ::tool::define {}

if {![info exists ::tool::dirty_classes]} {
  set ::tool::dirty_classes {}
}

###
# Monkey patch oometa's rebuild function to
# include a notifier to tool
###
proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}


###
# 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
  foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
    #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]
      if {$arglist in {args {}}} {

    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}
    oo::define $thisclass method $ensemble {{method default} args} $body
    # Define a property for this ensemble for introspection
    ::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} {

set ::tool::tool_root [file dirname $cwd]
::tool::pathload $cwd {
  uuid.tcl
  ensemble.tcl
  metaclass.tcl
  event.tcl
} $idxfile
package provide tool 0.6

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tool::define::constructor {arglist rawbody} {
  set body {
::tool::object_create [self] [info object class [self]]

# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  append body {
# Run "initialize"
my initialize

  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::tool::object_create {objname {class {}}} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    set ${varname}($objname) {}
  }
  if {$class eq {}} {
    set class [info object class $objname]
  }
   set object_info($objname) [list class $class]
  if {$class ne {}} {
    $objname graft class $class
    foreach command [info commands [namespace current]::dynamic_object_*] {
      $command $objname $class
    }
  }
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool 0.6 [list source [file join $dir index.tcl]]