Tcl Library Source Code

    dict set local_data($url) $field $value
  }
  if {$send} {
    broadcast ~SERVICE $url $local_data($url)
    update
  }
}

proc ::cluster::get_free_port {{startport 50000}} {
  set port $startport
  set conflict 1
  while {$conflict} {
    set conflict 0
    set port [::nettool::find_port $port]
    foreach {url info} [search *@[macid]] {
      if {[dict exists $info port] && [dict get $info port] eq $port} {
        incr port
        set conflict 1
        break
      }
    }
  }
  return $port
}

proc ::cluster::log args {
  broadcast LOG {*}$args
}

proc ::cluster::LookUp {rawname} {
  set self [self]

  # See: RFC3692 and http://www.iana.org
  variable discovery_group 224.0.0.200
  variable local_port {}
  variable local_macid [lindex [::nettool::mac_list] 0]
  variable local_pid   [::uuid::uuid generate]
}

package provide nameserv::cluster 0.2.2

if {![package vsatisfies [package provide Tcl] 8]} {return}
package ifneeded nameserv::common 0.1 [list source [file join $dir common.tcl]]

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded nameserv         0.4.2 [list source [file join $dir nns.tcl]]
package ifneeded nameserv::server 0.3.2 [list source [file join $dir server.tcl]]
package ifneeded nameserv::auto   0.3   [list source [file join $dir nns_auto.tcl]]
package ifneeded nameserv::cluster 0.2.2   [list source [file join $dir nns_cluster.tcl]]

###
# Author: Sean Woods, [email protected]
##
# TclOO routines to implement property tracking by class and object
###

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

if {[::info command ::tcl::dict::getnull] eq {}} {
  proc ::tcl::dict::getnull {dictionary args} {
    if {[exists $dictionary {*}$args]} {
      get $dictionary {*}$args
    }
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
}
if {[::info command ::tcl::dict::rmerge] eq {}} {
  ###
  # Test if element is a dict
  ###
  proc ::tcl::dict::is_dict { d } {
    # is it a dict, or can it be treated like one?
    if {[catch {dict size $d} err]} {
      #::set ::errorInfo {}
      return 0
    }
    return 1
  }
  
  ###
  # title: A recursive form of dict merge
  # description:
  # A routine to recursively dig through dicts and merge
  # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/
  ###
  proc ::tcl::dict::rmerge {a args} {
    ::set result $a
    # Merge b into a, and handle nested dicts appropriately
    ::foreach b $args {
      for { k v } $b {
        if {[string index $k end] eq ":"} {
          # Element names that end in ":" are assumed to be literals
          set result $k $v
        } elseif { [dict exists $result $k] } {
          # key exists in a and b?  let's see if both values are dicts
          # both are dicts, so merge the dicts
          if { [is_dict [get $result $k]] && [is_dict $v] } {
            set result $k [rmerge [get $result $k] $v]
          } else {  
            set result $k $v
          }
        } else {
          set result $k $v
        }
      }
    }
    return $result
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
}

proc ::oo::meta::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

proc ::oo::meta::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimleft $var -] $val
  }
  return $result
}

proc ::oo::meta::ancestors class {
  set class [::oo::meta::normalize $class]
  set thisresult {}
  set result {}
  set queue $class
  variable core_classes
  
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      if {$qclass in $core_classes} continue
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
      foreach aclass [::info class mixins $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
    }
    foreach item $tqueue {
      if { $item ni $result } {
        set result [linsert $result 0 $item]
      }
    }
  }
  return $result
}

proc ::oo::meta::info {class submethod args} {
  set class [::oo::meta::normalize $class]
  switch $submethod {
    rebuild {
      if {$class ni $::oo::meta::dirty_classes} {
        lappend ::oo::meta::dirty_classes $class
      }
    }
    is {
      set info [properties $class]
      return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
    }
    for -
    map {
      set info [properties $class]

      return [uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]]
    }
    with {
      upvar 1 TEMPVAR info
      set info [properties $class]
      return [uplevel 1 [list ::dict with TEMPVAR {*}$args]]
    }
    append -
    incr -
    lappend -
    set -
    unset -
    update {
      if {$class ni $::oo::meta::dirty_classes} {
        lappend ::oo::meta::dirty_classes $class
      }
      ::dict $submethod ::oo::meta::local_property($class) {*}$args
    }
    merge {
      if {$class ni $::oo::meta::dirty_classes} {
        lappend ::oo::meta::dirty_classes $class
      }
      set ::oo::meta::local_property($class) [dict rmerge $::oo::meta::local_property($class) {*}$args]
    }
    dump {
      set info [properties $class]
      return $info
    }
    default {
      set info [properties $class]
      return [::dict $submethod $info {*}$args] 
    }
  }
}







proc ::oo::meta::normalize class {
  set class ::[string trimleft $class :]
}

proc ::oo::meta::properties {class {force 0}} {
  set class [::oo::meta::normalize $class]
  ###
  # Destroy the cache of all derivitive classes
  ###
  if {$force} {
    unset -nocomplain ::oo::meta::cached_property
    unset -nocomplain ::oo::meta::cached_hierarchy
  } else {
    variable dirty_classes
    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 {[dict getnull $::oo::meta::local_property($dclass) classinfo type:] eq "core"} {
        if {$dclass ni $::oo::meta::core_classes} {
          lappend ::oo::meta::core_classes $dclass
        }
      }
    }
  }

  ###
  # If the cache is available, use it
  ###

  # them for future use
  ###
  variable cached_hierarchy
  set properties {}
  set stack {}
  variable local_property
  set cached_hierarchy($class) [::oo::meta::ancestors $class]
  foreach aclass [lrange $cached_hierarchy($class) 0 end-1] {
    if {[::info exists local_property($aclass)]} {
      lappend properties $local_property($aclass)
    }
  }
  lappend properties {classinfo {type {}}}
  if {[::info exists local_property($class)]} {
    set properties [dict rmerge {*}$properties $local_property($class)]
  } else {
    set properties [dict rmerge {*}$properties]
  }
  set cached_property($class) $properties
  return $properties
}


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

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

  set result {}
  foreach {class info} [array get local_property] {
    if {[dict exists $info {*}$path:]} {
      if {[string match [dict get $info {*}$path:] $value]} {
        lappend result $class
      }
      continue
    }
    if {[dict exists $info {*}$path]} {
      if {[string match [dict get $info {*}$path] $value]} {
        lappend result $class
      }
    }
  }
  return $result
}

proc ::oo::define::meta {args} {
  set class [lindex [::info level -1] 1]
  ::oo::meta::info $class {*}$args
}

###
# Add properties and option handling
###
proc ::oo::define::property args {
  set class [lindex [::info level -1] 1]
  switch [llength $args] {
    2 {
      set type const
      set property [string trimleft [lindex $args 0] :]
      set value [lindex $args 1]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    3 {
      set type     [lindex $args 0]
      set property [string trimleft [lindex $args 1] :]
      set value    [lindex $args 2]
      ::oo::meta::info $class set $type $property: $value
      return
    }
  }
  ::oo::meta::info $class set {*}$args
}

proc ::oo::define::option {field argdict} {
  set class [lindex [::info level -1] 1]
  foreach {prop value} $argdict {
    ::oo::meta::info $class set option $field [string trim $prop :]: $value
  }
}

oo::define oo::class {

  method meta {submethod args} {
    set class [self]
    switch $submethod {
      is {

      lappend -
      set -
      unset -
      update {
        ::oo::meta::info $class rebuild
        return [dict $submethod config {*}$args]
      }
      merge {
        ::oo::meta::info $class rebuild
        return [dict $submethod config {*}$args]
      }
      default {
        set info [::oo::meta::properties $class]
        return [dict $submethod $info {*}$args] 
      }
    }
  }
  
}

oo::define oo::object {
    
  method meta {submethod args} {
    my variable config
    if {![::info exists config]} {
      set config {}
    }
    set class [::info object class [self object]]
    switch $submethod {
      cget {
        # Get a constant from the local dict, a field in the const section of meta data, or under the root
        set path [lrange $args 0 end-1]
        set field [string trim [lindex $args end] :]
        if {[dict exists $config {*}$path $field:]} {
          return [dict get $config {*}$path $field:]
        }
        if {[dict exists $config {*}$path $field]} {
          return [dict get $config {*}$path $field]
        }
        set class_properties [::oo::meta::properties $class]
        if {[dict exists $class_properties const {*}$path $field:]} {
          return [dict get $class_properties const {*}$path $field:]
        }
        if {[dict exists $class_properties const {*}$path $field]} {
          return [dict get $class_properties const {*}$path $field]
        }
        if {[dict exists $class_properties {*}$path $field:]} {
          return [dict get $class_properties {*}$path $field:]
        }
        if {[dict exists $class_properties {*}$path $field]} {
          return [dict get $class_properties {*}$path $field]
        }
        return {}
      }
      is {

        set value [my meta cget {*}[lrange $args 1 end]]
        return [string is [lindex $args 0] -strict $value]
      }
      for -
      map {
        set class_properties [::oo::meta::properties $class]
        set info [dict rmerge $class_properties $config]
        return [uplevel 1 [list dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]]
      }
      with {
        set class_properties [::oo::meta::properties $class]
        upvar 1 TEMPVAR info
        set info [dict rmerge $class_properties $config]
        return [uplevel 1 [list dict with TEMPVAR {*}$args]]
      }
      dump {
        set class_properties [::oo::meta::properties $class]
        return [dict rmerge $class_properties $config]
      }
      append -
      incr -
      lappend -
      set -
      unset -
      update {
        return [dict $submethod config {*}$args]
      }
      rmerge -
      merge {
        set config [dict rmerge $config {*}$args]
        return $config
      }
      getnull {
        if {[dict exists $config {*}$args]} {
          return [dict get $config {*}$args]
        }
        set class_properties [::oo::meta::properties $class]
        if {[dict exists $class_properties {*}$args]} {
          return [dict get $class_properties {*}$args]
        }
        return {}
      }
      get {
        if {[dict exists $config {*}$args]} {
          return [dict get $config {*}$args]
        }
        set class_properties [::oo::meta::properties $class]
        if {[dict exists $class_properties {*}$args]} {
          return [dict get $class_properties {*}$args]
        }
        error "Key {*}$args does not exist"
      }
      default {
        set class_properties [::oo::meta::properties $class]
        set info [dict rmerge $class_properties $config]
        return [dict $submethod $info {*}$args] 
      }
    }
  }
}

package provide oo::meta 0.2

  method InitializePublic {} {
    my variable config
    if {![info exists config]} {
      set config {}
    }
    set dat [my meta getnull option]
    foreach {var info} $dat {
      if {[dict exists $info set-command:]} {
        if {[catch {my cget $var} value]} {
          dict set config $var [my cget $var default:]
        } else {
          if { $value eq {} } {
            dict set config $var [my cget $var default:]
          }
        }
      }
      if {![dict exists $config $var]} {
        dict set config $var [my cget $var default:]
      }
    }
    foreach {var info} [my meta getnull variable] {
      if { $var eq "config" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default:]} {
          set $var [dict get $info default:]
        } else {
          set $var {}
        }
      }
    }
    foreach {var info} [my meta getnull array] {
      if { $var eq "config" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default:]} {
          array set $var [dict get $info default:]
        } else {
          array set $var {}
        }
      }
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget {field {default {}}} {
    my variable config
    set field [string trimleft $field -]
    set dat [my meta getnull option]
  
    if {[my meta is true const options_strict:] && ![dict exists $dat $field]} {
      error "Invalid option -$field. Valid: [dict keys $dat]"
    }
    set info [dict getnull $dat $field]    
    if {$default eq "default"} {
      set getcmd [dict getnull $info default-command:]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        return [dict getnull $info default:]
      }
    }
    if {[dict exists $dat $field]} {
      set getcmd [dict getnull $info get-command:]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      }
      if {![dict exists $config $field]} {
        set getcmd [dict getnull $info default-command:]
        if {$getcmd ne {}} {
          dict set config $field [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
        } else {
          dict set config $field [dict getnull $info default:]
        }
      }
      if {$default eq "varname"} {
        set varname [my varname visconfig]
        set ${varname}($field) [dict get $config $field]
        return "${varname}($field)"
      }
      return [dict get $config $field]
    }



    return [my meta cget $field]
  }
  
  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"

  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method configurelist dictargs {
    my variable config
    set dat [my meta getnull option]
    if {[my meta is true const options_strict:]} {
      foreach {field val} $dictargs {
        if {![dict exists $dat $field]} {
          error "Invalid option $field. Valid: [dict keys $dat]"
        }
      }
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    ###
    # Apply all inputs with special rules
    ###

  ###
  method configurelist_triggers dictargs {
    set dat [my meta getnull option]
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
}
package provide oo::option 0.2

    my configure {*}$args
  }
}

oo::class create bar {
  superclass ::foo
  property shape oval
  option color {
    label Color
    default green
  }
}

test oo-class-meta-001 {Test accessing properties} {
  foo meta get const color:
} blue

test oo-class-meta-002 {Test accessing properties} {
  bar meta get const color:
} blue

test oo-class-meta-003 {Test accessing properties} {
  bar meta get const shape:
} oval

bar create cheers color pink
# Pulling the meta data from const will return
# the value specified in the class
test oo-object-meta-001 {Test accessing properties} {
  cheers meta get const color:
} blue

# Accessing the data via cget pulls from the local
# definition
test oo-object-meta-001a {Test accessing properties} {
  cheers meta cget color
} pink
# With or without the trailing :
test oo-object-meta-001b {Test accessing properties} {
  cheers meta cget color:
} pink
# And using the local cget
test oo-object-meta-001c {Test accessing properties} {
  cheers cget color
} pink

test  oo-object-meta-002 {Test accessing properties} {
  cheers meta get const shape:
} oval

test  oo-object-meta-003 {Test accessing properties} {
  cheers cget color
} pink

bar create moes
test  oo-object-meta-004 {Test accessing properties} {
  moes meta get const color:
} blue

test  oo-object-meta-004a {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-004a {Test accessing properties} {
  moes cget color:
} green

test  oo-object-meta-005 {Test accessing properties} {
  moes meta get const shape:
} oval

test  oo-object-meta-006 {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-007 {Test the CGET retrieves a property if an option doesn't exist} {
  moes cget shape
} oval

###
# Test altering a property
###

oo::define ::foo property woozle whoop

test oo-modclass-meta-001 {Test accessing properties of an altered class} {
  foo meta get const woozle:
} whoop

test oo-modclass-meta-002 {Test accessing properties of the descendent of an altered class} {
  bar meta get const woozle:
} whoop

test oo-modobject-meta-001 {Test the accessing of properties of an instance of an altered class} {
  moes meta get const woozle:
} whoop

test obj-meta-for-001 {Test object meta for} {
  set result {}
  moes meta for {key value} option {
    lappend result $key $value
  }
  set result
} {color {label: Color default: green}}



test obj-meta-with-001 {Test object meta with} {
  set result {}
  moes meta with option {}
  set color

} {label: Color default: green}


test obj-meta-for-001 {Test class meta for} {
  set result {}
  bar meta for {key value} option {
    lappend result $key $value
  }
  set result
} {color {label: Color default: green}}



test obj-meta-with-001 {Test class meta with} {
  set result {}
  bar meta with option {}
  set color

} {label: Color default: green}


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

# Test of recursive dicts

oo::class create baz {
  superclass ::bar
  meta set option color default: purple  
}

test obj-meta-recursive-1 {Test that meta set works with recursive dicts} {
  set result {}
  baz meta get option color default:
} {purple}

test obj-meta-recursive-2 {Test that meta set works with recursive dicts} {
  set result {}
  baz meta get option color label:
} {Color}

testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# 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::util 1.2.2 [list source [file join $dir ooutil.tcl]]
package ifneeded oo::meta 0.2 [list source [file join $dir oometa.tcl]]
package ifneeded oo::option 0.2 [list source [file join $dir oooption.tcl]]

#
#        eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
# 
proc ::zipfile::mkzip::mkzip {filename args} {
  array set opts {
      -zipkit 0 -runtime "" -comment "" -directory ""
      -exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"}
      -verbose 0
  }
  
  while {[string match -* [set option [lindex $args 0]]]} {
      switch -exact -- $option {
          -verbose { set opts(-verbose) 1}
          -zipkit  { set opts(-zipkit) 1 }
          -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] }
          -runtime { set opts(-runtime) [pop args 1] }
          -directory {set opts(-directory) [file normalize [pop args 1]] }
          -exclude {set opts(-exclude) [pop args 1] }
          -- { pop args ; break }
          default {

  if {$opts(-directory) ne ""} {
      set paths [walk $opts(-directory) $opts(-exclude)]
  } else {
      set paths [glob -nocomplain {*}$args]
  }
  foreach path $paths {
      if {[string is true $opts(-verbose)]} {
        puts $path
      }
      append cd [add_file_to_archive $zf $opts(-directory) $path]
      incr count
  }
  set cdoffset [tell $zf]
  set endrec [binary format a4ssssiis PK\05\06 0 0 \
                  $count $count [string length $cd] $cdoffset\
                  [string length $opts(-comment)]]