# HG changeset patch # User cin # Date 1392213723 -14400 # Node ID de1f875e8875794a1dbfdd14526868f39d0d786a # Parent 5aff94ba842f5e2891e4e0b17a25a703799a7f37 added reverse matching lookup to TypeKeyedCollection (find closest descendant) diff -r 5aff94ba842f -r de1f875e8875 Lib/IMPL/TypeKeyedCollection.pm --- a/Lib/IMPL/TypeKeyedCollection.pm Wed Feb 12 13:36:24 2014 +0400 +++ b/Lib/IMPL/TypeKeyedCollection.pm Wed Feb 12 18:02:03 2014 +0400 @@ -11,17 +11,19 @@ ], props => [ _items => PROP_RW | PROP_DIRECT, - _cache => PROP_RW | PROP_DIRECT + _cache => PROP_RW | PROP_DIRECT, + _reverse => PROP_RW | PROP_DIRECT ] }; sub CTOR { - my ($this,$items) = @_; + my ($this,$items,$reverse) = @_; $items = {} unless ref($items) eq 'HASH'; $this->{$_items} = $items; + $this->{$_reverse} = $reverse; } sub Get { @@ -33,21 +35,38 @@ if(my $val = $this->{$_cache}{$type}) { return $val; } else { - no strict 'refs'; - - my @isa = $type; - - while (@isa) { - my $sclass = shift @isa; - - $val = $this->{$_items}{$sclass}; + if ($this->_reverse) { + my $val = $this->{$_items}{$type}; + + unless(defined $val) { + my $matching; + while ( my ($k,$v) = each %{$this->{$_items}}) { + if (isclass($k,$type) && (not($matching) || isclass($k,$matching)) ) { + $matching = $k; + $val = $v; + } + } + } + + return $this->{$_cache}{$type} = $val; + + } else { + no strict 'refs'; + + my @isa = $type; - return($this->{$_cache}{$type} = $val) - if defined $val; # zeroes and empty strings are also valid - - push @isa, @{"${sclass}::ISA"}; - } - return; + while (@isa) { + my $sclass = shift @isa; + + $val = $this->{$_items}{$sclass}; + + return($this->{$_cache}{$type} = $val) + if defined $val; # zeroes and empty strings are also valid + + push @isa, @{"${sclass}::ISA"}; + } + return; + } } }