|
412
|
1 package IMPL::Config::Bag;
|
|
|
2 use strict;
|
|
|
3
|
|
414
|
4 use IMPL::lang qw(:base);
|
|
412
|
5 use IMPL::declare {
|
|
413
|
6 base => [
|
|
|
7 'IMPL::Object' => undef
|
|
|
8 ],
|
|
|
9 props => [
|
|
414
|
10 _parents => '*rw', # array of parent bags
|
|
415
|
11 _parentRev => '*rw', # the timestamp of the parent
|
|
|
12 _sealed => '*rw', # the bag has descendants
|
|
414
|
13 _cache => '*rw', # own or cached entries
|
|
|
14 _timestamp => '*rw',
|
|
|
15 _entries => '*rw', # each entry is represented by hash
|
|
|
16 # { isa => linear_isa_hash, owner => owner_of_the_entry, value => value }
|
|
413
|
17 ]
|
|
412
|
18 };
|
|
|
19
|
|
413
|
20 sub CTOR {
|
|
414
|
21 my ( $this, $p ) = @_;
|
|
|
22
|
|
|
23 if ($p) {
|
|
415
|
24 $p->_Seal();
|
|
414
|
25 my @parents;
|
|
|
26 push @parents, @{ $p->{$_parents} } if $p->{$_parents};
|
|
|
27 push @parents, $p;
|
|
415
|
28 $this->{$_parents} = \@parents;
|
|
|
29 $this->{$_parentRev} = $p->{$_timestamp};
|
|
414
|
30 }
|
|
|
31
|
|
|
32 $this->{$_timestamp} = 0;
|
|
|
33 $this->{$_cache} = {};
|
|
|
34 $this->{$_entries} = [];
|
|
|
35 }
|
|
|
36
|
|
|
37 sub GetParent {
|
|
415
|
38 my ($this) = @_;
|
|
|
39
|
|
|
40 $this->{$_parents} && $this->{$_parents}[ @{ $this->{$_parents} } - 1 ];
|
|
|
41 }
|
|
|
42
|
|
|
43 sub _Seal {
|
|
|
44 unless ($_[0]->{$_sealed}) {
|
|
|
45 $_[0]->{$_sealed} = 1;
|
|
|
46 $_[0]->{$_timestamp} = 0; # from now the timestamp is important
|
|
|
47 }
|
|
414
|
48 }
|
|
|
49
|
|
|
50 sub _Validate {
|
|
|
51 my ($this) = @_;
|
|
|
52
|
|
415
|
53 my $chain = $this->{$_parents}
|
|
|
54 or return 1;
|
|
414
|
55
|
|
415
|
56 my $rev = 0; # rev 0 means that parent was never modified
|
|
|
57 # this allows to made more efficient checks
|
|
|
58 my $flush;
|
|
|
59
|
|
|
60 foreach my $bag (@$chain, $this) {
|
|
|
61 # we need to updated all bags after the first change was detected;
|
|
|
62 if ($flush ||= $rev and $bag->{$_parentRev} != $rev) {
|
|
|
63 $bag->{$_cache} = {};
|
|
|
64 $bag->{$_parentRev} = $rev;
|
|
|
65 }
|
|
|
66 $rev = $bag->{$_timestamp};
|
|
414
|
67 }
|
|
415
|
68
|
|
|
69 return $flush ? 0 : 1;
|
|
413
|
70 }
|
|
|
71
|
|
412
|
72 sub Resolve {
|
|
414
|
73 my ( $this, $role ) = @_;
|
|
|
74
|
|
415
|
75 die IMPL::InvalidArgumentException->new('role')
|
|
|
76 unless defined $role;
|
|
|
77
|
|
|
78 if ( my $d = $this->_GetDescriptor($role) ) {
|
|
414
|
79 return $d->{value};
|
|
|
80 }
|
|
|
81 else {
|
|
|
82 return;
|
|
|
83 }
|
|
413
|
84 }
|
|
|
85
|
|
415
|
86 sub _GetDescriptor {
|
|
414
|
87 my ( $this, $role ) = @_;
|
|
|
88
|
|
413
|
89 my $d = $this->{$_cache}{$role};
|
|
414
|
90
|
|
|
91 # return descriptor if this is own descriptor and its level is 1 (i.e. it can't be overriden by the parent cache)
|
|
|
92 # otherwise the cache must be validated
|
|
|
93 return $d
|
|
|
94 if $d
|
|
|
95 and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 )
|
|
|
96 or $this->_Validate() );
|
|
|
97
|
|
415
|
98 # if there were no descriptor in cache we need to ensure that the cache
|
|
|
99 # chain is valid before reolving starts
|
|
|
100 $this->_Validate() unless $d;
|
|
|
101
|
|
414
|
102 # the cache chain is valid
|
|
|
103 # $d is not a valid descriptor
|
|
|
104
|
|
|
105 $d = undef;
|
|
|
106 my $prev;
|
|
|
107
|
|
|
108 if ( my $parents = $this->{$_parents} ) {
|
|
|
109 foreach my $bag ( @$parents, $this ) {
|
|
|
110
|
|
|
111 # check the cache;
|
|
|
112 unless ( my $t = $bag->{$_cache}{$role} ) {
|
|
|
113
|
|
|
114 # no cached entry this may be due cache flush
|
|
|
115 # go through own entries and find better entry than inherited from parents
|
|
|
116 foreach my $entry ( @{ $bag->{$_entries} } ) {
|
|
|
117 my $level = $entry->{isa}{$role};
|
|
|
118 if ( $level and ( not($prev) or $level <= $prev ) ) {
|
|
|
119 $d = $entry;
|
|
|
120 $prev = $level;
|
|
|
121 }
|
|
|
122 }
|
|
|
123
|
|
|
124 #cache it
|
|
|
125 $bag->{$_cache}{$role} = $d if $d;
|
|
|
126 }
|
|
|
127 else {
|
|
|
128 $d = $t;
|
|
|
129 $prev = $d->{isa}{$role};
|
|
|
130 }
|
|
|
131 }
|
|
413
|
132 }
|
|
414
|
133
|
|
|
134 return $d;
|
|
413
|
135 }
|
|
|
136
|
|
|
137 sub ResolveAll {
|
|
414
|
138 my ( $this, $role ) = @_;
|
|
|
139
|
|
|
140 return [
|
|
|
141 map $_->{value},
|
|
|
142 grep $_->{isa}{$role},
|
|
415
|
143 map @{$_->{$_entries}},
|
|
414
|
144 @{ $this->{$_parents} || [] },
|
|
|
145 $this
|
|
|
146 ];
|
|
|
147
|
|
413
|
148 }
|
|
|
149
|
|
|
150 sub Register {
|
|
414
|
151 my ( $this, $isa, $value ) = @_;
|
|
|
152
|
|
415
|
153 $isa = { $isa, 1 } unless ishash($isa);
|
|
413
|
154
|
|
414
|
155 push @{ $this->{$_entries} },
|
|
|
156 { owner => $this, isa => $isa, value => $value };
|
|
|
157 $this->{$_timestamp}++;
|
|
|
158
|
|
|
159 delete $this->{$_cache}{$_} foreach keys %$isa;
|
|
|
160
|
|
|
161 return $this;
|
|
412
|
162 }
|
|
|
163
|
|
414
|
164 1;
|
