|
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 {
|
|
417
|
44 unless ( $_[0]->{$_sealed} ) {
|
|
|
45 $_[0]->{$_sealed} = 1;
|
|
|
46 $_[0]->{$_timestamp} = 0; # from now the timestamp is important
|
|
415
|
47 }
|
|
414
|
48 }
|
|
|
49
|
|
|
50 sub _Validate {
|
|
|
51 my ($this) = @_;
|
|
|
52
|
|
415
|
53 my $chain = $this->{$_parents}
|
|
|
54 or return 1;
|
|
414
|
55
|
|
417
|
56 my $rev = 0; # rev 0 means that parent was never modified
|
|
|
57 # this allows to made more efficient checks
|
|
415
|
58 my $flush;
|
|
417
|
59
|
|
|
60 foreach my $bag ( @$chain, $this ) {
|
|
|
61
|
|
415
|
62 # we need to updated all bags after the first change was detected;
|
|
417
|
63 if ( $flush ||= $rev and $bag->{$_parentRev} != $rev ) {
|
|
|
64 $bag->{$_cache} = {};
|
|
|
65 $bag->{$_parentRev} = $rev;
|
|
|
66 }
|
|
|
67 $rev = $bag->{$_timestamp};
|
|
414
|
68 }
|
|
417
|
69
|
|
415
|
70 return $flush ? 0 : 1;
|
|
413
|
71 }
|
|
|
72
|
|
412
|
73 sub Resolve {
|
|
414
|
74 my ( $this, $role ) = @_;
|
|
|
75
|
|
415
|
76 die IMPL::InvalidArgumentException->new('role')
|
|
|
77 unless defined $role;
|
|
|
78
|
|
|
79 if ( my $d = $this->_GetDescriptor($role) ) {
|
|
414
|
80 return $d->{value};
|
|
|
81 }
|
|
|
82 else {
|
|
|
83 return;
|
|
|
84 }
|
|
413
|
85 }
|
|
|
86
|
|
415
|
87 sub _GetDescriptor {
|
|
414
|
88 my ( $this, $role ) = @_;
|
|
|
89
|
|
413
|
90 my $d = $this->{$_cache}{$role};
|
|
414
|
91
|
|
|
92 # return descriptor if this is own descriptor and its level is 1 (i.e. it can't be overriden by the parent cache)
|
|
|
93 # otherwise the cache must be validated
|
|
|
94 return $d
|
|
|
95 if $d
|
|
|
96 and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 )
|
|
|
97 or $this->_Validate() );
|
|
|
98
|
|
415
|
99 # if there were no descriptor in cache we need to ensure that the cache
|
|
|
100 # chain is valid before reolving starts
|
|
|
101 $this->_Validate() unless $d;
|
|
|
102
|
|
414
|
103 # the cache chain is valid
|
|
|
104 # $d is not a valid descriptor
|
|
|
105
|
|
|
106 $d = undef;
|
|
|
107 my $prev;
|
|
|
108
|
|
417
|
109 my $parents = $this->{$_parents};
|
|
|
110 my @bags = $parents ? ( @$parents, $this ) : ($this);
|
|
414
|
111
|
|
417
|
112 foreach my $bag (@bags) {
|
|
|
113
|
|
|
114 # check the cache;
|
|
|
115 unless ( my $t = $bag->{$_cache}{$role} ) {
|
|
414
|
116
|
|
|
117 # no cached entry this may be due cache flush
|
|
|
118 # go through own entries and find better entry than inherited from parents
|
|
417
|
119 foreach my $entry ( @{ $bag->{$_entries} } ) {
|
|
|
120 my $level = $entry->{isa}{$role};
|
|
|
121 if ( $level and ( not($prev) or $level <= $prev ) ) {
|
|
|
122 $d = $entry;
|
|
|
123 $prev = $level;
|
|
414
|
124 }
|
|
417
|
125 }
|
|
414
|
126
|
|
417
|
127 #cache it
|
|
|
128 $bag->{$_cache}{$role} = $d if $d;
|
|
|
129 }
|
|
|
130 else {
|
|
|
131 $d = $t;
|
|
|
132 $prev = $d->{isa}{$role};
|
|
414
|
133 }
|
|
413
|
134 }
|
|
414
|
135
|
|
|
136 return $d;
|
|
413
|
137 }
|
|
|
138
|
|
|
139 sub ResolveAll {
|
|
414
|
140 my ( $this, $role ) = @_;
|
|
|
141
|
|
|
142 return [
|
|
|
143 map $_->{value},
|
|
|
144 grep $_->{isa}{$role},
|
|
417
|
145 map @{ $_->{$_entries} },
|
|
414
|
146 @{ $this->{$_parents} || [] },
|
|
|
147 $this
|
|
|
148 ];
|
|
|
149
|
|
413
|
150 }
|
|
|
151
|
|
|
152 sub Register {
|
|
414
|
153 my ( $this, $isa, $value ) = @_;
|
|
|
154
|
|
415
|
155 $isa = { $isa, 1 } unless ishash($isa);
|
|
413
|
156
|
|
414
|
157 push @{ $this->{$_entries} },
|
|
|
158 { owner => $this, isa => $isa, value => $value };
|
|
|
159 $this->{$_timestamp}++;
|
|
|
160
|
|
|
161 delete $this->{$_cache}{$_} foreach keys %$isa;
|
|
|
162
|
|
|
163 return $this;
|
|
412
|
164 }
|
|
|
165
|
|
414
|
166 1;
|
