Mercurial > pub > Impl

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
added reverse matching lookup to TypeKeyedCollection (find closest descendant)
author cin
date Wed, 12 Feb 2014 18:02:03 +0400
parents 96a522aeb359
children 69a1f1508696
comparison
equal deleted inserted replaced
389:5aff94ba842f 390:de1f875e8875
9 base => [ 9 base => [
10 'IMPL::Object' => undef 10 'IMPL::Object' => undef
11 ], 11 ],
12 props => [ 12 props => [
13 _items => PROP_RW | PROP_DIRECT, 13 _items => PROP_RW | PROP_DIRECT,
14 _cache => PROP_RW | PROP_DIRECT 14 _cache => PROP_RW | PROP_DIRECT,
15 _reverse => PROP_RW | PROP_DIRECT
15 ] 16 ]
16 }; 17 };
17 18
18 sub CTOR { 19 sub CTOR {
19 my ($this,$items) = @_; 20 my ($this,$items,$reverse) = @_;
20 21
21 $items = {} 22 $items = {}
22 unless ref($items) eq 'HASH'; 23 unless ref($items) eq 'HASH';
23 24
24 $this->{$_items} = $items; 25 $this->{$_items} = $items;
26 $this->{$_reverse} = $reverse;
25 } 27 }
26 28
27 sub Get { 29 sub Get {
28 my ($this,$type) = @_; 30 my ($this,$type) = @_;
29 31
31 if not $type or ref($type); 33 if not $type or ref($type);
32 34
33 if(my $val = $this->{$_cache}{$type}) { 35 if(my $val = $this->{$_cache}{$type}) {
34 return $val; 36 return $val;
35 } else { 37 } else {
36 no strict 'refs'; 38 if ($this->_reverse) {
37 39 my $val = $this->{$_items}{$type};
38 my @isa = $type; 40
39 41 unless(defined $val) {
40 while (@isa) { 42 my $matching;
41 my $sclass = shift @isa; 43 while ( my ($k,$v) = each %{$this->{$_items}}) {
42 44 if (isclass($k,$type) && (not($matching) || isclass($k,$matching)) ) {
43 $val = $this->{$_items}{$sclass}; 45 $matching = $k;
46 $val = $v;
47 }
48 }
49 }
50
51 return $this->{$_cache}{$type} = $val;
52
53 } else {
54 no strict 'refs';
55
56 my @isa = $type;
44 57
45 return($this->{$_cache}{$type} = $val) 58 while (@isa) {
46 if defined $val; # zeroes and empty strings are also valid 59 my $sclass = shift @isa;
47 60
48 push @isa, @{"${sclass}::ISA"}; 61 $val = $this->{$_items}{$sclass};
49 } 62
50 return; 63 return($this->{$_cache}{$type} = $val)
64 if defined $val; # zeroes and empty strings are also valid
65
66 push @isa, @{"${sclass}::ISA"};
67 }
68 return;
69 }
51 } 70 }
52 } 71 }
53 72
54 sub Set { 73 sub Set {
55 my ($this,$type,$value) = @_; 74 my ($this,$type,$value) = @_;