Artifact Content
Not logged in

Artifact b22932f6d80e999ab71810a91329ec73387ab372:


# -*- Tcl -*-
package provide xotcl::mixinStrategy 2.0

package require XOTcl 2.0

namespace eval ::xotcl::mixinStrategy {
  namespace import ::xotcl::*

  @ @File { description {
    These methods provide support for managing "strategies",  i.e. 
    mixin-classes, where only one kind of a family of conformant 
    mixins should be registered.
    <@p>
    Naming conventions for strategies:
    All strategies must follow the naming convention 'kind=implementation'. 
    Examples are the persistency strategy 'eager' specified as
    'persistent=eager' or the persistency strategy 'lazy' (specified as
    'persistent=lazy')
  }}

  @ Object instproc mixinStrategy {strategy "Strategy to be added" } {
    description {
      This method adds or replaces a new strategy from the mixin
      list. Strategies are named following the convention mentioned 
      above.
    }
    return "old strategy"
  }

  Object instproc mixinStrategy {strategy} {
    regexp {:?([^:=]+)=} $strategy _ kind
    set mixins ""
    set oldStrategy ""
    foreach mixin [my info mixin] {
      if {[string match *${kind}=* $mixin]} {
	lappend mixins $strategy
	set oldStrategy $mixin
      } else {
	lappend mixins $mixin
      }
    }
    if {$oldStrategy eq ""} {
      lappend mixins $strategy
    }
    my mixin $mixins
    return $oldStrategy
  }

  @ Object instproc mixinQueryStrategy {kind "strategy kind"} {
    description {
      This method searches the mixin list for a mixin of this
      kind (starting with $kind=)
    }
    return "returns the matching strategy"
  }

  Object instproc mixinQueryStrategy {kind} {
    set m [my info mixin]
    return [::lindex $m [::lsearch -glob $m $kind=*]]
  }

  @ Object instproc add {construct "(inst) 'filter' or 'mixin'" args "to be added"} {
    description "add the specified (inst) 'filters' or 'mixins'"
    return "empty"
  }

  Object instproc add {kind args} {
    if {$kind != {instfilter} && $kind != {instmixin} &&
	$kind != {filter} && $kind != {mixin}} {
      error "Usage: <object> [self proc] <instfilter|instmixin|filter|mixin> ..."
    }
    ::set classes [my info $kind]
    eval ::lappend classes $args
    my $kind $classes
    #puts stderr "$kind of [self] are now: ´[my info $kind]´"
  }
  @ Object instproc remove {construct "(inst) 'filter' or 'mixin'" args "to be removed"} {
    description "remove the specified (inst) 'filters' or 'mixins'"
    return "empty"
  }
  Object instproc remove {kind args} {
    if {$kind != {instfilter} && $kind != {instmixin} &&
	$kind != {filter} && $kind != {mixin}} {
      error "Usage: <object> [self proc] <instfilter|instmixin|filter|mixin> ..."
    }
    ::set classes [my info $kind]
    foreach c $args {
      ::set pos [::lsearch $classes $c]
      if {$pos == -1} { 
	error "$kind ´$c´ could not be removed" 
      } else {
	set $classes [::lreplace $classes $pos $pos]
      }
    } 
    my $kind $classes
    # puts stderr "$kind of [self] are now: ´[my info $kind]´"
  }
}