|
407
|
1 package IMPL::TypeKeyedCollection;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use IMPL::Const qw(:prop);
|
|
|
5 use IMPL::lang;
|
|
|
6 use IMPL::declare {
|
|
|
7 require => {
|
|
|
8 ArgException => '-IMPL::InvalidArgumentException'
|
|
|
9 },
|
|
|
10 base => [
|
|
|
11 'IMPL::Object' => undef
|
|
|
12 ],
|
|
|
13 props => [
|
|
|
14 _items => PROP_RW | PROP_DIRECT,
|
|
|
15 _cache => PROP_RW | PROP_DIRECT,
|
|
|
16 _reverse => PROP_RW | PROP_DIRECT
|
|
|
17 ]
|
|
|
18 };
|
|
|
19
|
|
|
20 sub CTOR {
|
|
|
21 my ($this,$items,$reverse) = @_;
|
|
|
22
|
|
|
23 $items = {}
|
|
|
24 unless ref($items) eq 'HASH';
|
|
|
25
|
|
|
26 $this->{$_items} = $items;
|
|
|
27 $this->{$_reverse} = $reverse;
|
|
|
28 }
|
|
|
29
|
|
|
30 sub Get {
|
|
|
31 my ($this,$type) = @_;
|
|
|
32
|
|
|
33 die ArgException->new(type => 'Invalid type', $type)
|
|
|
34 if not $type or ref($type);
|
|
|
35
|
|
|
36 if(my $val = $this->{$_cache}{$type}) {
|
|
|
37 return $val;
|
|
|
38 } else {
|
|
|
39 if ($this->_reverse) {
|
|
|
40 my $val = $this->{$_items}{$type};
|
|
|
41
|
|
|
42 unless(defined $val) {
|
|
|
43 my $matching;
|
|
|
44 while ( my ($k,$v) = each %{$this->{$_items}}) {
|
|
|
45 if (isclass($k,$type) && (not($matching) || isclass($k,$matching)) ) {
|
|
|
46 $matching = $k;
|
|
|
47 $val = $v;
|
|
|
48 }
|
|
|
49 }
|
|
|
50 }
|
|
|
51
|
|
|
52 return $this->{$_cache}{$type} = $val;
|
|
|
53
|
|
|
54 } else {
|
|
|
55 no strict 'refs';
|
|
|
56
|
|
|
57 my @isa = $type;
|
|
|
58
|
|
|
59 while (@isa) {
|
|
|
60 my $sclass = shift @isa;
|
|
|
61
|
|
|
62 $val = $this->{$_items}{$sclass};
|
|
|
63
|
|
|
64 return($this->{$_cache}{$type} = $val)
|
|
|
65 if defined $val; # zeroes and empty strings are also valid
|
|
|
66
|
|
|
67 push @isa, @{"${sclass}::ISA"};
|
|
|
68 }
|
|
|
69 return;
|
|
|
70 }
|
|
|
71 }
|
|
|
72 }
|
|
|
73
|
|
|
74 sub Set {
|
|
|
75 my ($this,$type,$value) = @_;
|
|
|
76
|
|
|
77 die ArgException->new(type => 'Invalid type', $type)
|
|
|
78 if not $type or ref($type);
|
|
|
79
|
|
|
80 $this->{$_items}{$type} = $value;
|
|
|
81
|
|
|
82 delete $this->{$_cache};
|
|
|
83
|
|
|
84 return $value;
|
|
|
85 }
|
|
|
86
|
|
|
87 sub Delete {
|
|
|
88 my ($this,$type) = @_;
|
|
|
89
|
|
|
90 if(defined delete $this->{$_items}{$type} ) {
|
|
|
91 delete $this->{$_cache};
|
|
|
92 return 1;
|
|
|
93 }
|
|
|
94 return;
|
|
|
95 }
|
|
|
96
|
|
|
97 1;
|
|
|
98
|
|
|
99 __END__
|
|
|
100
|
|
|
101 =pod
|
|
|
102
|
|
|
103 =head1 NAME
|
|
|
104
|
|
|
105 C<IMPL::TypeKeyedCollection> - коллекция, ключами которой являются типы.
|
|
|
106
|
|
|
107 =head1 SYNOPSIS
|
|
|
108
|
|
|
109 =begin code
|
|
|
110
|
|
|
111 package Foo;
|
|
|
112
|
|
|
113 package Bar;
|
|
|
114 our @ISA = qw(Foo);
|
|
|
115
|
|
|
116 package Baz;
|
|
|
117 our @ISA = qw(Foo);
|
|
|
118
|
|
|
119 package main;
|
|
|
120 use IMPL::require {
|
|
|
121 TypeKeyedCollection => 'IMPL::TypeKeyedCollection'
|
|
|
122 };
|
|
|
123
|
|
|
124 my $col = TypeKeyedCollection->new({
|
|
|
125 Foo => 'base',
|
|
|
126 Bar => 'BAAAR'
|
|
|
127 });
|
|
|
128
|
|
|
129 print $col->Get('Foo'); # 'base'
|
|
|
130 print $col->Get('Bar'); # 'BAAAR'
|
|
|
131 print $col->Get('Baz'); # 'base'
|
|
|
132
|
|
|
133 =end code
|
|
|
134
|
|
|
135 =head1 DESCRIPTION
|
|
|
136
|
|
|
137 Использует иерархию классов для определения наиболее подходяжего значения в
|
|
|
138 коллекции.
|
|
|
139
|
|
|
140 =cut |
