diff Lib/IMPL/TypeKeyedCollection.pm @ 390:de1f875e8875

added reverse matching lookup to TypeKeyedCollection (find closest descendant)
author cin
date Wed, 12 Feb 2014 18:02:03 +0400
parents 96a522aeb359
children 69a1f1508696
line wrap: on
line diff
--- 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;
+    	}
     }
 }